!#########################################################################################
!# ***************************************************************************************
!# <name> elasticity_2d_disp_smallDeform_static </name>
!# ***************************************************************************************
!#
!# <purpose>
!#   This module solves the basic elasticity problem:
!#     - 2D
!#     - pure displacement or mixed formulation
!#     - small deformation (i.e., a linear problem)
!#     - static
!#   There is also the possibility to compute a 2D Poisson problem.
!# </purpose>
!#########################################################################################

module elasticity_2d_smallDef_stat

  implicit none

contains

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

!<subroutine>
  subroutine elast_2d_smallDef_stat

    use storage
    use genoutput
    use paramlist
    use derivatives
    use bilinearformevaluation
    use linearformevaluation
    use bcassembly
    use linearsolver
    use linearsolverautoinitialise
    use spdiscprojection
    use filtersupport
    use linearsystemscalar
    use matrixfilters
    use vectorfilters
    use scalarpde
    use ucd
    use collection
    use elasticity_basic
    use elasticity_callback

!<description>
  ! This routine realises the basic elasticity solver. It performs the following tasks:
  !
  ! 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>

    ! array of problem levels for the multigrid solver
    type(t_level), dimension(:), pointer :: Rlevels

    ! bilinear form (matrix) and linear form (RHS) describing the problem to solve
    type(t_bilinearForm) :: rform
    type(t_linearForm) :: rlinform

    ! block vectors for solution, right hand side and temp. vector
    type(t_vectorBlock), target :: rsol, rrhs, rtempBlock

    ! variable for selecting a specifig boundary region
    type(t_boundaryRegion) :: rboundaryRegion

    ! solver node
    type(t_linsolNode), pointer :: p_rsolver

    ! array for the block structured system matrix
    type(t_matrixBlock), dimension(:), pointer :: Rmatrices

    ! filter chain that describes how to filter the matrix/vector before/during the
    ! solution process (used for implementing Dirichlet boundary conditions)
    type(t_filterChain), dimension(1), target :: RfilterChain
    type(t_filterChain), dimension(:), pointer :: p_RfilterChain

    ! error indicator during initialisation of the solver
    integer :: ierror

    ! output block for UCD output to GMV file
    type(t_ucdExport) :: rexport
    character(len=SYS_STRLEN) :: sucddir
    real(DP), dimension(:), pointer :: p_Ddata, p_Ddata2
    real(DP), Dimension(:,:), pointer :: p_DvertexCoords

    ! some auxiliary variables
    integer :: i, j, k, ilev, irow, jcol, nlevels

    ! collection structure to provide additional information to the coefficient routine.
    type(t_collection) :: rcollection

    ! parameter list read from the parameter file
    type (t_parlist) :: rparams

    ! flags whether projection for UCD output is necessary for u and/or p component
    logical :: bprojU, bprojP
    ! additional variables eventually needed for UCD output: discretisation structure,
    ! block vector, discrete boundary conditions
    type(t_blockDiscretisation) :: rdiscretisationUCD
    type(t_vectorBlock), target :: rsolUCD
    type(t_discreteBC), target :: rdiscreteBCUCD
    type(t_vectorBlock), pointer :: p_rsolUCD

    ! +------------------------------------------------------------------------
    ! | READ PARAMETER FILE
    ! +------------------------------------------------------------------------

    ! call subroutine that reads in the parameter file
    call elast_readParameterFile(rprob, rparams)

    ! +------------------------------------------------------------------------
    ! | BOUNDARY AND TRIANGULATION
    ! +------------------------------------------------------------------------

    ! set number of levels
    nlevels = rprob%ilevelMax - rprob%ilevelMin + 1

    ! allocate memory for all levels
    allocate(Rlevels(rprob%ilevelMin:rprob%ilevelMax))

    ! read in the basic triangulation (the boundary components have already been read
    ! within the routine elast_readParameterFile)
    call output_line('reading triangulation from file ' // &
                     trim(rprob%sgridFileTRI) // '...')
    call tria_readTriFile2D(Rlevels(rprob%ilevelMin)%rtriangulation, &
                            rprob%sgridFileTRI, rprob%rboundary)

    ! refine it once
    call tria_quickRefine2LevelOrdering(rprob%ilevelMin-1, &
           Rlevels(rprob%ilevelMin)%rtriangulation, rprob%rboundary)

    ! create information about adjacencies etc.
    call tria_initStandardMeshFromRaw(Rlevels(rprob%ilevelMin)%rtriangulation, &
                                      rprob%rboundary)

    ! create all refinement levels
    do ilev = rprob%ilevelMin+1, rprob%ilevelMax

      ! refine the grid using the 2-Level-Ordering algorithm
      call tria_refine2LevelOrdering(Rlevels(ilev-1)%rtriangulation, &
                                     Rlevels(ilev)%rtriangulation, rprob%rboundary)

      ! Create a standard mesh
      call tria_initStandardMeshFromRaw(Rlevels(ilev)%rtriangulation, rprob%rboundary)

    end do

    ! +------------------------------------------------------------------------
    ! | DISCRETISATION
    ! +------------------------------------------------------------------------

    call output_line('performing discretisation...')
    ! set up a block discretisation structure that specifies the blocks in the
    ! solution vector for all levels. For the scalar Poisson problem, we only have
    ! one block, for the elasticity problem either two (pure displacement) or three
    ! (mixed formulation) blocks. Do this for all levels.
    do ilev = rprob%ilevelMin, rprob%ilevelMax
      call spdiscr_initBlockDiscr(Rlevels(ilev)%rdiscretisation, rprob%nblocks, &
                                  Rlevels(ilev)%rtriangulation, rprob%rboundary)
    end do

    ! rdiscretisation%Rdiscretisations is a list of scalar discretisation structures
    ! for every component of the solution vector.
    do ilev = rprob%ilevelMin, rprob%ilevelMax
      ! create a discretisation for the first component
      call spdiscr_initDiscr_simple(Rlevels(ilev)%rdiscretisation%RspatialDiscr(1),&
                                    rprob%celement, rprob%ccubature2D, &
                                    Rlevels(ilev)%rtriangulation, rprob%rboundary)

      ! ...and copy this structure to the discretisation structure of the 2nd component
      ! (y-displacement) (no additional memory needed)
      do j = 2, rprob%ndim
        call spdiscr_duplicateDiscrSc (&
            Rlevels(ilev)%rdiscretisation%RspatialDiscr(1),&
            Rlevels(ilev)%rdiscretisation%RspatialDiscr(j))
      enddo

      if (rprob%cformulation .eq. FORMULATION_MIXED .or. &
          rprob%cformulation .eq. FORMULATION_STOKES) then
        ! In case of the mixed formulation, a separate discretisation is set up for the
        ! 3rd component (=pressure). It is 'derived' from the displacement discretisation.
        call spdiscr_deriveSimpleDiscrSc(Rlevels(ilev)%rdiscretisation%RspatialDiscr(1), &
                                         rprob%celementPress, rprob%ccubaturePress2D, &
                                         Rlevels(ilev)%rdiscretisation%RspatialDiscr(3))
      endif
    end do

    ! Now as the discretisation is set up, we can start to generate the structure of the
    ! system matrix which is to solve.
    do ilev = rprob%ilevelMin, rprob%ilevelMax

      ! Initialise the block matrix with default values based on
      ! the discretisation.
      call lsysbl_createMatBlockByDiscr(Rlevels(ilev)%rdiscretisation, &
                                        Rlevels(ilev)%rmatrix)

      if (rprob%cequation .eq. EQ_POISSON) then
        ! in case of the Poisson equation only one block has to be set up

        ! generate the structure of the system matrix
        call bilf_createMatrixStructure(Rlevels(ilev)%rdiscretisation%RspatialDiscr(1), &
               LSYSSC_MATRIX9, Rlevels(ilev)%rmatrix%RmatrixBlock(1,1))

        ! bilinear form (grad u_j, grad v_i) with u trial and v test function
        rform%itermCount = 2
        rform%Idescriptors(1,1) = DER_DERIV_X
        rform%Idescriptors(2,1) = DER_DERIV_X
        rform%Idescriptors(1,2) = DER_DERIV_Y
        rform%Idescriptors(2,2) = DER_DERIV_Y

        ! use constant coefficients
        rform%ballCoeffConstant = .true.
        rform%BconstantCoeff = .true.
        rform%Dcoefficients(1)  = 1.0
        rform%Dcoefficients(2)  = 1.0

        ! Build the matrix entries. The callback function elast_mat_Poisson_2D for the
        ! coefficients is only used if specifying ballCoeffConstant = .FALSE. and
        ! BconstantCoeff = .FALSE.
        call bilf_buildMatrixScalar(rform, .true., &
               Rlevels(ilev)%rmatrix%RmatrixBlock(1,1), elast_mat_Poisson_2D)
      else if (rprob%cequation .eq. EQ_ELASTICITY) then

        if (rprob%cformulation .eq. FORMULATION_MIXED .or. &
            rprob%cformulation .eq. FORMULATION_STOKES) then
          ! store the information that this matrix is of saddle-point type. Some solvers
          ! make use of this special structure.
          Rlevels(ilev)%rmatrix%imatrixSpec = LSYSBS_MSPEC_SADDLEPOINT
        endif

        ! common information for all blocks
        rform%ballCoeffConstant = .true.
        rform%BconstantCoeff = .true.

        ! In the following, u is the trial/ansatz function and v the test function,
        ! u1_x means the x-derivative u1 etc.
        ! rform%Idescriptors(1,i) corresponds to the trial/ansatz function of the i-th
        ! term, rform%Idescriptors(2,i) to the test function.
        ! rform%Dcoefficients(i) is the coefficient of the i-th term.
        do irow = 1, rprob%nblocks
          do jcol = 1, rprob%nblocks
            call bilf_createMatrixStructure(&
                   ! discretisation of the trial function space
                   Rlevels(ilev)%rdiscretisation%RspatialDiscr(jcol), &
                   LSYSSC_MATRIX9, Rlevels(ilev)%rmatrix%RmatrixBlock(irow,jcol), &
                   ! discretisation of the test function space
                   Rlevels(ilev)%rdiscretisation%RspatialDiscr(irow))

            if (irow .eq. 1 .and. jcol .eq. 1) then
              ! block (1,1)
              rform%itermCount = 2
              rform%Idescriptors(1,1) = DER_DERIV_X
              rform%Idescriptors(2,1) = DER_DERIV_X
              rform%Idescriptors(1,2) = DER_DERIV_Y
              rform%Idescriptors(2,2) = DER_DERIV_Y
              if (rprob%cformulation .eq. FORMULATION_DISPL) then
                ! (2*mu + lambda) * u1_x * v1_x + mu * u1_y * v1_y
                rform%Dcoefficients(1)  = 2*rprob%dmu + rprob%dlambda
                rform%Dcoefficients(2)  = rprob%dmu
              else if (rprob%cformulation .eq. FORMULATION_MIXED) then
                ! 2*mu * u1_x * v1_x + mu * u1_y * v1_y
                rform%Dcoefficients(1)  = 2*rprob%dmu
                rform%Dcoefficients(2)  = rprob%dmu
              else ! FORMULATION_STOKES
                ! 2*mu * (u1_x * v1_x + u1_y * v1_y)
                rform%Dcoefficients(1)  = 2*rprob%dmu
                rform%Dcoefficients(2)  = 2*rprob%dmu
              endif

            else if (irow .eq. 1 .and. jcol .eq. 2) then
              ! block (1,2)
              if (rprob%cformulation .eq. FORMULATION_DISPL) then
                ! mu * u2_x * v1_y + lambda * u2_y * v1_x
                rform%itermCount = 2
                rform%Idescriptors(1,1) = DER_DERIV_X
                rform%Idescriptors(2,1) = DER_DERIV_Y
                rform%Idescriptors(1,2) = DER_DERIV_Y
                rform%Idescriptors(2,2) = DER_DERIV_X
                rform%Dcoefficients(1)  = rprob%dmu
                rform%Dcoefficients(2)  = rprob%dlambda
              else if (rprob%cformulation .eq. FORMULATION_MIXED) then
                ! mu * u2_x * v1_y
                rform%itermCount = 1
                rform%Idescriptors(1,1) = DER_DERIV_X
                rform%Idescriptors(2,1) = DER_DERIV_Y
                rform%Dcoefficients(1)  = rprob%dmu
              else ! FORMULATION_STOKES
!BRAL: geht hier auch rform%itermCount = 0 ?!?
                rform%itermCount = 1
                rform%Idescriptors(1,1) = DER_FUNC
                rform%Idescriptors(2,1) = DER_FUNC
                rform%Dcoefficients(1)  = 0.0_DP
              endif

            else if (irow .eq. 2 .and. jcol .eq. 1) then
              ! block (2,1)
              if (rprob%cformulation .eq. FORMULATION_DISPL) then
                ! mu * u1_y * v2_x + lambda * u1_x * v2_y
                rform%itermCount = 2
                rform%Idescriptors(1,1) = DER_DERIV_Y
                rform%Idescriptors(2,1) = DER_DERIV_X
                rform%Idescriptors(1,2) = DER_DERIV_X
                rform%Idescriptors(2,2) = DER_DERIV_Y
                rform%Dcoefficients(1)  = rprob%dmu
                rform%Dcoefficients(2)  = rprob%dlambda
              else if (rprob%cformulation .eq. FORMULATION_MIXED) then
                ! mu * u1_y * v2_x
                rform%itermCount = 1
                rform%Idescriptors(1,1) = DER_DERIV_Y
                rform%Idescriptors(2,1) = DER_DERIV_X
                rform%Dcoefficients(1)  = rprob%dmu
              else ! FORMULATION_STOKES
!BRAL: geht hier auch rform%itermCount = 0 ?!?
                rform%itermCount = 1
                rform%Idescriptors(1,1) = DER_FUNC
                rform%Idescriptors(2,1) = DER_FUNC
                rform%Dcoefficients(1)  = 0.0_DP
              endif

            else if (irow .eq. 2 .and. jcol .eq. 2) then
              ! block (2,2)
              rform%itermCount = 2
              rform%Idescriptors(1,1) = DER_DERIV_X
              rform%Idescriptors(2,1) = DER_DERIV_X
              rform%Idescriptors(1,2) = DER_DERIV_Y
              rform%Idescriptors(2,2) = DER_DERIV_Y
              if (rprob%cformulation .eq. FORMULATION_DISPL) then
                ! mu * u2_x * v2_x + (2*mu + lambda) * u2_y * v2_y
                rform%Dcoefficients(1)  = rprob%dmu
                rform%Dcoefficients(2)  = 2*rprob%dmu + rprob%dlambda
              else if (rprob%cformulation .eq. FORMULATION_MIXED) then
                ! mu * u2_x * v2_x + 2*mu * u2_y * v2_y
                rform%Dcoefficients(1)  = rprob%dmu
                rform%Dcoefficients(2)  = 2*rprob%dmu
              else ! FORMULATION_STOKES
                ! 2*mu * (u2_x * v2_x + u2_y * v2_y)
                rform%Dcoefficients(1)  = 2*rprob%dmu
                rform%Dcoefficients(2)  = 2*rprob%dmu
              endif

            else if (irow .eq. 1 .and. jcol .eq. 3) then
              ! block (1,3) (only for FORMULATION_MIXED or FORMULATION_STOKES)
              ! -p * v1_x
              rform%itermCount = 1
              rform%Idescriptors(1,1) = DER_FUNC
              rform%Idescriptors(2,1) = DER_DERIV_X
              rform%Dcoefficients(1)  = -1.0_DP

            else if (irow .eq. 2 .and. jcol .eq. 3) then
              ! block (2,3) (only for FORMULATION_MIXED or FORMULATION_STOKES)
              ! -p * v2_y
              rform%itermCount = 1
              rform%Idescriptors(1,1) = DER_FUNC
              rform%Idescriptors(2,1) = DER_DERIV_Y
              rform%Dcoefficients(1)  = -1.0_DP

            else if (irow .eq. 3 .and. jcol .eq. 1) then
              ! block (3,1) (only for FORMULATION_MIXED or FORMULATION_STOKES)
              ! -u1_x * q
              rform%itermCount = 1
              rform%Idescriptors(1,1) = DER_DERIV_X
              rform%Idescriptors(2,1) = DER_FUNC
              rform%Dcoefficients(1)  = -1.0_DP

            else if (irow .eq. 3 .and. jcol .eq. 2) then
              ! block (3,2) (only for FORMULATION_MIXED or FORMULATION_STOKES)
              ! -u2_y * q
              rform%itermCount = 1
              rform%Idescriptors(1,1) = DER_DERIV_Y
              rform%Idescriptors(2,1) = DER_FUNC
              rform%Dcoefficients(1)  = -1.0_DP

            else if (irow .eq. 3 .and. jcol .eq. 3) then
              ! block (3,3) (only for FORMULATION_MIXED or FORMULATION_STOKES)
              ! -1/lambda * q * q in the compressible or nearly incompressible case,
              ! 0 * q * p in the purely incompressible case (since lambda = infinity)
              ! and in the Stokes case
              rform%itermCount = 1
              rform%Idescriptors(1,1) = DER_FUNC
              rform%Idescriptors(2,1) = DER_FUNC
              if (rprob%dnu .eq. 0.5 .or. rprob%cformulation .eq. FORMULATION_STOKES) then
!BRAL: geht hier auch rform%itermCount = 0 ?!?
                ! purely incompressible case
                rform%Dcoefficients(1)  = 0.0_DP
              else
                ! compressible / nearly incompressible case
                rform%Dcoefficients(1)  = -1.0_DP/rprob%dlambda
              endif
            endif

! BRAL:
! As soon as I have to use the callback function (i.e. when *not* all coefficients are
! zero), the following call has to be modified and put inside the above if-else-block.
            call bilf_buildMatrixScalar(rform, .true., &
                   Rlevels(ilev)%rmatrix%RmatrixBlock(irow,jcol), elast_mat_Poisson_2D)
          enddo
        enddo
      endif
    end do

    ! set up structure for RHS and solution vector by using the block matrix as template
    call lsysbl_createVecBlockIndMat(Rlevels(rprob%ilevelMax)%rmatrix, rrhs, .false.)
    call lsysbl_createVecBlockIndMat(Rlevels(rprob%ilevelMax)%rmatrix, rsol, .false.)

    ! clear RHS and solution vector on the finest level
    call lsysbl_clearVector(rrhs)
    call lsysbl_clearVector(rsol)

    ! assemble RHS vector corresponding to linear form (f,Phi_j)
    rlinform%itermCount = 1
    rlinform%Idescriptors(1) = DER_FUNC

    ! build the RHS entries on the finest level using callback functions to compute
    ! the coefficients
    if (rprob%cequation .eq. EQ_POISSON) then
      ! Poisson equation

      ! use the callback function elast_RHS_Poisson_2D_vol
      call linf_buildVectorScalar(Rlevels(rprob%ilevelMax)%rdiscretisation%RspatialDiscr(1),&
                    rlinform, .true., rrhs%RvectorBlock(1), elast_RHS_Poisson_2D_vol)

    else if (rprob%cequation .eq. EQ_ELASTICITY) then
      ! elasticity equation

      ! compute volume forces using the callback routine elast_RHS_2D_vol
      ! (x-direction: rcollection%IquickAccess(1) = 1,
      !  y-direction: rcollection%IquickAccess(1) = 2)
      do irow = 1, rprob%ndim
        rcollection%IquickAccess(1) = irow
        call linf_buildVectorScalar(&
               Rlevels(rprob%ilevelMax)%rdiscretisation%RspatialDiscr(irow), &
               rlinform, .true., rrhs%RvectorBlock(irow), elast_RHS_2D_vol, rcollection)
      enddo
    endif

    ! print number of DOF
    call lsysbl_getbase_double(rsol, p_Ddata)
    call output_line('Number of DOF: ' // trim(sys_siL(size(p_Ddata),12)))

    ! 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.
    do ilev = rprob%ilevelMin, rprob%ilevelMax
      call bcasm_initDiscreteBC(Rlevels(ilev)%rdiscreteBC)
    end do

    ! set up the boundary conditions per boundary and segment
    do i = 1, boundary_igetNBoundComp(rprob%rboundary)
      do j = 1,boundary_igetNsegments(rprob%rboundary,i)
        ! Create '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(rprob%rboundary, i, j, rboundaryRegion)
        ! mark start and end point as belonging to the region
        rboundaryRegion%iproperties = BDR_PROP_WITHSTART + BDR_PROP_WITHEND
        do k = 1, rprob%nblocks
          if (rprob%Cbc(k,j,i) .eq. BC_DIRICHLET) then
            do ilev = rprob%ilevelMin, rprob%ilevelMax
              ! We use this boundary region to 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='k' to indicate that we set up the Dirichlet BCs
              !   for the k-th component in the solution vector.
              ! - Discretise the boundary condition so that the BCs can be applied
              !   to matrices and vectors.
              ! - Add the calculated discrete BCs to rdiscreteBC for later use.
              call bcasm_newDirichletBConRealBD(Rlevels(ilev)%rdiscretisation, k, &
                     rboundaryRegion, Rlevels(ilev)%rdiscreteBC, elast_boundValue_2D)
            end do
          else if (rprob%Cbc(k,j,i) .eq. BC_NEUMANN) then
            ! store the current segment number in rcollection%IquickAccess(2) to make it
            ! accessible in the callback routine
            rcollection%IquickAccess(2) = j
            ! The non-zero Neumann contributations on the current boundary region are
            ! added to the RHS vector which already contains the volumetric contributions.
            if (rprob%cequation .eq. EQ_POISSON) then
              call linf_buildVectorScalarBdr2d(rlinform, rprob%ccubature1D, .false., &
                     rrhs%RvectorBlock(1), elast_RHS_Poisson_2D_bound, rboundaryRegion, &
                     rcollection)
            else if (rprob%cequation .eq. EQ_ELASTICITY) then
              ! store the current component in rcollection%IquickAccess(1), such that
              ! the callback routine elast_RHS_2D_surf knows whether to compute surface
              ! forces in x- or y-direction
              rcollection%IquickAccess(1) = k
              call linf_buildVectorScalarBdr2d(rlinform, rprob%ccubature1D, .false., &
                rrhs%RvectorBlock(k), elast_RHS_2D_surf, rboundaryRegion, rcollection)
            endif
          else
            call output_line('Invalid BC found!', OU_CLASS_ERROR, OU_MODE_STD, &
                             'elast_2d_smallDef_stat')
            call sys_halt()
          end if
        enddo
      end do ! end segments
    end do ! end boundaries

    ! attach the boundary conditions to the matrix (on all levels)
    do ilev = rprob%ilevelMin, rprob%ilevelMax
      Rlevels(ilev)%rmatrix%p_rdiscreteBC => Rlevels(ilev)%rdiscreteBC
    end do

    ! attach the boundary conditions to the solution and the RHS vector
    rrhs%p_rdiscreteBC => Rlevels(rprob%ilevelMax)%rdiscreteBC
    rsol%p_rdiscreteBC => Rlevels(rprob%ilevelMax)%rdiscreteBC

    ! Next step is to implement boundary conditions into the matrix, the solution and the
    ! RHS vector. This is done using a vector/matrix filter for discrete boundary
    ! conditions that modifies the vectors/matrix according to the boundary conditions.
    call vecfil_discreteBCrhs(rrhs)
    call vecfil_discreteBCsol(rsol)
    do ilev = rprob%ilevelMin, rprob%ilevelMax
      call matfil_discreteBC(Rlevels(ilev)%rmatrix)
    end do

    ! +------------------------------------------------------------------------
    ! | SOLVER
    ! +------------------------------------------------------------------------

    ! During the linear solve, the boundary conditions must frequently be imposed to
    ! vectors. This is done using a 'filter chain'. (As the linear solver does not work
    ! with the actual solution vectors but with defect vectors instead, a filter for
    ! implementing the real boundary conditions would be wrong.)
    RfilterChain(1)%ifilterType = FILTER_DISCBCDEFREAL

    ! The above filter chain is attached to the solver, so that it automatically filters
    ! the vector during the solution process. Set the following pointer for this.
    p_RfilterChain => RfilterChain

    call linsolinit_initFromFile(p_rsolver, rparams, "SOLVER", nlevels, p_RfilterChain)

    ! Attach the system matrices to the solver.

    ! Copy all matrices to a big matrix array and transfer it to the setMatrices routines,
    ! which intitialise the matrices on all levels. Note that no new memory is allocated,
    ! Rmatrices(:) only contains 'links' to existing matrices.
    allocate(Rmatrices(rprob%ilevelMin:rprob%ilevelMax))
    do ilev = rprob%ilevelMin, rprob%ilevelMax
      call lsysbl_duplicateMatrix(Rlevels(ilev)%rmatrix, Rmatrices(ilev), &
                                  LSYSSC_DUP_SHARE, LSYSSC_DUP_SHARE)
    end do

    call linsol_setMatrices(p_rsolver, Rmatrices(rprob%ilevelMin:rprob%ilevelMax))

    ! Rmatrices can be released immediately
    do ilev = rprob%ilevelMin,rprob%ilevelMax
      call lsysbl_releaseMatrix(Rmatrices(ilev))
    end do
    deallocate(Rmatrices)

    ! initialise solver structure/data
    call linsol_initStructure(p_rsolver, ierror)
    if (ierror .ne. LINSOL_ERR_NOERROR) then
      call output_line('Error in initialisation of the solver structure: ' // &
                       sys_siL(ierror,8), OU_CLASS_ERROR, OU_MODE_STD, &
                       'elast_2d_smallDef_stat')
      call sys_halt()
    endif
    call linsol_initData(p_rsolver, ierror)
    if (ierror .ne. LINSOL_ERR_NOERROR) then
      call output_line('Error in initialisation of the solver data: ' // &
                       sys_siL(ierror,8), OU_CLASS_ERROR, OU_MODE_STD, &
                       'elast_2d_smallDef_stat')
      call sys_halt()
    endif

    ! Solve the system. We want to solve Ax=b with b being the 'real' RHS and x being
    ! the 'real' solution vector, so linsol_solveAdaptively is the appropriate routine.
    ! If b is a defect and x a defect correction to be added to a solution vector, we
    ! would have to use linsol_precondDefect instead.
    call linsol_solveAdaptively(p_rsolver, rsol, rrhs, rtempBlock)

    call output_line('*********************************************************')
    ! number of iterations
    call output_line('Number of iterations: ' // sys_siL(p_rsolver%iiterations,8) )
    ! rate of convergence
    call output_line('Convergence rate: ' // sys_sdL(p_rsolver%dconvergenceRate,5) )
    ! rate of asymptotic convergence
    call output_line('Asymptotic convergence rate: ' // &
                      sys_sdL(p_rsolver%dasymptoticConvergenceRate,5) )
    call output_line('*********************************************************')
    call output_lbrk()

    ! calculate and display errors
    call elast_calcErrors(rprob, rsol)

    ! +------------------------------------------------------------------------
    ! | UCD output
    ! +------------------------------------------------------------------------

    ! All components that are not discretised with Q1/P1/Q0, must be projected for
    ! UCD output.

    ! inquire which components have to be projected
    bprojU = .false.
    bprojP = .false.
    if (rprob%celement .ne. EL_Q1) then
      bprojU = .true.
    endif
    if (rprob%cformulation .ne. FORMULATION_DISPL .and. &
        rprob%celementPress .ne. EL_Q0 .and. &
        rprob%celementPress .ne. EL_Q1 .and. &
        rprob%celementPress .ne. EL_QP1 .and. &
        rprob%celementPress .ne. EL_QP1NP .and. &
        rprob%celementPress .ne. EL_QP1NPD) then
      bprojP = .true.
    endif

    if (bprojU .or. bprojP) then
      call spdiscr_duplicateBlockDiscr(Rlevels(rprob%ilevelMax)%rdiscretisation, &
                                       rdiscretisationUCD)
      ! first treat the displacement discretisation
      if (bprojU) then
        do i = 1,rprob%ndim
          ! create a 'derived' simple discretisation structure based on Q1 by copying
          ! and modifying the discretisation structure
          call spdiscr_deriveSimpleDiscrSc(&
                 Rlevels(rprob%ilevelMax)%rdiscretisation%RspatialDiscr(i), EL_Q1, &
                 CUB_G2X2, rdiscretisationUCD%RspatialDiscr(i))
        enddo
      endif
      ! now treat the pressure discretisation
      if (bprojP) then
        call spdiscr_deriveSimpleDiscrSc(&
               Rlevels(rprob%ilevelMax)%rdiscretisation%RspatialDiscr(3), EL_Q1, &
               CUB_G2X2, rdiscretisationUCD%RspatialDiscr(3))
      endif

      ! set up a solution vector based on th new discretisation (allocates memory!)
      call lsysbl_createVecBlockByDiscr(rdiscretisationUCD, rsolUCD, .false.)

      ! convert the original solution vector according to the new discretisation
      call spdp_projectSolution (rsol, rsolUCD)

      ! discretise the boundary conditions according to the derived discretisation.
      call bcasm_initDiscreteBC(rdiscreteBCUCD)

      ! set up the boundary conditions per boundary and segment
      do i = 1, boundary_igetNBoundComp(rprob%rboundary)
        do j = 1,boundary_igetNsegments(rprob%rboundary,i)
          ! create boundary region
          call boundary_createRegion(rprob%rboundary, i, j, rboundaryRegion)
          ! mark start and end point as belonging to the region
          rboundaryRegion%iproperties = BDR_PROP_WITHSTART + BDR_PROP_WITHEND
          ! currently, only the displacements have to be treated
          do k = 1, rprob%ndim
            if (rprob%Cbc(k,j,i) .eq. BC_DIRICHLET) then
              ! create Dirichlet BC
              call bcasm_newDirichletBConRealBD(rdiscretisationUCD, k, rboundaryRegion, &
                                                rdiscreteBCUCD, elast_boundValue_2D)
            end if
          enddo
        end do ! end segments
      end do ! end boundaries

      ! attach the UCD boundary conditions to the UCD solution vector
      rsolUCD%p_rdiscreteBC => rdiscreteBCUCD

      ! modify the vector according to the attached discrete boundary conditions
      call vecfil_discreteBCsol(rsolUCD)
      p_rsolUCD => rsolUCD
    else
      ! otherwise simply set the pointer
      p_rsolUCD => rsol
    endif

    ! 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)) then
      sucddir = './gmv'
    endif

    ! get pointers to the arrays containing the displacement solutions
    call lsyssc_getbase_double(p_rsolUCD%RvectorBlock(1), p_Ddata)
    if (rprob%cequation .eq. EQ_ELASTICITY) then
      call lsyssc_getbase_double(p_rsolUCD%RvectorBlock(2), p_Ddata2)
    end if

    ! add displacements to the vertex coordinates when deformation is to be displayed in
    ! the gmv file
    if (rprob%cshowDeformation .eq. YES .and. rprob%cequation .eq. EQ_ELASTICITY) then
      ! get pointer to the arrays containing the vertex coordinates
      call storage_getbase_double2D( &
             Rlevels(rprob%ilevelMax)%rtriangulation%h_DvertexCoords, p_DvertexCoords)

      ! add displacements
      do i = 1,Rlevels(rprob%ilevelMax)%rtriangulation%NVT
        p_Dvertexcoords(1,i) = p_Dvertexcoords(1,i) + p_Ddata(i)
        p_Dvertexcoords(2,i) = p_dvertexCoords(2,i) + p_Ddata2(i)
      end do
    end if

    call output_line('Prepare UCD output...')
    ! initialise UCD export to GMV file
    call ucd_startGMV(rexport, UCD_FLAG_STANDARD, &
                      Rlevels(rprob%ilevelMax)%rtriangulation, &
                      trim(sucddir) // '/elasticity_2d.gmv')

    if (rprob%cequation .eq. EQ_ELASTICITY) then
      ! add the displacement solution to the file
      call ucd_addVarVertBasedVec(rexport, 'velocity', p_Ddata, p_Ddata2)
      if (rprob%cformulation .eq. FORMULATION_MIXED .or. &
          rprob%cformulation .eq. FORMULATION_STOKES) then
        ! add pressure solution
        call lsyssc_getbase_double(p_rsolUCD%RvectorBlock(3), p_Ddata)
        if (rprob%celementPress .eq. EL_Q1 .or. bprojP) then
          call ucd_addVariableVertexBased(rexport, 'pressure', UCD_VAR_STANDARD, p_Ddata)
        else ! Q0, P1, P1_NP, P1_NPD
          call ucd_addVariableElementBased(rexport, 'pressure', UCD_VAR_STANDARD, p_Ddata)
        endif
      endif
    else if (rprob%cequation .eq. EQ_POISSON) then
      call ucd_addVarVertBasedVec(rexport, 'velocity', p_Ddata)
    end if
!BRAL: output of derivatives, strains and stresses is missing...

    ! write the file
    call ucd_write(rexport)
    call ucd_release(rexport)

    ! -----------------------
    ! simulation finished
    ! -----------------------

    ! clean up so that all the memory is available again.

    ! release solver data and structure and the solver node itself
    call linsol_doneData(p_rsolver)
    call linsol_doneStructure(p_rsolver)
    call linsol_releaseSolver(p_rsolver)

    ! release block matrix/vectors
    call lsysbl_releaseVector(rsol)
    if (bprojU .or. bprojP) then
      call lsysbl_releaseVector(rsolUCD)
    endif
    call lsysbl_releaseVector(rtempBlock)
    call lsysbl_releaseVector(rrhs)
    do ilev = rprob%ilevelMax, rprob%ilevelMin, -1
      call lsysbl_releaseMatrix(Rlevels(ilev)%rmatrix)
    end do

    ! release discrete version of the boundary conditions
    do ilev = rprob%ilevelMax, rprob%ilevelMin, -1
      call bcasm_releaseDiscreteBC(Rlevels(ilev)%rdiscreteBC)
    end do
    if (bprojU .or. bprojP) then
      call bcasm_releaseDiscreteBC(rdiscreteBCUCD)
    endif

    ! release discretisation structure
    do ilev = rprob%ilevelMax, rprob%ilevelMin, -1
      call spdiscr_releaseBlockDiscr(Rlevels(ilev)%rdiscretisation)
    end do
    if (bprojU .or. bprojP) then
      call spdiscr_releaseBlockDiscr(rdiscretisationUCD)
    endif

    ! release triangulation
    do ilev = rprob%ilevelMax, rprob%ilevelMin, -1
      call tria_done(Rlevels(ilev)%rtriangulation)
    end do
    deallocate(Rlevels)

    ! release domain
    call boundary_release(rprob%rboundary)

    ! release all manually allocated arrays
    deallocate(rprob%Cbc)
    if (rprob%csimulation .eq. SIMUL_REAL) then
      deallocate(rprob%DbcValue)
    endif
    if (rprob%nevalPoints .gt. 0) then
      deallocate(rprob%DevalPoints, rprob%Dvalues)
      if (rprob%nrefSols .gt. 0) then
        deallocate(rprob%DrefSols)
      endif
    endif

  end subroutine elast_2d_smallDef_stat

end module elasticity_2d_smallDef_stat


!==========================================================================
elemental function gsw_beta_const_t_exact (sa, t, p)
!==========================================================================
!
! Calculates saline (haline) contraction coefficient of seawater at
! constant in-situ temperature.
!
! sa     : Absolute Salinity                               [g/kg]
! t      : in-situ temperature                             [deg C]
! p      : sea pressure                                    [dbar]
!
! gsw_beta_const_t_exact : haline contraction coefficient  [kg/g]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, t, p

real (r8) :: gsw_beta_const_t_exact

integer, parameter :: n0=0, n1=1

gsw_beta_const_t_exact = -gsw_gibbs(n1,n0,n1,sa,t,p)/gsw_gibbs(n0,n0,n1,sa,t,p)

return
end function

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


! This is a constant gamma equation of state, using and ideal gas.
!
! We compute the mean molecular weight, mu, based on the mass fractions
! of the different species.
!
! There are 2 ways to compute mu, depending on whether the gas is
! completely ionized or not.
!
! For a neutral gas, the mean molecular weight is:
!
!   1/mu = sum_k { X_k / A_k }
!
! For a completely ionized gas, the mean molecular weight is:
!
!   1/mu = sum_k { (1 + Z_k) X_k / A_k }  = 1/mu_e + 1/mu
!
! It is expected that composition() is called the input eos_t
! state before calling this eos routine.
!
! The ratio of specific heats (gamma) is allowed to vary.  NOTE: the
! expression for entropy is only valid for an ideal MONATOMIC gas
! (gamma = 5/3).

module actual_eos_module

  use bl_types
  use bl_space
  use bl_error_module
  use bl_constants_module
  use network, only: nspec, aion, zion
  use eos_type_module

  implicit none

  private

  character (len=64) :: eos_name = "gamma_law_general"

  real (kind=dp_t), save :: gamma_const

  logical, save :: assume_neutral

  public actual_eos, actual_eos_init, eos_name

contains

  subroutine actual_eos_init

    use extern_probin_module, only: eos_gamma, eos_assume_neutral

    if (eos_gamma > ZERO) then
       gamma_const = eos_gamma
    else
       call bl_error("eos_gamma cannot be < 0")
    endif

    assume_neutral = eos_assume_neutral

  end subroutine actual_eos_init

  subroutine actual_eos(input, state)

    use fundamental_constants_module, only: k_B, n_A, hbar

    implicit none

    integer,           intent(in   ) :: input
    type (eos_t),      intent(inout) :: state

    ! get the mass of a nucleon from Avogadro's number.
    real (kind=dp_t), parameter :: m_nucleon = ONE / n_A
    real (kind=dp_t), parameter :: fac = ONE / (TWO*M_PI*hbar*hbar)**1.5d0

    real (kind=dp_t) :: Tinv, rhoinv

    ! calculate mu

    if (assume_neutral) then
       state % mu = state % abar
    else
       state % mu = ONE / sum( (ONE + zion(:)) * state % xn(:) / aion(:) )
    endif

    !-------------------------------------------------------------------------
    ! for all EOS input modes EXCEPT eos_input_rt, first compute dens
    ! and temp as needed from the inputs
    !-------------------------------------------------------------------------

    select case (input)

    case (eos_input_rt)

       ! dens, temp, and xmass are inputs

       ! we don't need to do anything here
       continue

    case (eos_input_rh)

       ! dens, enthalpy, and xmass are inputs

       ! Solve for the temperature:
       ! h = e + p/rho = (p/rho)*[1 + 1/(gamma-1)] = (p/rho)*gamma/(gamma-1)

       state % T = (state % h * state % mu * m_nucleon / k_B)*(gamma_const - ONE)/gamma_const

    case (eos_input_tp )

       ! temp, pres, and xmass are inputs

       ! Solve for the density:
       ! p = rho k T / (mu m_nucleon)

       state%rho = state%p * state%mu * m_nucleon / (k_B * state%T)

    case (eos_input_rp )

       ! dens, pres, and xmass are inputs

       ! Solve for the temperature:
       ! p = rho k T / (mu m_nucleon)

       state%T = state%p * state%mu * m_nucleon / (k_B * state%rho)

    case (eos_input_re)

       ! dens, energy, and xmass are inputs

       ! Solve for the temperature
       ! e = k T / [(mu m_nucleon)*(gamma-1)]

       state%T = state%e * state%mu * m_nucleon * (gamma_const - ONE) / k_B

    case (eos_input_ps)

       ! pressure, entropy, and xmass are inputs

       ! Solve for the temperature
       ! Invert Sackur-Tetrode eqn (below) using
       ! rho = p mu m_nucleon / (k T)

       state%T = state%p**(TWO/FIVE) * &
            ( TWO*M_PI*hbar*hbar/(state%mu*m_nucleon) )**(THREE/FIVE) * &
            dexp(TWO*state%mu*m_nucleon*state%s/(FIVE*k_B) - ONE) / k_B

       ! Solve for the density
       ! rho = p mu m_nucleon / (k T)

       state%rho = state%p*state%mu*m_nucleon/(k_B*state%T)

    case (eos_input_ph)

       call bl_error("EOS: eos_input_ph not implemented")

    case (eos_input_th)

       ! temperature, enthalpy, and xmass are inputs

       ! this system is underconstrained

       call bl_error("EOS: eos_input_th is not a valid input for the gamma law EOS")

    case default

       call bl_error("EOS: invalid input")

    end select

    !-------------------------------------------------------------------------
    ! now we have the density and temperature (and mass fractions /
    ! mu), regardless of the inputs.
    !-------------------------------------------------------------------------

    Tinv = ONE / state % T
    rhoinv = ONE / state % rho

    ! compute the pressure simply from the ideal gas law, and the
    ! specific internal energy using the gamma-law EOS relation
    state%p = state%rho * k_B * state%T / (state%mu * m_nucleon)
    state%e = state%p / (gamma_const - ONE) * rhoinv

    ! enthalpy is h = e + p/rho
    state%h = state%e + state%p * rhoinv

    ! entropy (per gram) of an ideal monoatomic gas (the Sackur-Tetrode equation)
    ! NOTE: this expression is only valid for gamma = 5/3.
    state%s = (k_B/(state%mu*m_nucleon))*(2.5_dp_t + &
         log( ( (state%mu*m_nucleon)**2.5_dp_t*rhoinv)*(k_B*state%T)**1.5_dp_t * fac) )

    ! compute the thermodynamic derivatives and specific heats
    state % dpdT = state%p * Tinv
    state % dpdr = state%p * rhoinv
    state % dedT = state%e * Tinv
    state % dedr = ZERO
    state % dsdT = 1.5_dp_t * (k_B / (state%mu * m_nucleon*state%T))
    state % dsdr = - (k_B / (state%mu* m_nucleon*state%rho) )
    state % dhdT = state % dedT + state % dpdT * rhoinv
    state % dhdr = ZERO

    state%cv = state%dedT
    state%cp = gamma_const*state%cv

    state%gam1 = gamma_const

    ! electron-specific stuff (really for the degenerate EOS)
    state%xne = 0.d0
    state%eta = 0.d0
    state%pele = 0.d0

    ! sound speed
    state%cs = sqrt(gamma_const * state%p * rhoinv)

    state % dpdA = - state % p * (ONE/state % abar)
    state % dedA = - state % e * (ONE/state % abar)

    if (assume_neutral) then
       state % dpdZ = ZERO
       state % dedZ = ZERO
    else
       state % dpdZ = state % p * (ONE/(ONE + state % zbar))
       state % dedZ = state % e * (ONE/(ONE + state % zbar))
    endif

  end subroutine actual_eos

end module actual_eos_module


      subroutine run_iiiii(j,i1,i2,i3,i4,i5,DetGr,Xtwiddle0,Gtwiddle,
     . Shat6,N0)
      implicit none
C---Fixes Diiiii according to extension of Denner-Dittmaier
c---knowing D00iiii with a correction of order Delta*Diiiiii
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,j,i1,i2,i3,i4,i5,n
      double precision DetGr,Xtwiddle0(3),Gtwiddle(3,3)
      double complex Shat6s(3,z5max,-2:0),Shat6(3,z5max,-2:0)

      do ep=-2,0
      do n=1,3
      Shat6s(n,z5(i1,i2,i3,i4,i5),ep)=Shat6(n,z5(i1,i2,i3,i4,i5),ep)
     .   -2d0*(delta(n,i1)*Dv(N0+dzziiii(z4(i2,i3,i4,i5)),ep)
     .        +delta(n,i2)*Dv(N0+dzziiii(z4(i1,i3,i4,i5)),ep)
     .        +delta(n,i3)*Dv(N0+dzziiii(z4(i1,i2,i4,i5)),ep)
     .        +delta(n,i4)*Dv(N0+dzziiii(z4(i1,i2,i3,i5)),ep)
     .        +delta(n,i5)*Dv(N0+dzziiii(z4(i1,i2,i3,i4)),ep))
      enddo

      Dv(diiiii(z5(i1,i2,i3,i4,i5))+N0,ep)=-(
     . +Gtwiddle(j,1)*Shat6s(1,z5(i1,i2,i3,i4,i5),ep)
     . +Gtwiddle(j,2)*Shat6s(2,z5(i1,i2,i3,i4,i5),ep)
     . +Gtwiddle(j,3)*Shat6s(3,z5(i1,i2,i3,i4,i5),ep)
     . -DetGr*Dv(diiiiii(z6(j,i1,i2,i3,i4,i5))+N0,ep))
     . /Xtwiddle0(j)

      enddo

      return
      end


C
C $Id: mlfnsp.f,v 1.5 2008-07-27 00:17:09 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      REAL FUNCTION MLFNSP (E0,E1,E2,E3,PHI)
C
C This function computes the constant M.
C
      IMPLICIT REAL (A-Z)
      DATA TWO,FOUR,SIX /2.0E0,4.0E0,6.0E0/
C
      MLFNSP = E0 * PHI - E1 * SIN (TWO * PHI) + E2 * SIN (FOUR * PHI)
     * - E3 * SIN (SIX * PHI)
C
      RETURN
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id$
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE MRADF3 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2)
      REAL       CH(IN2,IDO,3,L1)  ,CC(IN1,IDO,L1,3)     ,
     1                WA1(IDO)     ,WA2(IDO)
C
      M1D = (M-1)*IM1+1
      M2S = 1-IM2
      ARG=2.*4.*ATAN(1.0)/3.
      TAUR=COS(ARG)
      TAUI=SIN(ARG)
      DO 101 K=1,L1
         M2 = M2S
         DO 1001 M1=1,M1D,IM1
         M2 = M2+IM2
         CH(M2,1,1,K) = CC(M1,1,K,1)+(CC(M1,1,K,2)+CC(M1,1,K,3))
         CH(M2,1,3,K) = TAUI*(CC(M1,1,K,3)-CC(M1,1,K,2))
         CH(M2,IDO,2,K) = CC(M1,1,K,1)+TAUR*
     1      (CC(M1,1,K,2)+CC(M1,1,K,3))
 1001    CONTINUE
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            M2 = M2S
            DO 1002 M1=1,M1D,IM1
            M2 = M2+IM2
            CH(M2,I-1,1,K) = CC(M1,I-1,K,1)+((WA1(I-2)*CC(M1,I-1,K,2)+
     1       WA1(I-1)*CC(M1,I,K,2))+(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*
     1       CC(M1,I,K,3)))
            CH(M2,I,1,K) = CC(M1,I,K,1)+((WA1(I-2)*CC(M1,I,K,2)-
     1       WA1(I-1)*CC(M1,I-1,K,2))+(WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*
     1       CC(M1,I-1,K,3)))
            CH(M2,I-1,3,K) = (CC(M1,I-1,K,1)+TAUR*((WA1(I-2)*
     1       CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2))+(WA2(I-2)*
     1       CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3))))+(TAUI*((WA1(I-2)*
     1       CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2))-(WA2(I-2)*
     1       CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3))))
            CH(M2,IC-1,2,K) = (CC(M1,I-1,K,1)+TAUR*((WA1(I-2)*
     1       CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2))+(WA2(I-2)*
     1       CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3))))-(TAUI*((WA1(I-2)*
     1       CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2))-(WA2(I-2)*
     1       CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3))))
            CH(M2,I,3,K) = (CC(M1,I,K,1)+TAUR*((WA1(I-2)*CC(M1,I,K,2)-
     1       WA1(I-1)*CC(M1,I-1,K,2))+(WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*
     1       CC(M1,I-1,K,3))))+(TAUI*((WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*
     1       CC(M1,I,K,3))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*
     1       CC(M1,I,K,2))))
            CH(M2,IC,2,K) = (TAUI*((WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*
     1       CC(M1,I,K,3))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*
     1       CC(M1,I,K,2))))-(CC(M1,I,K,1)+TAUR*((WA1(I-2)*CC(M1,I,K,2)-
     1       WA1(I-1)*CC(M1,I-1,K,2))+(WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*
     1       CC(M1,I-1,K,3))))
 1002       CONTINUE
  102    CONTINUE
  103 CONTINUE
      RETURN
      END


subroutine correction(u, v, uf, vf, pc, p, auf_bar, avf_bar, p_uf, p_vf, d_u, d_v, dx, dy, imax, jmax, xi, xf, alphap)
        !use variables
        use parallel_variables
use kind_parameters
        implicit none

        !! Input variables

        integer, intent(in):: imax, jmax, xi, xf
        real(kind=dp), dimension(imax, xi-1:xf+1):: u, v, pc, p, d_u, d_v
        real(kind=dp), dimension(imax-1, xi-1:xf+1):: uf, auf_bar, p_uf, pc_uf
        real(kind=dp), dimension(imax, xi-1:xf+1):: vf, avf_bar, p_vf, pc_vf
        real(kind=dp):: dx(imax), dy(jmax)
        real(kind=dp):: alphap

        !! Other local variables
        integer:: iu, ju, ip, jp, iv, jv
        real(kind=dp):: fe_area, fn_area

        !write(*,*) 'alphap = ', alphap

        ! Calculate boundary pressure correction values

        if (xi .eq. 2) then

                do ip=2,imax-1

                !     pc(ip,1) = (15.0*pc(ip,2) - 10.0*pc(ip,3) + 3.0*pc(ip,4))/8.0d0
                pc(ip,1) = pc(ip,2)

                end do

        end if

        if (xf .eq. jmax-1) then

                do ip=2,imax-1

                !       pc(ip,jmax) = (15.0*pc(ip,jmax-1) - 10.0*pc(ip,jmax-2) + 3.0*pc(ip,jmax-3))/8.0d0
                pc(ip,jmax) = pc(ip,jmax-1)

                end do

        end if

        do jp=xi,xf

        !    pc(1,jp) = (15.0*pc(2,jp) - 10.0*pc(3,jp) + 3.0*pc(4,jp))/8.0d0
        !    pc(imax,jp) = (15.0*pc(imax-1,jp) - 10.0*pc(imax-2,jp) + 3.0*pc(imax-3,jp))/8.0d0
        pc(1,jp) = pc(2,jp)
        pc(imax,jp) = pc(imax-1,jp)

        end do

        call exchange_data(pc, imax, xi, xf)

        ! Correct face velocities

        do ju = xi,xf

        do iu = 2,imax-2

        uf(iu,ju) = uf(iu,ju) + dy(ju)/auf_bar(iu,ju)*(pc(iu,ju)-pc(iu+1,ju))

        end do

        end do

        do jv = xi,xf

        do iv=2,imax-1

        vf(iv,jv) = vf(iv,jv) + dx(iv)/avf_bar(iv,jv)*(pc(iv,jv)-pc(iv,jv+1))

        end do

        end do

        if (xf .eq. jmax-1) then

                do iv = 2,imax-1

                vf(iv,jmax-1) = v(iv,jmax)

                end do

        end if

        ! Correct nodal pressures

        do jp = xi,xf

        do ip = 2,imax-1

        p(ip,jp) = p(ip,jp) + alphap*pc(ip,jp)

        end do

        end do

        if (xi .eq. 2) then

                do ip=2,imax-1

                p(ip,1) = (15.0*p(ip,2) - 10.0*p(ip,3) + 3.0*p(ip,4))/8.0d0
                !     p(ip,1) = p(ip,2)

                end do

        end if

        if (xf .eq. jmax-1) then

                do ip=2,imax-1

                p(ip,jmax) = (15.0*p(ip,jmax-1) - 10.0*p(ip,jmax-2) + 3.0*p(ip,jmax-3))/8.0d0
                !       p(ip,jmax) = p(ip,jmax-1)

                end do

        end if

        do jp=xi,xf

        p(1,jp) = (15.0*p(2,jp) - 10.0*p(3,jp) + 3.0*p(4,jp))/8.0d0
        p(imax,jp) = (15.0*p(imax-1,jp) - 10.0*p(imax-2,jp) + 3.0*p(imax-3,jp))/8.0d0
        !    p(1,jp) = p(2,jp)
        !    p(imax,jp) = p(imax-1,jp)

        end do

        call exchange_data(p, imax, xi, xf)

        ! Calculate pressure and pressure correction values at interface

        do jp = xi,xf

        do ip = 2,imax-1

        fe_area = dx(ip+1)/(dx(ip+1)+dx(ip))
        p_uf(ip,jp) = fe_area*p(ip,jp) + (1.0d0-fe_area)*p(ip+1,jp)
        pc_uf(ip,jp) = fe_area*pc(ip,jp) + (1.0d0-fe_area)*pc(ip+1,jp)

        end do

        end do

        do jp =xi,xf

        do ip = 2,imax-1

        fn_area = dy(jp+1)/(dy(jp+1)+dy(jp))
        p_vf(ip,jp) = fn_area*p(ip,jp) + (1.0d0-fn_area)*p(ip,jp+1)
        pc_vf(ip,jp) = fn_area*pc(ip,jp) + (1.0d0-fn_area)*pc(ip,jp+1)

        end do

        end do

        pc_uf(1,xi-1:xf+1) = pc(1,xi-1:xf+1)
        p_uf(1,xi-1:xf+1) = p(1,xi-1:xf+1)

        pc_uf(imax-1,xi-1:xf+1) = pc(imax,xi-1:xf+1)
        p_uf(imax-1,xi-1:xf+1) = p(imax,xi-1:xf+1)

        !pc_uf(1,xi-1:xf+1) = pc_uf(2,xi-1:xf+1)
        !p_uf(1,xi-1:xf+1) = p_uf(2,xi-1:xf+1)

        !pc_uf(imax-1,xf-1:xf+1) = pc_uf(imax-2,xf-1:xf+1)
        !p_uf(imax-1,xf-1:xf+1) = p_uf(imax-2,xf-1:xf+1)

        if (xi .eq. 2) then

                pc_vf(1:imax,1) = pc(1:imax,1)
                p_vf(1:imax,1) = p(1:imax,1)

                !pc_vf(1:imax,1) = pc_vf(2:imax,1)
                !p_vf(1:imax,1) = p_vf(2:imax,1)

        end if

        if (xf .eq. jmax-1) then

                pc_vf(1:imax,jmax-1) = pc(1:imax,jmax)
                p_vf(1:imax,jmax-1) = p(1:imax,jmax)

                !pc_vf(1:imax,jmax-1) = pc_vf(1:imax,jmax-2)
                !p_vf(1:imax,jmax-1) = p_vf(1:imax,jmax-2)

        end if

        call exchange_data(pc_uf, imax-1, xi, xf)
        call exchange_data(pc_vf, imax, xi, xf)
        call exchange_data(p_uf, imax-1, xi, xf)
        call exchange_data(p_vf, imax, xi, xf)

        ! Correct nodal velocities using pressure correction at interfaces

        do ju = xi,xf

        do iu = 2,imax-1

        u(iu,ju) = u(iu,ju) + d_u(iu,ju)*(pc_uf(iu-1,ju)-pc_uf(iu,ju))

        end do

        end do

        do jv = xi,xf

        do iv=2,imax-1

        v(iv,jv) = v(iv,jv) + d_v(iv,jv)*(pc_vf(iv,jv-1)-pc_vf(iv,jv))

        end do

        end do

        uf(1,xi-1:xf+1) = u(1,xi-1:xf+1)
        uf(imax-1,xi-1:xf+1) = u(imax,xi-1:xf+1)

        vf(1,xi-1:xf+1) = v(1,xi-1:xf+1)
        vf(imax,xi-1:xf+1) = v(imax,xi-1:xf+1)

        call exchange_data(uf, imax-1, xi, xf)
        call exchange_data(vf, imax, xi, xf)
        call exchange_data(u, imax, xi, xf)
        call exchange_data(v, imax, xi, xf)

end subroutine


!-----------------------------------------------------------------------
      subroutine ppiclf_user_SetYdot
!
      implicit none
!
      include "PPICLF"
!
! Internal:
!
      real*8 rmass,fbx,fby,fbz,fcx,fcy,fcz
      integer*4 i
!
! evaluate ydot
      do i=1,ppiclf_npart
         ! Particle mass
         rmass = ppiclf_rprop(PPICLF_R_JVOLP,i)
     >          *ppiclf_rprop(PPICLF_R_JRHOP,i)

         ! Gravity
         fbx  = 0.0d0
         fby  = -9.8d0*rmass
         fbz  = 0.0d0

         ! Collision search
         call ppiclf_solve_NearestNeighbor(i)

         ! User implemented collision force from EvalNearestNeighbor()
         fcx  = ppiclf_ydotc(PPICLF_JVX,i)
         fcy  = ppiclf_ydotc(PPICLF_JVY,i)
         fcz  = ppiclf_ydotc(PPICLF_JVZ,i)

         ! set ydot for all PPICLF_LRS number of equations
         ppiclf_ydot(PPICLF_JX ,i) = ppiclf_y(PPICLF_JVX,i)
         ppiclf_ydot(PPICLF_JY ,i) = ppiclf_y(PPICLF_JVY,i)
         ppiclf_ydot(PPICLF_JZ ,i) = ppiclf_y(PPICLF_JVZ,i)
         ppiclf_ydot(PPICLF_JVX,i) = (fbx+fcx)/rmass
         ppiclf_ydot(PPICLF_JVY,i) = (fby+fcy)/rmass
         ppiclf_ydot(PPICLF_JVZ,i) = (fbz+fcz)/rmass
      enddo
! evaluate ydot

      return
      end
!-----------------------------------------------------------------------
      subroutine ppiclf_user_MapProjPart(map,y,ydot,ydotc,rprop)
!
      implicit none
!
! Input:
!
      real*8 y    (PPICLF_LRS)
      real*8 ydot (PPICLF_LRS)
      real*8 ydotc(PPICLF_LRS)
      real*8 rprop(PPICLF_LRP)
!
! Output:
!
      real*8 map  (PPICLF_LRP_PRO)
!

      return
      end
!-----------------------------------------------------------------------
      subroutine ppiclf_user_EvalNearestNeighbor
     >                                        (i,j,yi,rpropi,yj,rpropj)
!
      implicit none
!
      include "PPICLF"
!
! Input:
!
      integer*4 i
      integer*4 j
      real*8 yi    (PPICLF_LRS)
      real*8 rpropi(PPICLF_LRP)
      real*8 yj    (PPICLF_LRS)
      real*8 rpropj(PPICLF_LRP)
!
! Internal:
!
      real*8 ksp,erest
      common /ucollision/ ksp,erest
#ifdef PPICLC
      BIND(C, name="ucollision") :: /ucollision/ ! c binding
#endif

      real*8 rpi2, rthresh, rxdiff, rydiff, rzdiff, rdiff, rm1, rm2,
     >       rmult, eta, rbot, rn_12x, rn_12y, rn_12z, rdelta12,
     >       rv12_mag, rv12_mage, rksp_max, rnmag, rksp_wall, rextra
!
      rpi2  =  9.869604401089358d0

      ! other particles
      if (j .ne. 0) then
         rthresh  = 0.5d0*(rpropi(PPICLF_R_JDP) + rpropj(PPICLF_R_JDP))

         rxdiff = yj(PPICLF_JX) - yi(PPICLF_JX)
         rydiff = yj(PPICLF_JY) - yi(PPICLF_JY)
         rzdiff = yj(PPICLF_JZ) - yi(PPICLF_JZ)

         rdiff = sqrt(rxdiff**2 + rydiff**2 + rzdiff**2)

         if (rdiff .gt. rthresh) return

         rm1 = rpropi(PPICLF_R_JRHOP)*rpropi(PPICLF_R_JVOLP)
         rm2 = rpropj(PPICLF_R_JRHOP)*rpropj(PPICLF_R_JVOLP)

         rmult = 1.0d0/sqrt(1.0d0/rm1+1.0d0/rm2)
         eta   = 2.0d0*sqrt(ksp)*log(erest)/sqrt(log(erest)**2+rpi2)
     >           *rmult

         rbot = 1.0d0/rdiff
         rn_12x = rxdiff*rbot
         rn_12y = rydiff*rbot
         rn_12z = rzdiff*rbot

         rdelta12 = rthresh - rdiff

         rv12_mag = (yj(PPICLF_JVX)-yi(PPICLF_JVX))*rn_12x +
     >              (yj(PPICLF_JVY)-yi(PPICLF_JVY))*rn_12y +
     >              (yj(PPICLF_JVZ)-yi(PPICLF_JVZ))*rn_12z

         rv12_mage = rv12_mag*eta
         rksp_max  = ksp*rdelta12
         rnmag     = -rksp_max - rv12_mage

         ppiclf_ydotc(PPICLF_JVX,i) = ppiclf_ydotc(PPICLF_JVX,i)
     >                              + rnmag*rn_12x
         ppiclf_ydotc(PPICLF_JVY,i) = ppiclf_ydotc(PPICLF_JVY,i)
     >                              + rnmag*rn_12y
         ppiclf_ydotc(PPICLF_JVZ,i) = ppiclf_ydotc(PPICLF_JVZ,i)
     >                              + rnmag*rn_12z

      ! boundaries
      elseif (j .eq. 0) then

         rksp_wall = ksp

         ! give a bit larger collision threshold for walls
         rextra   = 0.5d0
         rthresh  = (0.5d0+rextra)*rpropi(PPICLF_R_JDP)

         rxdiff = yj(PPICLF_JX) - yi(PPICLF_JX)
         rydiff = yj(PPICLF_JY) - yi(PPICLF_JY)
         rzdiff = yj(PPICLF_JZ) - yi(PPICLF_JZ)

         rdiff = sqrt(rxdiff**2 + rydiff**2 + rzdiff**2)

         if (rdiff .gt. rthresh) return

         rm1 = rpropi(PPICLF_R_JRHOP)*rpropi(PPICLF_R_JVOLP)

         rmult = sqrt(rm1)
         eta   = 2.0d0*sqrt(rksp_wall)*log(erest)
     >           /sqrt(log(erest)**2+rpi2)*rmult

         rbot = 1.0d0/rdiff
         rn_12x = rxdiff*rbot
         rn_12y = rydiff*rbot
         rn_12z = rzdiff*rbot

         rdelta12 = rthresh - rdiff

         rv12_mag = -1.0d0*(yi(PPICLF_JVX)*rn_12x +
     >                      yi(PPICLF_JVY)*rn_12y +
     >                      yi(PPICLF_JVZ)*rn_12z)

         rv12_mage = rv12_mag*eta
         rksp_max  = rksp_wall*rdelta12
         rnmag     = -rksp_max - rv12_mage

         ppiclf_ydotc(PPICLF_JVX,i) = ppiclf_ydotc(PPICLF_JVX,i)
     >                              + rnmag*rn_12x
         ppiclf_ydotc(PPICLF_JVY,i) = ppiclf_ydotc(PPICLF_JVY,i)
     >                              + rnmag*rn_12y
         ppiclf_ydotc(PPICLF_JVZ,i) = ppiclf_ydotc(PPICLF_JVZ,i)
     >                              + rnmag*rn_12z

      endif

      return
      end
!-----------------------------------------------------------------------


      SUBROUTINE ewald_setp()

      implicit none

      include 'p_const.inc'
      include 'cm_latt.inc'
      include 'cm_ewld.inc'

      real*8 axb1,axb2,axb3,bxc1,bxc2,bxc3,cxa1,cxa2,cxa3
      integer i

      ralphsq=-0.25/alpha**2

      write(*,*) "rlatt"
      write(*,*) (rlatt(i,1),i=1,3)
      write(*,*) (rlatt(i,2),i=1,3)
      write(*,*) (rlatt(i,3),i=1,3)

      axb1=rlatt(2,1)*rlatt(3,2)-rlatt(3,1)*rlatt(2,2)
      axb2=rlatt(3,1)*rlatt(1,2)-rlatt(1,1)*rlatt(3,2)
      axb3=rlatt(1,1)*rlatt(2,2)-rlatt(2,1)*rlatt(1,2)
      bxc1=rlatt(2,2)*rlatt(3,3)-rlatt(3,2)*rlatt(2,3)
      bxc2=rlatt(3,2)*rlatt(1,3)-rlatt(1,2)*rlatt(3,3)
      bxc3=rlatt(1,2)*rlatt(2,3)-rlatt(2,2)*rlatt(1,3)
      cxa1=rlatt(2,3)*rlatt(3,1)-rlatt(2,1)*rlatt(3,3)
      cxa2=rlatt(1,1)*rlatt(3,3)-rlatt(3,1)*rlatt(1,3)
      cxa3=rlatt(2,1)*rlatt(1,3)-rlatt(1,1)*rlatt(2,3)

      rvol=abs(rlatt(1,1)*bxc1+rlatt(2,1)*bxc2+rlatt(3,1)*bxc3)

      xvector=rvol/sqrt(bxc1*bxc1+bxc2*bxc2+bxc3*bxc3)
      yvector=rvol/sqrt(cxa1*cxa1+cxa2*cxa2+cxa3*cxa3)
      zvector=rvol/sqrt(axb1*axb1+axb2*axb2+axb3*axb3)

      rksqmax=min(real(kmaxx)*xvector,
     $            real(kmaxy)*yvector,
     $            real(kmaxz)*zvector)
      rksqmax=rksqmax*1.05*twopi
      rksqmax=rksqmax**2

      write(*,*) "ewald data"
      write(*,*) "kmax",kmaxx,kmaxy,kmaxz
      write(*,*) "alpha",alpha
      write(*,*) "ralphsq",ralphsq
      write(*,*) "rksqmax",rksqmax

      return

      END
c $Id$


c--- This is just a wrapping routine that calls ovCtensor or pvCtensor
      subroutine doCtensor(q1,q2,m1s,m2s,m3s,
     . FC0,FC1,FC2,FC3,FC4,FC5,FC6)
      implicit none
C     q1,q2 are the momenta in the propagators
C     m1s,m2s,m3s are the squares of the masses in the propagators
      include 'TRconstants.f'
      include 'TRydef.f'
      include 'TRtensorcontrol.f'
      double complex FC0(-2:0),FC1(y1max,-2:0),FC2(y2max,-2:0),
     . FC3(y3max,-2:0),FC4(y4max,-2:0),FC5(y5max,-2:0),FC6(y6max,-2:0),
     . C00(-2:0),tau3(4,-2:0)
      double precision q1(4),q2(4),p2(4),m1s,m2s,m3s

      if (doovred) then
        p2(:)=q2(:)-q1(:)
        call ovCtensor(q1,p2,m1s,m2s,m3s,FC0,FC1,FC2,FC3,C00,tau3)
        FC4=czip
        FC5=czip
        FC6=czip
      endif

      if (dopvred) then
        call pvCtensor(q1,q2,m1s,m2s,m3s,
     &   FC0,FC1,FC2,FC3,FC4,FC5,FC6)
      endif

      return
      end


C
C $Id: mdptrp.f,v 1.9 2008-09-18 00:42:17 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MDPTRP (UINS,VINS,UOUT,VOUT,UINT,VINT)
C
        DOUBLE PRECISION UINS,VINS,UOUT,VOUT,UINT,VINT
C
C This routine finds the point of intersection (UINT,VINT) of the line
C from (UINS,VINS) to (UOUT,VOUT) with the edge of a rectangular frame.
C The first point is inside the frame and the second outside the frame.
C
C Because MDPTRP can be called with the same actual arguments for UINT
C and VINT as for UOUT and VOUT, respectively, UINT and VINT must not
C be reset until all use of UOUT and VOUT is complete.
C
C Declare required common blocks.  See MAPBDX for descriptions of these
C common blocks and the variables in them.
C
        COMMON /MAPCM2/  BLAM,BLOM,PEPS,SLAM,SLOM,UCEN,UMAX,UMIN,UOFF,
     +                   URNG,VCEN,VMAX,VMIN,VOFF,VRNG,ISSL
        DOUBLE PRECISION BLAM,BLOM,PEPS,SLAM,SLOM,UCEN,UMAX,UMIN,UOFF,
     +                   URNG,VCEN,VMAX,VMIN,VOFF,VRNG
        INTEGER          ISSL
        SAVE   /MAPCM2/
C
C Declare local variables.
C
        INTEGER          IREA
C
        DOUBLE PRECISION DU,DV,U,V
C
C Declare local arithmetic statement functions.
C
        DOUBLE PRECISION UFUN,VFUN
C
C Given one coordinate of a point on the line joining (UINS,VINS) and
C (UOUT,VOUT), the other can be obtained by using one of the following
C arithmetic statement functions:
C
        UFUN(V)=UINS+(V-VINS)*DU/DV
        VFUN(U)=VINS+(U-UINS)*DV/DU
C
C                                      I     I
C                                   5  I  4  I  6
C                                      I     I
C                                 -----------------
C First, determine in which            I     I
C of the areas shown the            2  I  1  I  3
C point (UOUT,VOUT) lies.              I     I
C                                 -----------------
C                                      I     I
C                                   8  I  7  I  9
C                                      I     I
C
        IREA=1
        IF (UOUT-UMIN) 101,104,102
  101   IREA=IREA+1
        GO TO 104
  102   IF (UOUT-UMAX) 104,104,103
  103   IREA=IREA+2
  104   IF (VOUT-VMIN) 105,108,106
  105   IREA=IREA+6
        GO TO 108
  106   IF (VOUT-VMAX) 108,108,107
  107   IREA=IREA+3
C
C Next, compute the quantities required by UFUN and VFUN and jump to the
C appropriate piece of code for the given area.
C
  108   DU=UOUT-UINS
        DV=VOUT-VINS
C
        GO TO (119,113,114,115,109,110,116,111,112) , IREA
C
  109   IF (UFUN(VMAX)-UMIN) 113,115,115
  110   IF (UFUN(VMAX)-UMAX) 115,115,114
  111   IF (UFUN(VMIN)-UMIN) 113,116,116
  112   IF (UFUN(VMIN)-UMAX) 116,116,114
C
  113   UINT=UMIN
        GO TO 117
  114   UINT=UMAX
        GO TO 117
  115   VINT=VMAX
        GO TO 118
  116   VINT=VMIN
        GO TO 118
C
  117   VINT=VFUN(UINT)
        RETURN
C
  118   UINT=UFUN(VINT)
        RETURN
C
  119   UINT=UOUT
        VINT=VOUT
C
C Done.
C
        RETURN
C
      END


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_apwsdim
      CONTAINS
      SUBROUTINE apws_dim(&
     &                    bkpt,cell,input,noco,oneD,&
     &                    nv,nv2,kq1d,kq2d,kq3d)
!
!*********************************************************************
!     determines dimensions of the lapw basis set with |k+G|<rkmax.
!     bkpt is the k-point given in internal units
!
!     dimensions kq(i)d for charge density FFT added.
!        s. bluegel, JRCAT, Feb. 97
!*********************************************************************
      USE m_boxdim
      USE m_ifft,     ONLY : ifft235
      USE m_types_cell
      USE m_types_input
      USE m_types_noco
      USE m_types_oned

      IMPLICIT NONE
      REAL,INTENT(IN)              :: bkpt(3)
      TYPE(t_cell),INTENT(IN)      :: cell
      TYPE(t_input),INTENT(IN)     :: input
      TYPE(t_noco),INTENT(IN)      :: noco
      TYPE(t_oneD),INTENT(IN)      :: oneD
      INTEGER,INTENT(OUT) :: nv,nv2,kq1d,kq2d,kq3d

      INTEGER j1,j2,j3,mk1,mk2,mk3,iofile,ksfft
      INTEGER ispin,nvh(2),nv2h(2)

      REAL arltv1,arltv2,arltv3,rkm,rk2,r2,s(3),gmaxp
! ..
!
!------->          ABBREVIATIONS
!

!   iofile      : device number for in and output
!   gmax        : cut-off wavevector for charge density
!   rkmax       : cut-off for |g+k|
!   gmaxp       : gmaxp = gmax/rkmax, ideal: gmaxp=2
!   arltv(i)    : length of reciprical lattice vector along
!                 direction (i)
!
!---> Determine rkmax box of size mk1, mk2, mk3,
!     for which |G(mk1,mk2,mk3) + (k1,k2,k3)| < rkmax
!
      CALL boxdim(cell%bmat,arltv1,arltv2,arltv3)

!     (add 1+1 due to integer rounding, strange k_vector in BZ)
      mk1 = int(input%rkmax/arltv1) + 2
      mk2 = int(input%rkmax/arltv2) + 2
      mk3 = int(input%rkmax/arltv3) + 2

      rkm = input%rkmax
      rk2 = rkm*rkm
!---> obtain vectors
!---> in a spin-spiral calculation different basis sets are used for
!---> the two spin directions, because the cutoff radius is defined
!---> by |G + k +/- qss/2| < rkmax.
      DO ispin = 1,2
         nv = 0
         nv2 = 0
         DO j1 = -mk1,mk1
            s(1) = bkpt(1) + j1 + (2*ispin - 3)/2.0*noco%qss_inp(1)
            DO j2 = -mk2,mk2
               s(2) = bkpt(2) + j2 + (2*ispin - 3)/2.0*noco%qss_inp(2)
!--->          nv2 for films
               s(3) = 0.0
               !r2 = dotirp(s,s,cell%bbmat)
               r2 = dot_product(matmul(s,cell%bbmat),s)
               IF (r2.LE.rk2) nv2 = nv2 + 1
               DO j3 = -mk3,mk3
                  s(3) = bkpt(3) + j3 + (2*ispin - 3)/2.0*noco%qss_inp(3)
                  !r2 = dotirp(s,s,cell%bbmat)
                  r2 = dot_product(matmul(s,cell%bbmat),s)
                  IF (r2.LE.rk2) THEN
                     nv = nv + 1
                  END IF
               END DO
            END DO
         END DO
!-odim
         IF (oneD%odd%d1) THEN
           nv2 = 0
           s(1) = 0.0
           s(2) = 0.0
           DO j3 = -mk3,mk3
              s(3) = bkpt(3) + j3 + (2*ispin - 3)/2.0*noco%qss_inp(3)
              !r2 = dotirp(s,s,cell%bbmat)
              r2 = dot_product(matmul(s,cell%bbmat),s)

              IF (r2.LE.rk2) THEN
                 nv2 = nv2 + 1
              END IF
           END DO
         END IF
!+odim
         nvh(ispin)  = nv
         nv2h(ispin) = nv2
      END DO
      nv  = max(nvh(1),nvh(2))
      nv2 = max(nv2h(1),nv2h(2))

!---> Determine the dimensions kq1d, kq2d, kq3d
!     of the dimension of the charge density fft-box
!     needed for the fast calculation of pw density
!     (add 1 due to integer rounding,
!      factor 2 due to positive domain)
!
      gmaxp = 2.0
      CALL boxdim(cell%bmat,arltv1,arltv2,arltv3)
!
      mk1 = int(gmaxp*input%rkmax/arltv1) + 1
      mk2 = int(gmaxp*input%rkmax/arltv2) + 1
      mk3 = int(gmaxp*input%rkmax/arltv3) + 1

!---> add + 1 in spin spiral calculation, to make sure that all G's are
!---> still within the FFT-box after being shifted by the spin spiral
!---> q-vector.
      IF (noco%l_ss) THEN
         mk1 = mk1 + 1
         mk2 = mk2 + 1
         mk3 = mk3 + 1
      ENDIF
!
      kq1d = 2*mk1
      kq2d = 2*mk2
      kq3d = 2*mk3
!
!---> fft's are usually fastest for low primes
!     (restrict kqid to: kqid=  (2**P) * (3**Q) * (5**R)
!
      ksfft = 1
!     ksfft=(0,1) : KEY OF SELECTING FFT-PRDOGRAM AND RADIX-TYPE
!                      0  PROGRAM, RADIX-2 ONLY
!                      1  PROGRAM, RADIX-2, RADIX-3,RADIX-5

      kq1d = ifft235(ksfft,kq1d,gmaxp)
      kq2d = ifft235(ksfft,kq2d,gmaxp)
      kq3d = ifft235(ksfft,kq3d,gmaxp)

      RETURN
      END SUBROUTINE
      END


SUBROUTINE cnfnum_light
!=======================================
! Common Neighbour Function light
!=======================================
! Calculates the number of pairs that have the same number of common nearest neighbours.
! The derivatives are not calculated in order to improve performance.
!=======================================

   USE PARACLUSTER
   USE CLUSTER
   USE POTENTIAL
   USE ENFORCE
   USE DISTANCE
   USE META

   IMPLICIT NONE

   INTEGER :: i, j, k
   REAL(8) :: cnf_num_loc
   REAL(8), DIMENSION(nsiz) :: friends

   IF (ipas.eq.1) WRITE(*,*) 'cnfnum_light> first calculation of CNN.'

   cnf_num_loc = 0.d0

   DO i = 1, natom-1
      DO j = i+1, natom
         IF (cutoffmat(j,i)) THEN
            WHERE (cutoffmat(:,i) .AND. cutoffmat(:,j))
               friends(1:natom) = f_sigmoid(pair_dist(j,i), pairkindmat(j,i))* &
               & f_sigmoid(pair_dist(:,i), pairkindmat(:,i))* &
               & f_sigmoid(pair_dist(:,j), pairkindmat(:,j))
            ELSE WHERE
               friends(1:natom) = 0.d0
            END WHERE
            cnf_num_loc = cnf_num_loc + f_window(SUM(friends(1:natom)))
         END IF
      END DO !j
   END DO !i

   ! Return value
   cnf_num = cnf_num_loc

END SUBROUTINE cnfnum_light


*     SB02RD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDG, LDQ, LDS, LDT, LDV, LDX
      PARAMETER        ( LDA = NMAX, LDG = NMAX, LDQ = NMAX,
     $                   LDS = 2*NMAX, LDT = NMAX, LDV = NMAX,
     $                   LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*NMAX, NMAX*NMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 5 + 4*NMAX*NMAX + 8*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCOND, SEP
      INTEGER          I, INFO, J, N
      CHARACTER        DICO, FACT, HINV, JOB, LYAPUN, SCAL, SORT, TRANA,
     $                 UPLO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), G(LDG,NMAX),
     $                 Q(LDQ,NMAX), S(LDS,2*NMAX), T(LDT,NMAX),
     $                 V(LDV,NMAX), WI(2*NMAX), WR(2*NMAX), X(LDX,NMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB02RD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT,
     $                      FACT, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) .OR.
     $        LSAME( FACT, 'N' ) .OR. LSAME( LYAPUN, 'O' ) )
     $      READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( .NOT.LSAME( JOB, 'X' ) .AND. LSAME( FACT, 'F' ) ) THEN
            READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,N ), I = 1,N )
            READ ( NIN, FMT = * ) ( ( V(I,J), J = 1,N ), I = 1,N )
         END IF
         READ ( NIN, FMT = * ) ( ( Q(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'E' ) )
     $      READ ( NIN, FMT = * ) ( ( X(I,J), J = 1,N ), I = 1,N )
*        Find the solution matrix X.
         CALL SB02RD( JOB, DICO, HINV, TRANA, UPLO, SCAL, SORT, FACT,
     $                LYAPUN, N, A, LDA, T, LDT, V, LDV, G, LDG, Q, LDQ,
     $                X, LDX, SEP, RCOND, FERR, WR, WI, S, LDS, IWORK,
     $                DWORK, LDWORK, BWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         END IF
         IF ( INFO.EQ.0 .OR. INFO.EQ.7 ) THEN
            IF ( LSAME( JOB, 'X' ) .OR. LSAME( JOB, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( X(I,J), J = 1,N )
   20          CONTINUE
            END IF
            IF ( LSAME( JOB, 'C' ) .OR. LSAME( JOB, 'A' ) ) THEN
               WRITE ( NOUT, FMT = 99994 ) SEP
               WRITE ( NOUT, FMT = 99993 ) RCOND
            END IF
            IF ( LSAME( JOB, 'E' ) .OR. LSAME( JOB, 'A' ) )
     $         WRITE ( NOUT, FMT = 99992 ) FERR
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB02RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB02RD = ',I2)
99997 FORMAT (' The solution matrix X is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
99994 FORMAT (/' Estimated separation = ',F8.4)
99993 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99992 FORMAT (/' Estimated error bound = ',F8.4)
      END


C SYSCF.F - Gateway function for SLICOT coprime factorization routines
C           SB08CD.F, SB08DD.F, SB08ED.F and SB08FD.F.
C
C RELEASE 2.0 of SLICOT Basic Systems and Control Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C MATLAB CALL:
C   [Af,Bf,Cf,Df,nr] = syscf(meth,A,B,C,D,tol,discr,alpha,beta)
C
C Purpose:
C   To compute for a state-space system (A,B,C,D) with the
C   transfer-function matrix G a left coprime factorization (LCF) or
C   a right coprime factorization (RCF)
C                   -1                    -1
C         LCF: G = M  N,  or  RCF:  G = NM  ,
C
C   as specified by the method parameter meth.
C   The resulting (Af,Bf,Cf,Df) is the state-space system having
C   the transfer-function matrix [ N M ] for a LCF or [ N ] for a RCF.
C                                                     [ M ]
C   A minimal realization of M of order nr can be recovered from the
C   resulting state-space matrices (see description of nr).
C
C Input parameters:
C   meth    - type of right/left coprime factorization (LCF/RCF):
C               = 1 : RCF with inner denominator;
C               = 2 : LCF with inner denominator;
C               = 3 : RCF with ALPHA stability degree;
C               = 4 : LCF with ALPHA stability degree.
C   A,B,
C   C,D     - state-space system matrices.
C   tol     - (optional) controllability/observability tolerance
C             for computing right/left coprime factorizations.
C                Default controllability tolerance
C                   tol = epsilon_machine*max(norm(A),norm(B));
C                default  observability tolerance
C                   tol = epsilon_machine*max(norm(A),norm(C)).
C   discr   - (optional) type of system:
C                = 0 : continuous-time (default);
C                = 1 : discrete-time.
C   alpha   - (optional) stability degree for LCF/RCF with prescribed
C                stability degree.
C                Default: -0.05  for continuous-time;
C                          0.95  for discrete-time.
C   beta    - (optional) stability margin for the LCF/RCF with prescribed
C                stability degree.
C                Default: beta = alpha.
C
C Output parameters:
C   Af, Bf,                                   ( N )                  -1
C   Cf, Df  - matrices of the compound system ( M ) such that G = N*M
C             is a RCF  if meth = 1 or meth = 3, or
C             matrices of the compound system ( N M ) such that
C                  -1
C             G = M  *N is a LCF  if meth = 2 or meth = 4.
C   nr      - order of a minimal realization of M;
C             for a p-by-m transfer-function matrix G, the minimal
C             realization of M can be recovered as the state-space model
C               ( Af(si,si), Bf(si,ii), Cf(oi,si), Df(oi,ii) )
C             where si, ii and oi are the index vectors for state, input
C             and output vector, respectively, defined as follows
C                si = 1:nr, ii = m+1:m+p, oi = 1:p for a LCF;
C                si = nr+1:end; ii = 1:m, oi = p+1:p+m for a RCF.
C
C Contributor:
C A. Varga, DLR-Oberpfaffenhofen; March 1999.
C
C Revisions:
C A. Varga, DLR-Oberpfaffenhofen; March 2003, Sept. 2005.
C V. Sima, Research Institute for Informatics, Nov. 2005, Apr. 2009,
C Dec. 2012.
C
C *********************************************************************
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
      DOUBLE PRECISION  ONE, TWO, ZERO, P05
      PARAMETER         ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0,
     $                    P05 = 0.05D0 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         DICO
      INTEGER           INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR,
     $                  LWORK, M, N, NQ, NR, P
      DOUBLE PRECISION  ALPHA(2), TOL
C
C .. Allocatable local arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      DOUBLE PRECISION, ALLOCATABLE:: A(:,:), B(:,:), C(:,:), D(:,:),
     $                                BR(:,:), DR(:,:), WORK(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      LOGICAL           DISCR, LEFT
      INTEGER           I, LW1, LW2, LW3, LW4, METH, MP, M1,
     $                  N1, N2, N3, PM, P1
      DOUBLE PRECISION  DUM
C
C .. External functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C
C .. External Subroutines ..
      EXTERNAL          DLACPY, SB08CD, SB08DD, SB08ED, SB08FD
C
C .. Intrinsic functions ..
      INTRINSIC         DBLE, MAX
C
C Check for proper number of arguments
C
      IF( NRHS.LT.5 ) THEN
         CALL mexErrMsgTxt
     $        ( 'SYSCF requires at least 5 input arguments' )
      ELSE IF( NLHS.GT.5 ) THEN
         CALL mexErrMsgTxt
     $        ( 'SYSCF has at most 5 output argument' )
      END IF
C
C Check dimensions of input parameters and read/set scalar parameters
C
C  meth
C
      METH = 1
      IF( mxGetM( PRHS(1) ).NE.1 .OR. mxGetN( PRHS(1) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'METH must be a scalar' )
      END IF
      IF( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $    mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'METH must be an integer scalar 0 or 1' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), DUM, 1 )
      METH = DUM
      IF( METH.LE.0 .OR. METH.GT.4 ) THEN
         CALL mexErrMsgTxt
     $        ( 'METH has 1 ... 4 the only admissible values' )
      END IF
      LEFT = METH.EQ.2 .OR. METH.EQ.4
C
C   A(NxN), B(NxM), C(PxN), D(PxM)
C
      N  = mxGetM( PRHS(2) )
      M  = mxGetN( PRHS(3) )
      P  = mxGetM( PRHS(4) )
      N1 = mxGetN( PRHS(2) )
      N2 = mxGetM( PRHS(3) )
      N3 = mxGetN( PRHS(4) )
      P1 = mxGetM( PRHS(5) )
      M1 = mxGetN( PRHS(5) )
C
      IF( (N1.NE.N) ) THEN
         CALL mexErrMsgTxt
     $        ( 'A must be a square matrix' )
      END IF
      IF( N2.NE.N ) THEN
         CALL mexErrMsgTxt
     $        ( 'B must have the same row dimension as A' )
      END IF
      IF( N3.NE.N ) THEN
         CALL mexErrMsgTxt
     $        ( 'C must have the same column dimension as A ' )
      END IF
      IF( M1.NE.M ) THEN
         CALL mexErrMsgTxt
     $        ( 'D must have the same column dimension as B' )
      END IF
      IF( P1.NE.P ) THEN
         CALL mexErrMsgTxt
     $        ( 'D must have the same row dimension as C' )
      END IF
      IF( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $    mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'A must be a real matrix' )
      END IF
      IF( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $    mxIsComplex( PRHS(3) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'B must be a real matrix' )
      END IF
      IF( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $    mxIsComplex( PRHS(4) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'C must be a real matrix' )
      END IF
      IF( mxIsNumeric( PRHS(5) ).EQ.0 .OR.
     $    mxIsComplex( PRHS(5) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'D must be a real matrix' )
      END IF
C
C   tol
C
      TOL = ZERO
      IF( NRHS.GT.5 ) THEN
         IF( mxGetM( PRHS(6) ).NE.1 .OR. mxGetN( PRHS(6) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'TOL must be a scalar' )
         END IF
         IF( mxIsNumeric( PRHS(6) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(6) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'TOL must be a real vector' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(6) ), TOL, 1 )
      END IF
C
C   discr
C
      DICO = 'C'
      IF( NRHS.GT.6 ) THEN
         IF( mxGetM( PRHS(7) ).NE.1 .OR. mxGetN( PRHS(7) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'DISCR must be a scalar' )
         END IF
         IF( mxIsNumeric( PRHS(7) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(7) ).EQ.1 ) THEN
           CALL mexErrMsgTxt( 'DISCR must be an integer scalar 0 or 1' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(7) ), DUM, 1 )
         IF( DUM.NE.ZERO ) DICO = 'D'
      END IF
      DISCR = LSAME( DICO, 'D' )
C
C   alpha
C
      IF( NRHS.GT.7 ) THEN
         IF( mxGetM( PRHS(8) ).NE.1 .OR. mxGetN( PRHS(8) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'ALPHA must be a scalar' )
         END IF
         IF( mxIsNumeric( PRHS(8) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(8) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'ALPHA must be a real scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(8) ), ALPHA(1), 1 )
      ELSE
         ALPHA(1) = -P05
         IF( DISCR ) ALPHA(1) = ONE + ALPHA(1)
      END IF
C
C   beta
C
      IF( NRHS.GT.8 ) THEN
         IF( mxGetM( PRHS(9) ).NE.1 .OR. mxGetN( PRHS(9) ).NE.1 ) THEN
            CALL mexErrMsgTxt( 'BETA must be a scalar' )
         END IF
         IF( mxIsNumeric( PRHS(9) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(9) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'BETA must be a real scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(9) ), ALPHA(2), 1 )
      ELSE
         ALPHA(2) = ALPHA(1)
      END IF
C
C Determine the lenghts of working arrays
C
      LW1   = MAX( N*(N+5), 5*M, 4*P )
      LW2   = N*P + MAX( N*(N+5), 5*P, 4*M )
      LW3   = MAX( N*(N+5), M*(M+2), 4*M, 4*P )
      LW4   = P*N + MAX( N*(N+5),P*(P+2),4*P,4*M )
      LWORK = MAX( 1, LW1, LW2, LW3, LW4 )
C
      LDA  = MAX( 1, N )
      LDB  = MAX( 1, N )
      LDC  = MAX( 1, P+M )
      LDD  = MAX( 1, P+M )
      LDBR = LDB
      LDDR = MAX( 1, P )
C
C Allocate variable dimension local arrays
C !Fortran 90/95
C
      ALLOCATE ( A( LDA, N ), B( LDB, M+P ), C( LDC, N ), D( LDD, M+P ),
     $           BR( LDBR, P ), DR( LDDR, P ), WORK( LWORK ) )
C
C Copy inputs from MATLAB workspace to locally allocated arrays
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), A, N*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), B, N*M )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), WORK, P*N )
      CALL DLACPY( 'F', P, N, WORK, MAX( 1, P ), C, LDC )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(5) ), WORK, P*M )
      CALL DLACPY( 'F', P, M, WORK, MAX( 1, P ), D, LDD )
C
C Do the actual computations
C
C RCFID
C
      IF( METH.EQ.1 )
     $   CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC,
     $                D, LDD, NQ, NR, C(P+1,1), LDC, D(P+1,1), LDD,
     $                TOL, WORK, LWORK, IWARN, INFO )
C
C LCFID
C
      IF( METH.EQ.2 )
     $   CALL SB08CD( DICO, N, M, P, A, LDA, B, LDB, C, LDC,
     $                D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL, WORK,
     $                LWORK, IWARN, INFO )
C
C RCFS
C
      IF( METH.EQ.3 )
     $   CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC,
     $                D, LDD, NQ, NR, C(P+1,1), LDC, D(P+1,1), LDD,
     $                TOL, WORK, LWORK, IWARN, INFO )
C
C LCFS
C
      IF( METH.EQ.4 )
     $   CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC,
     $                D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL, WORK,
     $                LWORK, IWARN, INFO )
C
C Copy output to MATLAB workspace
C
      IF( INFO.EQ.0 ) THEN
         IF( LEFT ) THEN
            PM = P
            MP = M + P
         ELSE
            PM = P + M
            MP = M
         END IF
         IF( NLHS.GE.1 ) THEN
            PLHS(1) = mxCreateDoubleMatrix( NQ, NQ, 0 )
            IF( NQ.LT.N .AND. NQ.GT.0 )
     $         CALL DLACPY( 'F', NQ, NQ, A, LDA, A, NQ )
            CALL mxCopyReal8ToPtr( A, mxGetPr( PLHS(1) ), NQ*NQ )
         END IF
         IF( NLHS.GE.2 ) THEN
            PLHS(2) = mxCreateDoubleMatrix( NQ, MP, 0 )
            CALL DLACPY( 'F', NQ, M, B, LDB, WORK, NQ )
            IF( LEFT )
     $         CALL DLACPY( 'F', NQ, P, BR, LDBR, WORK(NQ*M+1), NQ )
            CALL mxCopyReal8ToPtr( WORK, mxGetPr( PLHS(2) ), NQ*MP )
         END IF
         IF( NLHS.GE.3 ) THEN
            PLHS(3) = mxCreateDoubleMatrix( PM, NQ, 0 )
            CALL DLACPY( 'F', PM, NQ, C, LDC, WORK, PM )
            CALL mxCopyReal8ToPtr( WORK, mxGetPr( PLHS(3) ), PM*NQ )
         END IF
         IF( NLHS.GE.4 ) THEN
            PLHS(4) = mxCreateDoubleMatrix( PM, MP, 0 )
            CALL DLACPY( 'F', PM, M, D, LDD, WORK, PM )
            IF( LEFT )
     $         CALL DLACPY( 'F', P, P, DR, LDDR, WORK(PM*M+1), PM )
            CALL mxCopyReal8ToPtr( WORK, mxGetPr( PLHS(4) ), PM*MP )
         END IF
C
         IF( NLHS.GE.5 ) THEN
            PLHS(5) = mxCreateDoubleMatrix( 1, 1, 0 )
            CALL mxCopyReal8ToPtr( DBLE( NR ), mxGetPr( PLHS(5) ), 1 )
         END IF
C
      END IF
C
C Deallocate local arrays
C !Fortran 90/95
C
      DEALLOCATE ( A, B, C, D, BR, DR, WORK )
C
C Error handling
C
      IF( INFO.NE.0 ) THEN
         IF( METH.EQ.1 ) THEN
            WRITE( TEXT,'( " INFO =", I4, " ON EXIT FROM SB08DD" )' )
     $             INFO
         ELSE IF( METH.EQ.2 ) THEN
            WRITE( TEXT,'( " INFO =", I4, " ON EXIT FROM SB08CD" )' )
     $             INFO
         ELSE IF( METH.EQ.3 ) THEN
            WRITE( TEXT,'( " INFO =", I4, " ON EXIT FROM SB08FD" )' )
     $             INFO
         ELSE IF( METH.EQ.4 ) THEN
            WRITE( TEXT,'( " INFO =", I4, " ON EXIT FROM SB08ED" )' )
     $             INFO
         END IF
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C *** Last line of SYSCF ***
      END


subroutine cumnor ( arg, cum, ccum )

!*****************************************************************************80
!
!! CUMNOR computes the cumulative normal distribution.
!
!  Discussion:
!
!    This function evaluates the normal distribution function:
!
!                              / x
!                     1       |       -t*t/2
!          P(x) = ----------- |      e       dt
!                 sqrt(2 pi)  |
!                             /-oo
!
!    This transportable program uses rational functions that
!    theoretically approximate the normal distribution function to
!    at least 18 significant decimal digits.  The accuracy achieved
!    depends on the arithmetic system, the compiler, the intrinsic
!    functions, and proper selection of the machine dependent
!    constants.
!
!  Author:
!
!    William Cody
!    Mathematics and Computer Science Division
!    Argonne National Laboratory
!    Argonne, IL 60439
!
!  Reference:
!
!    William Cody,
!    Rational Chebyshev approximations for the error function,
!    Mathematics of Computation,
!    1969, pages 631-637.
!
!    William Cody,
!    Algorithm 715:
!    SPECFUN - A Portable FORTRAN Package of Special Function Routines
!    and Test Drivers,
!    ACM Transactions on Mathematical Software,
!    Volume 19, Number 1, 1993, pages 22-32.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) ARG, the upper limit of integration.
!
!    Output, real ( kind = 8 ) CUM, CCUM, the Normal density CDF and
!    complementary CDF.
!
!  Local Parameters:
!
!    Local, real ( kind = 8 ) EPS, the argument below which anorm(x)
!    may be represented by 0.5 and above which  x*x  will not underflow.
!    A conservative value is the largest machine number X
!    such that   1.0D+00 + X = 1.0D+00   to machine precision.
!
  implicit none

  real ( kind = 8 ), parameter, dimension ( 5 ) :: a = (/ &
    2.2352520354606839287D+00, &
    1.6102823106855587881D+02, &
    1.0676894854603709582D+03, &
    1.8154981253343561249D+04, &
    6.5682337918207449113D-02 /)
  real ( kind = 8 ) arg
  real ( kind = 8 ), parameter, dimension ( 4 ) :: b = (/ &
    4.7202581904688241870D+01, &
    9.7609855173777669322D+02, &
    1.0260932208618978205D+04, &
    4.5507789335026729956D+04 /)
  real ( kind = 8 ), parameter, dimension ( 9 ) :: c = (/ &
    3.9894151208813466764D-01, &
    8.8831497943883759412D+00, &
    9.3506656132177855979D+01, &
    5.9727027639480026226D+02, &
    2.4945375852903726711D+03, &
    6.8481904505362823326D+03, &
    1.1602651437647350124D+04, &
    9.8427148383839780218D+03, &
    1.0765576773720192317D-08 /)
  real ( kind = 8 ) ccum
  real ( kind = 8 ) cum
  real ( kind = 8 ), parameter, dimension ( 8 ) :: d = (/ &
    2.2266688044328115691D+01, &
    2.3538790178262499861D+02, &
    1.5193775994075548050D+03, &
    6.4855582982667607550D+03, &
    1.8615571640885098091D+04, &
    3.4900952721145977266D+04, &
    3.8912003286093271411D+04, &
    1.9685429676859990727D+04 /)
  real ( kind = 8 ) del
  real ( kind = 8 ) eps
  integer i
  real ( kind = 8 ), parameter, dimension ( 6 ) :: p = (/ &
    2.1589853405795699D-01, &
    1.274011611602473639D-01, &
    2.2235277870649807D-02, &
    1.421619193227893466D-03, &
    2.9112874951168792D-05, &
    2.307344176494017303D-02 /)
  real ( kind = 8 ), parameter, dimension ( 5 ) :: q = (/ &
    1.28426009614491121D+00, &
    4.68238212480865118D-01, &
    6.59881378689285515D-02, &
    3.78239633202758244D-03, &
    7.29751555083966205D-05 /)
  real ( kind = 8 ), parameter :: root32 = 5.656854248D+00
  real ( kind = 8 ), parameter :: sixten = 16.0D+00
  real ( kind = 8 ) temp
  real ( kind = 8 ), parameter :: sqrpi = 3.9894228040143267794D-01
  real ( kind = 8 ), parameter :: thrsh = 0.66291D+00
  real ( kind = 8 ) x
  real ( kind = 8 ) xden
  real ( kind = 8 ) xnum
  real ( kind = 8 ) y
  real ( kind = 8 ) xsq
!
!  Machine dependent constants
!
  eps = epsilon ( 1.0D+00 ) * 0.5D+00

  x = arg
  y = abs ( x )

  if ( y <= thrsh ) then
!
!  Evaluate  anorm  for  |X| <= 0.66291
!
    if ( eps < y ) then
      xsq = x * x
    else
      xsq = 0.0D+00
    end if

    xnum = a(5) * xsq
    xden = xsq
    do i = 1, 3
      xnum = ( xnum + a(i) ) * xsq
      xden = ( xden + b(i) ) * xsq
    end do
    cum = x * ( xnum + a(4) ) / ( xden + b(4) )
    temp = cum
    cum = 0.5D+00 + temp
    ccum = 0.5D+00 - temp
!
!  Evaluate ANORM for 0.66291 <= |X| <= sqrt(32)
!
  else if ( y <= root32 ) then

    xnum = c(9) * y
    xden = y
    do i = 1, 7
      xnum = ( xnum + c(i) ) * y
      xden = ( xden + d(i) ) * y
    end do
    cum = ( xnum + c(8) ) / ( xden + d(8) )
    xsq = aint ( y * sixten ) / sixten
    del = ( y - xsq ) * ( y + xsq )
    cum = exp ( - xsq * xsq * 0.5D+00 ) * exp ( -del * 0.5D+00 ) * cum
    ccum = 1.0D+00 - cum

    if ( 0.0D+00 < x ) then
      call r8_swap ( cum, ccum )
    end if
!
!  Evaluate ANORM for sqrt(32) < |X|.
!
  else

    cum = 0.0D+00
    xsq = 1.0D+00 / ( x * x )
    xnum = p(6) * xsq
    xden = xsq
    do i = 1, 4
      xnum = ( xnum + p(i) ) * xsq
      xden = ( xden + q(i) ) * xsq
    end do

    cum = xsq * ( xnum + p(5) ) / ( xden + q(5) )
    cum = ( sqrpi - cum ) / y
    xsq = aint ( x * sixten ) / sixten
    del = ( x - xsq ) * ( x + xsq )
    cum = exp ( - xsq * xsq * 0.5D+00 ) &
      * exp ( - del * 0.5D+00 ) * cum
    ccum = 1.0D+00 - cum

    if ( 0.0D+00 < x ) then
      call r8_swap ( cum, ccum )
    end if

  end if

  if ( cum < tiny ( cum ) ) then
    cum = 0.0D+00
  end if

  if ( ccum < tiny ( ccum ) ) then
    ccum = 0.0D+00
  end if

  return
end

subroutine r8_swap ( x, y )

!*****************************************************************************80
!
!! R8_SWAP swaps two R8 values.
!
!  Modified:
!
!    01 May 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) X, Y.  On output, the values of X and
!    Y have been interchanged.
!
  implicit none

  real ( kind = 8 ) x
  real ( kind = 8 ) y
  real ( kind = 8 ) z

  z = x
  x = y
  y = z

  return
end


! ============================ Module Description ===========================
! etdsdc_mod Implementation of ETDSDC method. Contains 2 subroutines:
!   1. etdsdc   - ETDSDC timestepping code
!   2. initW    - initializes ETD coefficients
! ===========================================================================

module etdsdc_mod

    ! Module Parameters
    use tools_mod,  only: dp, tic, toc, norm, weights
    use phi_mod,    only: phi

    implicit none
    ! Custom Settings Data Type
    type etdsdc_settings
        integer :: m
        real(dp), allocatable :: tau(:)
    end type etdsdc_settings

    contains

    ! =======================================================================
    ! ETDSDC    Implements ETDSDC Numerical Time Integrator
    !
    ! Arguments
    !
    !   L       (input) COMPLEX*16 array, dimension(M)
    !           vector cooresponding to PDE linear operator
    !
    !   N       (input) SUBROUTINE:
    !           cooresponds to PDE nonlinear operator. Must be of the form:
    !               subroutine N(t,y_in,N_out)
    !                   real(kind=8),    intent(in)  :: t
    !                   complex(kind=8), intent(in)  :: y_in(:)
    !                   complex(kind=8), intent(out) :: N_out(:)
    !               end subroutine N
    !
    !   tspan   (input) DOUBLE array, dimension(2)
    !           contains left and right integration bounds
    !
    !   y_in    (input) COMPLEX*16 array, dimension (N)
    !           Initial condition.
    !
    !   options (input) ETDSDC_SETTINGS
    !           derived data type that contains one field:
    !               options%tau : DOUBLE (quadrature points)
    !
    !   y_out   (output) COMPLEX*16 array, dimension (N)
    !           Initial condition.
    !
    !   times   (output) DOUBLE array, dimension(4)
    !           times(1:2) = [cputime,clocktime] for timestepping loop
    !           times(3:4) = [cputime,clocktime] for initializing coefficients,
    ! =======================================================================

    subroutine etdsdc(L,N,tspan,y_in,Nt,options,y_out,times)

        !Arguments
        complex(dp), intent(in)         :: L(:)
        real(dp),    intent(in)         :: tspan(2)
        complex(dp), intent(in)         :: y_in(:)
        type(etdsdc_settings), intent(in)   :: options
        integer,         intent(in)         :: Nt
        real(dp),    intent(out)        :: times(4)
        complex(dp), intent(out)        :: y_out(size(y_in))
        ! define interface subroutine function N
        interface
            subroutine N(t,yh_in, N_out, thread_id)
            import :: dp
            complex(dp), intent(in)  :: t
            complex(dp), intent(in)  :: yh_in(:)
            complex(dp), intent(out) :: N_out(:)
            integer, intent(in), optional :: thread_id
            end subroutine N
        end interface

        ! Local Variables
        integer :: i,j,k,nn,m,nL
        real(dp)    :: h
        complex(dp) :: t
        complex(dp), allocatable :: W(:,:,:)
        complex(dp), allocatable :: P01(:,:,:)
        complex(dp), allocatable :: y_n(:,:), N_n(:,:), IW(:,:), n_new(:)
        real(dp),    allocatable :: tau(:)

        ! Initialize Variables
        tau = options%tau
        m   = options%m
        nn  = size(tau)
        nL  = size(L)
        h   = (tspan(2)-tspan(1))/(real(Nt,dp))
        t   = tspan(1)
        allocate(P01(NL,nn-1,2), W(nL,nn,nn-1), y_n(nL,nn), N_n(nL,nn), IW(nL,nn), n_new(nL))

        ! initialize ETD coefficients
        call tic()
        call initW(L,h,tau,W,P01)
        call toc(times(3:4))

        ! timestepping loop
        call tic()
        y_n(:,1) = y_in
        do i=1,Nt
            ! Euler step
            do j=1,nn-1
                call N(t + h*tau(j),y_n(:,j),N_n(:,j))
                y_n(:,j+1) = P01(:,j,1) * y_n(:, j) + P01(:,j,2) * N_n(:, j)
            enddo
            call N(t + h*tau(nn), y_n(:, nn), N_n(:, nn))
            ! Correction Sweeps
            do k=1,m
                do j = 1, nn - 1
                    IW(:, j) = sum(W(:,:,j) * N_n, 2)
                enddo
                y_n(:, 2) = P01(:,1,1)*y_n(:, 1) + IW(:, 1)
                do j = 2, nn - 1
                    call N(t+h*tau(j),y_n(:, j),n_new)
                    y_n(:,j+1) = P01(:,j,1)*y_n(:, j) + P01(:, j, 2)*(n_new - N_n(:, j)) + IW(:, j)
                    N_n(:,j) = n_new;
                enddo
                if(k /= m) then
                    call N(t + h*tau(nn),y_n(:,nn),N_n(:, nn))
                endif
            enddo
            y_n(:, 1) = y_n(:, nn)
            t = t + h
        enddo
        call toc(times(1:2))
        y_out = y_n(:, nn)

    end subroutine etdsdc

    ! ==========================================================================
    ! INITW   Initializes ETDSDC W functions for matrix L using weights
    !         function by Fornberg.
    !
    ! Arguments
    !
    !   L   (input) COMPLEX*16 array, dimension(M)
    !       vector cooresponding to PDE linear operator
    !
    !   h   (input) DOUBLE
    !       timestep
    !
    !   tau (input) DOUBLE array, dimensions(n,1)
    !       normalized quadrature points
    !
    !   W   (output) COMPLEX*16 array, dimension(size(tau)-1, size(tau), size(L))
    !       contains the ETD Coefficients so that W(:,:,j) is the ETD integration
    !       matrix cooresponding to lambda=L(j)
    !
    !   P01 (output) COMPLEX*16 array, dimension(2,size(tau)-1,size(L))
    !       contains phi_0 and phi_1 functions needed for ETD Euler method, where
    !       P01(:,:,1,k) = Exp(h_k L) and P01(:,:,2,k) = h*h_i*\phi_{1}(h_k L)
    ! ==========================================================================

    subroutine initW(L,h,tau,W, P01)

        ! Arguments
        complex(dp), intent(in)  :: L(:)
        real(dp),    intent(in)  :: h
        real(dp),    intent(in)  :: tau(:)
        complex(dp), intent(out) :: W(size(L),size(tau),size(tau)-1)
        complex(dp), intent(out) :: P01(size(L), size(tau)-1, 2)

        ! Local Variables
        real(dp) :: eta(size(tau)-1)
        real(dp) :: q(size(tau))
        real(dp) :: A(size(tau),size(tau))
        complex(dp), allocatable :: p(:,:)
        integer :: i, n

        ! Initialize variables
        n     = size(tau)
        eta   = tau(2:n) - tau(1:n-1)
        allocate(p(n+1,size(L)))

        ! Calculate W functions
        do i=1,n-1
            q = (tau - tau(i))/eta(i)                                           ! scaled quadrature ppints
            call weights(0.d0,q,n-1,A)                                          ! finite difference matrix
            call phi(eta(i)*h*L,n,p)                                            ! phi functions 0 to n
            W(:, :, i)   = transpose(h * eta(i) * matmul(a,p(2:n+1,:)))         ! store ith row of Integration matrix
            P01(:, i, 1) = p(1,:)                                               ! store exp(h_i L)
            P01(:, i, 2) = h*eta(i)*p(2,:)                                      ! store h*eta(i)*phi_1(h_i L)
        enddo
        deallocate(p)

    end subroutine initW

end module etdsdc_mod