!##############################################################################
!# ****************************************************************************
!# <name> poisson2d_method0_simple </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module is a demonstration program how to solve a simple Poisson
!# optimal control problem with constant coefficients on a simple domain.
!# </purpose>
!#
!# Problem and system definition
!# -----------------------------
!# The system to solve is the following:
!#
!#  -Laplace(y) = f + u
!#  -Laplace(p) = u - z
!#            u = P(-1/alpha p)
!#
!# with:
!#   u = primal solution
!#   p = dual solution
!#   z = target solution
!#
!# The boundary conditions for the dual solution are =0 on the
!# Dirichlet boundary.
!# The projection operator
!#
!#   P(g) = P(g)g = P[a,b](g)g = max(a,min(b,g))
!#
!# with
!#
!#   P(h)g = a     , for all x with h(x) < a
!#         = g(x)  , for all x with a <= h(x) <= b
!#         = b     , for all x with h(x) > b
!#
!# for a function g=g(x) defines the projection to the interval [a,b].
!# In the moment where this operator get's active, the system
!# is going to be nonlinear!
!#
!# In the simple case b=-a=infinity, the projection operator is the
!# identity, so we get the system
!#
!#  -Laplace(y) + 1/alpha p = f
!#  -Laplace(p) - u = -z
!#
!# which corresponds to the system
!#
!#  (  A    1/alpha M ) ( y )= (  f )
!#  ( -M    A         ) ( p )  ( -z )
!#
!# A simple UMFPACK Gauss elimination can be used to solve this
!# system, as it is completely linear.
!#
!# In the moment where the projection is active, the whole
!# thing gets a little bit harder. In that moment, we have
!# to solve
!#
!#  (  A    -P(u) ) ( y ) = (  f )
!#  ( -M    A     ) ( p )   ( -z )
!#
!# To solve this system, we can use a Newton iteration.
!# This is written down as follows:
!#
!#  ( y_n+1 ) = ( y_n ) + (  A   -P'(u_n)(-1/alpha .) )^-1 [ (  f ) - (  A    -P(u_n)(-1/alpha .) ) ( y_n ) ]
!#  ( p_n+1 )   ( p_n )   ( -M    A                   )    [ ( -z )   ( -M    A                   ) ( p_n ) ]
!#
!# <=>
!#
!#  ( y_n+1 ) = ( y_n ) + (  A    P'(u_n)(1/alpha .) )^-1 [ (  f ) - (  A    P(u_n)(1/alpha .) ) ( y_n ) ]
!#  ( p_n+1 )   ( p_n )   ( -M    A                  )    [ ( -z )   ( -M    A                 ) ( p_n ) ]
!#
!# where u_n = -1/alpha p_n and P'(g) (and its corresponding matrix) is
!# the semismooth Newton operator the projection P(g). This operator is defined by
!#
!#   P'(h)g (x) = g(x)  , if a <= h(x) <= b
!#              = 0     , elsewhere
!#
!# or in another way of writing:
!#
!#   P'(h) = Id  , for all x with a <= h(x) <= b
!#         = 0   , elsewhere.
!#
!# For the corresponding matrix, this can be interpreted as
!#
!#   P'(h)g = M  , for all nodes (vertices) x where a <= h(x) <= b
!#          = 0  , elsewhere (-> insert a zero row to the mass matrix!)
!#
!# Iterating this Newton iteration to convergence gives the optimal control u.
!#
!# -----
!#
!# Current problem:
!#
!# 1.) bpointBC=TRUE:
!#
!#  min J(y,u) = |y-z|^2 + alpha/2 |u|
!#
!# with alpha=0.001 and
!#
!#    -Laplace(y) = u
!#              y = 0    in (0,0)
!#          dy/dn = 0    on boundary of [0,1]^2 \ (0,0)
!#       -1 <= u <= 1
!#              z = x1 + x2
!#
!# 2.) bpointBC=FALSE:
!#
!#  min J(y,u) = |y-z|^2 + alpha/2 |u|
!#
!# with alpha=0.001 and
!#
!#    -Laplace(y) = u
!#              y = 0    on boundary of [0,1]^2
!#        0 <= u <= 15
!#              z = x1 + x2
!#
!##############################################################################

module poisson2d_method0_simple

  use fsystem
  use genoutput
  use storage
  use boundary
  use cubature
  use linearalgebra
  use matrixfilters
  use vectorfilters
  use bcassembly
  use triangulation
  use spatialdiscretisation
  use ucd
  use pprocerror
  use genoutput
  use stdoperators
  use spdiscprojection
  use convection
  use analyticprojection
  use optcontrolconvection
  use matrixio
  use collection
  use filtersupport
  use scalarpde
  use bilinearformevaluation
  use linearformevaluation
  use multilevelprojection
  use linearsolver
  use matrixmodification

  use poisson2d_callback

  implicit none

contains

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

  subroutine massmatfilter (rmatrix, rvector, dalphaC, dmin, dmax)

  ! Filters a mass matrix. The lines in the matrix rmatrix corresponding
  ! to all entries in the (control-)vector violating the constraints
  ! of the problem.

  ! Matrix to be filtered
  type(t_matrixScalar), intent(inout) :: rmatrix

  ! Vector containing a dial solution lambda. Whereever -1/alpha*lambda
  ! violates the control constraints given by rmatrixComponents, the corresponding
  ! lines are set to 0.
  type(t_vectorScalar), intent(in) :: rvector

  ! ALPHA regularisation parameter from the space-time matrix
  real(dp), intent(in) :: dalphaC

  ! minimum bound for the control
  real(dp), intent(in) :: dmin

  ! maximum bound for the control
  real(dp), intent(in) :: dmax

    ! local variables
    real(dp), dimension(:), pointer :: p_Ddata
    integer, dimension(:), allocatable :: p_Idofs
    integer :: i,nviolate
    real(dp) :: du

    ! Get the vector data
    call lsyssc_getbase_double (rvector,p_Ddata)

    ! Figure out the DOF's violating the constraints
    allocate(p_Idofs(rvector%NEQ))

    nviolate = 0
    do i=1,rvector%NEQ
      du = -p_Ddata(i)/dalphaC
      if ((du .le. dmin) .or. (du .ge. dmax)) then
        nviolate = nviolate + 1
        p_Idofs(nviolate) = i
      end if
    end do

    if (nviolate .gt. 0) then
      ! Filter the matrix
      call mmod_replaceLinesByZero (rmatrix,p_Idofs(1:nviolate))
    end if

    deallocate(p_Idofs)

  end subroutine

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

!<subroutine>

  subroutine projectControlTimestep (rdualSolution,dumin,dumax)

!<description>
  ! Projects a dual solution vector u in such a way, that
  ! dumin <= u <= dumax holds.
!</description>

!<input>
  ! Minimum value for u
  real(DP), intent(in) :: dumin

  ! Maximum value for u
  real(DP), intent(in) :: dumax
!</input>

!<inputoutput>
  ! Vector to be restricted
  type(t_vectorScalar), intent(inout) :: rdualSolution
!</inputoutput>

!</subroutine>

    ! local variables
    real(DP), dimension(:), pointer :: p_Ddata
    integer :: i

    ! Get the vector array
    call lsyssc_getbase_double (rdualSolution,p_Ddata)

    ! Restrict the vector
    do i=1,rdualSolution%NEQ
      p_Ddata(i) = min(max(p_Ddata(i),dumin),dumax)
    end do

  end subroutine

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

!<subroutine>

  subroutine poisson2d_0_simple

!<description>
  ! This is an all-in-one poisson solver for directly solving a Poisson
  ! problem without making use of special features like collections
  ! and so on. The routine 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>

    ! Definitions of variables.
    !
    ! We need a couple of variables for this problem. Let's see...
    !
    ! An object for saving the domain:
    type(t_boundary) :: rboundary

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

    ! An object specifying the discretisation.
    ! This contains also information about trial/test functions,...
    type(t_blockDiscretisation) :: rdiscretisation
    type(t_spatialDiscretisation) :: rdiscrOutput

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

    ! A scalar matrix and vector. The vector accepts the RHS of the problem
    ! in scalar form.
    type(t_matrixScalar) :: rmatrixLaplace, rmatrixMass, rmatrixMassLump

    ! A block matrix and a couple of block vectors. These will be filled
    ! with data for the linear solver.
    type(t_matrixBlock) :: rmatrixBlock
    type(t_vectorBlock) :: rvectorBlock,rrhsBlock,rtempRhsBlock
    type(t_vectorScalar) :: rvectorTmp,rvectorOutput

    ! A set of variables describing the discrete boundary conditions.
    type(t_boundaryRegion) :: rboundaryRegion
    type(t_discreteBC), target :: rdiscreteBC

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

    ! An array for the system matrix(matrices) during the initialisation of
    ! the linear solver.
    type(t_matrixBlock), dimension(1) :: Rmatrices

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

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

    ! Error of FE function to reference function
    real(DP) :: derror

    ! Data for the Newton iteration
    integer :: ite, nmaxiterations
    real(dp) :: dinitRes, dcurrentRes

    ! Relaxation parameters
    real(DP) :: dalpha
    logical :: bboundsActive
    integer :: itypeBC
    real(dp) :: dmax,dmin

    ! Output block for UCD output to GMV file
    type(t_ucdExport) :: rexport
    real(DP), dimension(:), pointer :: p_Ddata

    ! Ok, let's start.
    !
    ! We want to solve our Poisson problem on level...
    NLMAX = 6

    ! Newton iteration counter
    nmaxiterations = 10

    ! Relaxation parameter
    dalpha = 0.001_DP

    ! 0=Neumann problem
    ! 1=BC on whole boundary.
    ! 2=BC only on (0,0).
    itypeBC = 0

    select case (itypeBC)
    case (0)
      bboundsActive = .false.
    case (1)
      ! Bounds on the control
      bboundsActive = .true.
      dmin = -1.0_DP
      dmax = 1.0_DP
    case (2)
      ! Bounds on the control
      bboundsActive = .true.
      dmin = 0.0_DP
      dmax = 15.0_DP
    case (3)
      ! No bounds
      bboundsActive = .false.
    case (4)
      ! No bounds
      bboundsActive = .false.
    end select

    ! At first, read in the parametrisation of the boundary and save
    ! it to rboundary.
    call boundary_read_prm(rboundary, './pre/QUAD.prm')

    ! Now read in the basic triangulation.
    call tria_readTriFile2D (rtriangulation, './pre/QUAD.tri', rboundary)

    ! Refine it.
    call tria_quickRefine2LevelOrdering (NLMAX-1,rtriangulation,rboundary)

    ! And create information about adjacencies and everything one needs from
    ! a triangulation.
    call tria_initStandardMeshFromRaw (rtriangulation,rboundary)

    ! Set up a block discretisation structure for two components:
    ! Primal and dual solution vector.
    call spdiscr_initBlockDiscr (rdiscretisation,2,&
                                 rtriangulation, rboundary)

    ! Set up the blocks. Both are discretised with the same finite element.
    call spdiscr_initDiscr_simple (rdiscretisation%RspatialDiscr(1), &
        EL_Q1,CUB_G3X3,rtriangulation, rboundary)
    call spdiscr_duplicateDiscrSc (rdiscretisation%RspatialDiscr(1), &
        rdiscretisation%RspatialDiscr(2), .true.)

    ! Now as the discretisation is set up, we can start to generate
    ! the structure of the system matrix which is to solve.
    ! We create a scalar matrix, based on the discretisation structure
    ! for our one and only solution component.
    call bilf_createMatrixStructure (rdiscretisation%RspatialDiscr(1),&
                                     LSYSSC_MATRIX9,rmatrixLaplace)

    ! Assemble the Laplace matrix.
    call stdop_assembleLaplaceMatrix (rmatrixLaplace)

    ! And a mass matrix; we need it for the coupling.
    ! Share the structure with the Laplace matrix.
    call lsyssc_duplicateMatrix (rmatrixLaplace,rmatrixMass,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_REMOVE)
    call stdop_assembleSimpleMatrix (rmatrixMass,DER_FUNC,DER_FUNC)

    ! Lumped mass matrix
    call lsyssc_duplicateMatrix (rmatrixMass,rmatrixMassLump,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_COPY)
    call lsyssc_lumpMatrixScalar (rmatrixMassLump,LSYSSC_LUMP_DIAG,.true.)

    ! -----
    ! Boundary conditions
    !
    ! In our example, we have pure Dirichlet-0-BC on all boundary components.

    call bcasm_initDiscreteBC(rdiscreteBC)

    select case (itypeBC)
    case (0)
    case (1,3)
      ! Edge 1 of boundary component 1 the domain.
      call boundary_createRegion(rboundary,1,1,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (rdiscretisation,1,&
                                        rboundaryRegion,rdiscreteBC,&
                                        getBoundaryValuesPrimal_2D)

      ! Now to the edge 2 of boundary component 1 the domain.
      call boundary_createRegion(rboundary,1,2,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (rdiscretisation,1,&
                                        rboundaryRegion,rdiscreteBC,&
                                        getBoundaryValuesPrimal_2D)

      ! Edge 3 of boundary component 1.
      call boundary_createRegion(rboundary,1,3,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (rdiscretisation,1,&
                                        rboundaryRegion,rdiscreteBC,&
                                        getBoundaryValuesPrimal_2D)

      ! Edge 4 of boundary component 1. That's it.
      call boundary_createRegion(rboundary,1,4,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (rdiscretisation,1,&
                                        rboundaryRegion,rdiscreteBC,&
                                        getBoundaryValuesPrimal_2D)

      ! ---
      ! The same for the dual variable.
      call boundary_createRegion(rboundary,1,1,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (rdiscretisation,2,&
                                        rboundaryRegion,rdiscreteBC,&
                                        getBoundaryValuesDual_2D)

      ! Now to the edge 2 of boundary component 1 the domain.
      call boundary_createRegion(rboundary,1,2,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (rdiscretisation,2,&
                                        rboundaryRegion,rdiscreteBC,&
                                        getBoundaryValuesDual_2D)

      ! Edge 3 of boundary component 1.
      call boundary_createRegion(rboundary,1,3,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (rdiscretisation,2,&
                                        rboundaryRegion,rdiscreteBC,&
                                        getBoundaryValuesDual_2D)

      ! Edge 4 of boundary component 1. That's it.
      call boundary_createRegion(rboundary,1,4,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (rdiscretisation,2,&
                                        rboundaryRegion,rdiscreteBC,&
                                        getBoundaryValuesDual_2D)

    case (2,4)
      ! Edge 1 of boundary component 1 the domain.
      call boundary_createRegion(rboundary,1,1,rboundaryRegion)
      rboundaryRegion%dmaxParam = 0.0_DP

      call bcasm_newDirichletBConRealBD (rdiscretisation,1,&
                                        rboundaryRegion,rdiscreteBC,&
                                        getBoundaryValuesPrimal_2D)

      ! ---
      ! The same for the dual variable.
      call boundary_createRegion(rboundary,1,1,rboundaryRegion)
      rboundaryRegion%dmaxParam = 0.0_DP

      call bcasm_newDirichletBConRealBD (rdiscretisation,2,&
                                        rboundaryRegion,rdiscreteBC,&
                                        getBoundaryValuesDual_2D)

    end select

    ! -----
    ! Linear system: Basic structure.
    !
    ! Create a 2x2 matrix and 2-block vectors from the discretisation.
    call lsysbl_createVecBlockByDiscr (rdiscretisation,rrhsBlock)
    call lsysbl_createVecBlockByDiscr (rdiscretisation,rvectorBlock)
    call lsysbl_createVecBlockByDiscr (rdiscretisation,rtempRhsBlock)
    call lsyssc_createVecByDiscr (rdiscretisation%RspatialDiscr(1),rvectorTmp)

    ! Create the RHS vector f of the primal equation
    rlinform%itermCount = 1
    rlinform%Idescriptors(1) = DER_FUNC
    call linf_buildVectorScalar (rdiscretisation%RspatialDiscr(1),&
                                  rlinform,.true.,rrhsBlock%RvectorBlock(1),&
                                  coeff_RHS_primal_2D)

    ! Create the RHS vector -z of the dual equation
    call linf_buildVectorScalar (rdiscretisation%RspatialDiscr(1),&
                                  rlinform,.true.,rrhsBlock%RvectorBlock(2),&
                                  coeff_RHS_dual_2D)

    call vecfil_discreteBCrhs (rrhsBlock,rdiscreteBC)

    ! -----
    ! Newton iteration
    !
    ! Initialise the solution vector.
    call lsysbl_clearVector (rvectorBlock)

    call vecfil_discreteBCsol (rvectorBlock,rdiscreteBC)

    do ite = 1,nmaxIterations

      ! Create the nonliear defect
      !  (d1) =  (  f ) - (  A    -P(u)(-1/alpha .) ) ( y )
      !  (d2)    ( -z )   ( -M    A                 ) ( p )
      ! We do this manually...

      call lsysbl_getbase_double (rtempRhsBlock,p_Ddata)
      call lsysbl_copyVector (rrhsBlock,rtempRhsBlock)

      call lsyssc_scalarMatVec (rmatrixLaplace,&
          rvectorBlock%RvectorBlock(1),rtempRhsBlock%RvectorBlock(1),-1.0_DP,1.0_DP)
      call lsyssc_scalarMatVec (rmatrixLaplace,&
          rvectorBlock%RvectorBlock(2),rtempRhsBlock%RvectorBlock(2),-1.0_DP,1.0_DP)
      call lsyssc_scalarMatVec (rmatrixMass,&
          rvectorBlock%RvectorBlock(1),rtempRhsBlock%RvectorBlock(2),1.0_DP,1.0_DP)

      ! No constraints: -P(u_n) = 1/alpha p_n -> multiply p_n by weighted Mass matrix.
      ! Constraints active: Create the projection and multiply by the weighted mass matrix.
      call lsyssc_copyVector (rvectorBlock%RvectorBlock(2),rvectorTmp)
      call lsyssc_scaleVector (rvectorTmp,-1.0_DP/dalpha)
      if (bboundsActive) then
        call projectControlTimestep (rvectorTmp,dmin,dmax)
      end if
      call lsyssc_scalarMatVec (rmatrixMass,&
          rvectorTmp,rtempRhsBlock%RvectorBlock(1),1.0_DP,1.0_DP)

      if (itypeBC .eq. 0) then
        ! Prepare a pure Neumann problem.
        !
        ! impose int(f)=0 into the RHS using the l1-0 filter
        call vecfil_subvectorSmallL1To0 (rtempRhsBlock,1)
        call vecfil_subvectorSmallL1To0 (rtempRhsBlock,2)
      end if

      ! Include boundary conditions
      call vecfil_discreteBCdef (rtempRhsBlock,rdiscreteBC)

      ! Check for convergence
      if (ite .eq. 1) then
        dinitRes = lsysbl_vectorNorm(rtempRhsBlock,LINALG_NORML2)
        call output_line ('Iteration: '//TRIM(sys_siL(ite-1,10))//&
            ', Initial defect: '//sys_sdEL(dinitRes,10))
      else
        dcurrentRes = lsysbl_vectorNorm(rtempRhsBlock,LINALG_NORML2)
        call output_line ('Iteration: '//TRIM(sys_siL(ite-1,10))//&
            ', Current defect: '//sys_sdEL(dcurrentRes,10))
        if (dcurrentRes .lt. dinitRes * 1E-10_DP) exit
      end if

      ! Prepare the preconditioner matrix (Newton).
      call lsysbl_createMatBlockByDiscr (rdiscretisation,rmatrixBlock)
      call lsyssc_duplicateMatrix (rmatrixLaplace,rmatrixBlock%RmatrixBlock(1,1),&
          LSYSSC_DUP_COPY,LSYSSC_DUP_COPY)
      call lsyssc_duplicateMatrix (rmatrixLaplace,rmatrixBlock%RmatrixBlock(2,2),&
          LSYSSC_DUP_COPY,LSYSSC_DUP_COPY)
      call lsyssc_duplicateMatrix (rmatrixMass,rmatrixBlock%RmatrixBlock(2,1),&
          LSYSSC_DUP_SHARE,LSYSSC_DUP_COPY)
      rmatrixBlock%RmatrixBlock(2,1)%dscaleFactor = -1.0_DP

      ! Copy also the mass matrix for the 4th block. In the case of no
      ! control constraints, that's it!
      call lsyssc_duplicateMatrix (rmatrixMass,rmatrixBlock%RmatrixBlock(1,2),&
          LSYSSC_DUP_SHARE,LSYSSC_DUP_COPY)
      rmatrixBlock%RmatrixBlock(1,2)%dscaleFactor = -(-1.0_DP/dalpha)

      if (bboundsActive) then
        ! Filter the mass matrix. Set those rows to zero where the DOF's are out
        ! of bounds. The result is the derivative of the projection operator...
        call massmatfilter (rmatrixBlock%RmatrixBlock(1,2), &
            rvectorBlock%RvectorBlock(2), dalpha, dmin, dmax)
      end if

      call matfil_discreteBC (rmatrixBlock,rdiscreteBC)

      if (itypeBC .eq. 0) then
        ! Prepare a pure Neumann problem.
        !
        ! impose int(f)=0 into the RHS using the l1-0 filter
        call vecfil_OneEntryZero (rtempRhsBlock,1,1)
        call vecfil_OneEntryZero (rtempRhsBlock,2,1)

        ! Impose the condition int(u)=0 into the matrix using
        ! the lumped mass matrix.
        call mmod_replaceLineByLumpedMass (rmatrixBlock%RmatrixBlock(1,1),1,rmatrixMassLump)
        call mmod_replaceLineByLumpedMass (rmatrixBlock%RmatrixBlock(2,2),1,rmatrixMassLump)
        call mmod_replaceLinesByZero (rmatrixBlock%RmatrixBlock(1,2),(/1/))
        call mmod_replaceLinesByZero (rmatrixBlock%RmatrixBlock(2,1),(/1/))

      end if

      ! Prepare an UMFPACK solver for the system
      call linsol_initUMFPACK4(p_rsolverNode)

      ! Set the output level of the solver to 2 for some output
      p_rsolverNode%ioutputLevel = 2

      ! Attach the system matrix to the solver.
      ! First create an array with the matrix data (on all levels, but we
      ! only have one level here), then call the initialisation
      ! routine to attach all these matrices.
      ! Remark: Don't make a call like
      !    CALL linsol_setMatrices(p_RsolverNode,(/p_rmatrix/))
      ! This doesn't work on all compilers, since the compiler would have
      ! to create a temp array on the stack - which does not always work!
      call linsol_setMatrix(p_RsolverNode,rmatrixBlock)

      ! Initialise structure/data of the solver. This allows the
      ! solver to allocate memory / perform some precalculation
      ! to the problem.
      call linsol_initStructure (p_rsolverNode, ierror)
      if (ierror .ne. LINSOL_ERR_NOERROR) stop
      call linsol_initData (p_rsolverNode, ierror)
      if (ierror .ne. LINSOL_ERR_NOERROR) stop

      ! Preconditioning of the defect by the inverse of the Newton matrix
      call linsol_precondDefect (p_rsolverNode,rtempRhsBlock)

      ! Release solver data and structure
      call linsol_doneData (p_rsolverNode)
      call linsol_doneStructure (p_rsolverNode)

      ! Release the solver node and all subnodes attached to it (if at all):
      call linsol_releaseSolver (p_rsolverNode)

      ! Release the matrix
      call lsysbl_releaseMatrix (rmatrixBlock)

      if (itypeBC .eq. 0) then
        ! Solution filter for the pure Neumann problem.
        ! Actually not necessaty.
        !
        ! Impose int(f)=0 into the correction using the L1-0 filter
        call vecfil_subvectorL1To0byLmass (rtempRhsBlock,1,rmatrixMassLump)

      end if

      ! Sum up the correction to the current solution.
      call lsysbl_vectorLinearComb (rtempRhsBlock,rvectorBlock,1.0_DP,1.0_DP)

      ! Plug in the BC's to the solution
      call vecfil_discreteBCsol (rvectorBlock,rdiscreteBC)

    end do

    ! That's it, rvectorBlock now contains our solution. We can now
    ! start the postprocessing.
    ! Start UCD export to GMV file:
    call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                       'gmv/up2d_0_simple.vtk')

    call spdp_stdProjectionToP1Q1Scalar (rvectorBlock%RvectorBlock(1),&
      rvectorOutput,rdiscrOutput)

    call lsyssc_getbase_double (rvectorOutput,p_Ddata)

    call ucd_addVariableVertexBased (rexport,'solprimal',UCD_VAR_STANDARD, p_Ddata)
    call spdp_stdProjectionToP1Q1Scalar (rvectorBlock%RvectorBlock(2),&
        rvectorOutput,rdiscrOutput)
    call ucd_addVariableVertexBased (rexport,'soldual',UCD_VAR_STANDARD, p_Ddata)

    call lsyssc_copyVector (rvectorBlock%RvectorBlock(2),rvectorTmp)
    call lsyssc_scaleVector (rvectorTmp,-1.0_DP/dalpha)
    if (bboundsActive) then
      call projectControlTimestep (rvectorTmp,dmin,dmax)
    end if
    call spdp_stdProjectionToP1Q1Scalar (rvectorTmp,&
        rvectorOutput,rdiscrOutput)
    call ucd_addVariableVertexBased (rexport,'control',UCD_VAR_STANDARD, p_Ddata)

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

    ! Calculate the error to the reference function.
    call pperr_scalar (rvectorBlock%RvectorBlock(1),PPERR_L2ERROR,derror,&
                       getReferenceFunction_2D)
    call output_line ('L2-error: ' // sys_sdEL(derror,10) )

    call pperr_scalar (rvectorBlock%RvectorBlock(1),PPERR_H1ERROR,derror,&
                       getReferenceFunction_2D)
    call output_line ('H1-error: ' // sys_sdEL(derror,10) )

    ! We are finished - but not completely!
    ! Now, clean up so that all the memory is available again.

    ! Release the block matrix/vectors
    call lsyssc_releaseVector (rvectorOutput)
    call lsyssc_releaseVector (rvectorTmp)
    call lsysbl_releaseVector (rtempRhsBlock)
    call lsysbl_releaseVector (rvectorBlock)
    call lsysbl_releaseVector (rrhsBlock)

    call lsyssc_releaseMatrix (rmatrixMassLump)
    call lsyssc_releaseMatrix (rmatrixMass)
    call lsyssc_releaseMatrix (rmatrixLaplace)

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

    ! Release the discretisation structure and all spatial discretisation
    ! structures in it.
    call spdiscr_releaseDiscr(rdiscrOutput)
    call spdiscr_releaseBlockDiscr(rdiscretisation)

    ! Release the triangulation.
    call tria_done (rtriangulation)

    ! Finally release the domain, that's it.
    call boundary_release (rboundary)

  end subroutine

end module


real*8 function SHSjkPG0(incspectra, j, k, l, m, evec, lwin)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function will compute the expected windowed cross-power spectra for a two fields,
!	which are windowed by tapers j and k. Note that this is only valid for zonal tapers.
!	This corresponds to the variable (this is eq. D8 of Wieczoek and Simons 2005):
!
!	   (j,k)
!	< S      (l,m) >
!	   PG
!
!	It can be shown that SPGjk(l,-m) = SPGjk(l,m).
!
!	Calling Parameteters
!		IN
!			incspectra	Knonw input (cross) power spectra
!					as a function of degree.
!			j, k		Taper numbers
!			l, m 		Angular degree and order.
!			evec		Matrix containing the spectral coefficients of the
!					zonal tapers.
!			lwin		Spherical harmonic bandwidth of the windows.
!
!	Dependencies: Wigner3j.
!
!	Written by Mark Wieczorek, May 2006.
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: Wigner3j
	implicit none

	real*8, intent(in) ::	incspectra(:), evec(:,:)
	integer, intent(in) ::	lwin, l, m, j, k
	integer ::	i, l1, l2, imin, imax, &
			l10min, l10max, l1min, l1max, l20min, l20max, l2min, l2max
	real*8 :: 	wl10(lwin+l+1), wl20(lwin+l+1), &
			wl1(lwin+l+1), wl2(lwin+l+1)

	if (size(evec(1,:)) < lwin+1 .or. size(evec(:,1)) < lwin+1) then
		print*, "Error --- SHSjkPG"
		print*, "EVEC must be dimensioned (LWIN+1, LWIN+1) where LWIN is ", lwin
		print*, "Input array is dimensioned", size(evec(:,1)), size(evec(1,:))
		stop
	elseif(size(incspectra(:)) < l+lwin + 1) then
		print*, "Error --- SHSjkPG"
		print*, "INCSPECTRA must be dimensioned as (L+LWIN+1) where L and LWIN are ", l, lwin
		print*, "Input arrays is dimensioned ", size(incspectra)
		stop
	elseif(j>lwin+1 .or. k>lwin+1) then
		print*, "Error --- SHSjkPG"
		print*, "J and K must be less then LWIN+1."
		print*, "J = ", j
		print*, "K = ", k
		stop
	endif

	SHSjkPG0 = 0.0d0

	if (l<abs(m)) return

	do l1=0, lwin, 1
		call Wigner3j(wl10, l10min, l10max, l1, l, 0, 0, 0)
		call Wigner3j(wl1, l1min, l1max, l1, l, m, 0, -m)

		do l2 = 0, lwin, 1
			call Wigner3j(wl20, l20min, l20max, l2, l, 0, 0, 0)
			call Wigner3j(wl2, l2min, l2max, l2, l, m, 0, -m)
			imin = max(l1min, l2min)
			imax = min(l1max, l2max)

			do i=imin, imax, 1
				if (mod(i+l1+l,2) == 0 .and. mod(i+l2+l,2) == 0 ) then
					SHSjkPG0 = SHSjkPG0 + evec(l1+1,j)*evec(l2+1,k) * &
						incspectra(i+1) * sqrt(2.0d0*l1+1.0d0) * sqrt(2.0d0*l2+1.0d0) * &
						(2.0d0*l+1.0d0) *  wl10(i-l10min+1) * wl20(i-l20min+1) * &
						wl1(i-l1min+1) * wl2(i-l2min+1)
				endif
			enddo
		enddo
	enddo

end function SHSjkPG0


!-------------------------------------------------------------------------------------------------
! Fortran source code for module et_rng.frng
!-------------------------------------------------------------------------------------------------
! Remarks:
!   . Enter Python documentation for this module in ``./frng.rst``.
!     You might want to check the f2py output for the interfaces of the C-wrapper functions.
!     It will be autmatically included in the et_rng documentation.
!   . Documument the Fortran routines in this file. This documentation will not be included
!     in the et_rng documentation (because there is no recent sphinx
!     extension for modern fortran.
module f90
    implicit none

    ! The Fortrtan version store the state of the function as module variables. Note that this way
    ! we can have only one random number generator, as there is only a single state.
    integer*8, parameter :: a=2147483629_8
    integer*8, parameter :: b=2147483629_8
    integer*8, parameter :: m=2_8**31-1
    integer*8            :: seed = 0_8
    integer*8            :: x    = 0_8
    ! REMARK: Fortran has no standard support for unsigned integers. So we use signed
    ! integers. As a consequence the Python version and the Fortran version are not
    ! entirely equivalent, since the range of allowed numbers in the Fortran version
    ! is only half of that in Python (half of the range is for negative numbers).

    contains
        subroutine set_seed(s)
            integer*8, intent(in) :: s
            seed = s
            x = s
        end subroutine set_seed

        function lcg1()
          ! Compute the next random number in the sequence
            implicit none
            integer*8 :: lcg1 ! result type

            ! modify the state
            x = modulo( a*x+b, m )
            ! assign result
            lcg1 = x

        end function lcg1

end module f90


!
! ej8b.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
program powspec

use precision, pr => dp

IMPLICIT NONE

include "/usr/include/fftw3.f"
integer                 :: plan_rc, plan_cr

integer, parameter      :: N = 500
integer                 :: i, j, k, t
real(pr)                :: rr, trash1, trash2, trash3, fre, fim
real(pr), dimension(:)  :: xc(200), x(200), d(N), r(5)
complex(pr), dimension(101) :: x_hat, xc_hat
character(len=4)        :: rj

r = (/1.5_pr, 3.3_pr, 3.5_pr, 3.55_pr, 4._pr/)

print '(F4.2)', r(1), r(2), r(3), r(4), r(5)

do j = 1, 5

    write(rj, '(F4.2)') r(j)
    print *, 'ej8a_r_'//trim(rj)//'.dat'

    open(unit=10, file='ej8a_r_'//trim(rj)//'.dat', action='READ')
    read(10, *)

    do i = 1, N
        read(10, *) t, trash1, trash2, d(i), trash3, rr
    end do
    close(10)

    call dfftw_plan_dft_r2c_1d(plan_rc, 200, xc, xc_hat, FFTW_MEASURE)
    xc = d(301:500)
    call dfftw_execute_dft_r2c(plan_rc, xc, xc_hat)
    x_hat = xc_hat

    call dfftw_destroy_plan(plan_rc)

    open(unit=11, file='fourier'//'ej8a_r_'//trim(rj)//'.dat', action='write',&
        & status='unknown')
    write(11, *) "#  freq    real    imag"

    do k = -100, 100, 1
        if (k < 0) then
            fre = real(conjg(x_hat(-k+1) )/real(200, pr))
            fim = imag(conjg(x_hat(-k+1) )/real(200, pr))
            write(11,*) real(k, pr),  fre, fim
        else
            fre = real(x_hat(k+1) /real(200, pr))
            fim = imag(x_hat(k+1) /real(200, pr))
            write(11,*) real(k, pr), fre, fim
        end if
    end do
    close(11)
end do

end program powspec


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Main test program for the FFT interface
!  - use input data from a NAG FFT library for validation
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program fft_test_c2c

use decomp_2d
use decomp_2d_fft

implicit none

integer, parameter :: nx=2, ny=3, nz=4
integer, parameter :: p_row=2, p_col=2

complex(mytype), allocatable, dimension(:,:,:) :: in, out

complex(mytype), dimension(nx,ny,nz) :: in1, out1
integer :: ierror, i,j,k

interface
   subroutine assemble_global(ndir,local,global,nx,ny,nz)
     use decomp_2d
     integer, intent(IN) :: ndir
     integer, intent(IN) :: nx,ny,nz
     complex(mytype), dimension(:,:,:), intent(IN) :: local
     complex(mytype), dimension(nx,ny,nz), intent(OUT) :: global
   end subroutine assemble_global
end interface

call MPI_INIT(ierror)
call decomp_2d_init(nx,ny,nz,p_row,p_col)
call decomp_2d_fft_init

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! (1) Testing the complex-to-complex interface (c2c)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!  input is X-pencil data
! output is Z-pencil data
allocate (in(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))
allocate (out(zstart(1):zend(1),zstart(2):zend(2),zstart(3):zend(3)))

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Following is the testing input for NAG library C06FXF
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
in1(1,1,1) = (1.000,  0.000)
in1(1,1,2) = (0.999, -0.040)
in1(1,1,3) = (0.987, -0.159)
in1(1,1,4) = (0.936, -0.352)
in1(1,2,1) = (0.994, -0.111)
in1(1,2,2) = (0.989, -0.151)
in1(1,2,3) = (0.963, -0.268)
in1(1,2,4) = (0.891, -0.454)
in1(1,3,1) = (0.903, -0.430)
in1(1,3,2) = (0.885, -0.466)
in1(1,3,3) = (0.823, -0.568)
in1(1,3,4) = (0.694, -0.720)
in1(2,1,1) = (0.500,  0.500)
in1(2,1,2) = (0.499,  0.040)
in1(2,1,3) = (0.487,  0.159)
in1(2,1,4) = (0.436,  0.352)
in1(2,2,1) = (0.494,  0.111)
in1(2,2,2) = (0.489,  0.151)
in1(2,2,3) = (0.463,  0.268)
in1(2,2,4) = (0.391,  0.454)
in1(2,3,1) = (0.403,  0.430)
in1(2,3,2) = (0.385,  0.466)
in1(2,3,3) = (0.323,  0.568)
in1(2,3,4) = (0.194,  0.720)

! each processor gets its local portion of global data
do k=xstart(3),xend(3)
   do j=xstart(2),xend(2)
      do i=xstart(1),xend(1)
         in(i,j,k) = in1(i,j,k)
      end do
   end do
end do

! write out input, to match the format of NAG example result file
if (nrank==0) then
   write(*,*) 'C06FXF Example Program Results'
   write(*,*) ''
   write(*,*) 'Original data values'
   write(*,*) ''
   call print_global(in1,nx,ny,nz)
end if

! ===== 3D forward FFT =====
call decomp_2d_fft_3d(in, out, DECOMP_2D_FFT_FORWARD)

! normalisation - note FFTW doesn't normalise
do k=zstart(3),zend(3)
   do j=zstart(2),zend(2)
      do i=zstart(1),zend(1)
         out(i,j,k) = out(i,j,k) / sqrt(real(nx*ny*nz))
      end do
   end do
end do

call assemble_global(3,out,out1,nx,ny,nz)

! write out forward FFT result
if (nrank==0) then
   write(*,*) 'Components of discrete Fourier transform'
   write(*,*) ''
   call print_global(out1,nx,ny,nz)
end if

! ===== 3D inverse FFT =====
call decomp_2d_fft_3d(out, in, DECOMP_2D_FFT_BACKWARD)

! normalisation - note FFTW doesn't normalise
do k=xstart(3),xend(3)
   do j=xstart(2),xend(2)
      do i=xstart(1),xend(1)
         in(i,j,k) = in(i,j,k) / sqrt(real(nx*ny*nz))
      end do
   end do
end do

call assemble_global(1,in,in1,nx,ny,nz)

! write out inverse FFT result
if (nrank==0) then
   write(*,*) 'Original sequence as restored by inverse transform'
   write(*,*) ''
   call print_global(in1,nx,ny,nz)
end if

call decomp_2d_fft_finalize
call decomp_2d_finalize
call MPI_FINALIZE(ierror)

end program fft_test_c2c

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Collect data from each processor and assemble into a global array
! at the master rank
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine assemble_global(ndir,local,global,nx,ny,nz)

  use decomp_2d
  use MPI

  implicit none

  integer, intent(IN) :: ndir  ! 1 = X-pencil; 3 = Z-pencil
  integer, intent(IN) :: nx,ny,nz
  complex(mytype), dimension(:,:,:), intent(IN) :: local
  complex(mytype), dimension(nx,ny,nz), intent(OUT) :: global

  complex(mytype), allocatable, dimension(:,:,:) :: rbuf
  integer, dimension(9) :: sbuf1, rbuf1

  integer :: ierror, i,j,k,m, i1,i2,j1,j2,k1,k2, count
  integer, dimension(MPI_STATUS_SIZE) :: status

  if (nrank==0) then
     ! master writes its own data to a global array
     if (ndir==3) then  ! Z-pencil
        i1 = zstart(1)
        i2 = zend(1)
        j1 = zstart(2)
        j2 = zend(2)
        k1 = zstart(3)
        k2 = zend(3)
     else if (ndir==1) then  ! X-pencil
        i1 = xstart(1)
        i2 = xend(1)
        j1 = xstart(2)
        j2 = xend(2)
        k1 = xstart(3)
        k2 = xend(3)
     end if
     do k=k1,k2
        do j=j1,j2
           do i=i1,i2
              ! 'local' is assumbed shape array
              ! but it is OK as starting index for rank 0 always 1
              global(i,j,k)=local(i,j,k)
           end do
        end do
     end do
     ! then loop through all other ranks to collect data
     do m=1,nproc-1
        CALL MPI_RECV(rbuf1,9,MPI_INTEGER,m,m,MPI_COMM_WORLD, &
             status,ierror)
        allocate(rbuf(rbuf1(1):rbuf1(2),rbuf1(4):rbuf1(5), &
             rbuf1(7):rbuf1(8)))
        CALL MPI_RECV(rbuf,rbuf1(3)*rbuf1(6)*rbuf1(9),complex_type,m, &
             m+nproc,MPI_COMM_WORLD,status,ierror)
        do k=rbuf1(7),rbuf1(8)
           do j=rbuf1(4),rbuf1(5)
              do i=rbuf1(1),rbuf1(2)
                 global(i,j,k)=rbuf(i,j,k)
              end do
           end do
        end do
        deallocate(rbuf)
     end do
  else
     ! slaves send data to mater
     if (ndir==3) then  ! Z-pencil
        sbuf1(1) = zstart(1)
        sbuf1(2) = zend(1)
        sbuf1(3) = zsize(1)
        sbuf1(4) = zstart(2)
        sbuf1(5) = zend(2)
        sbuf1(6) = zsize(2)
        sbuf1(7) = zstart(3)
        sbuf1(8) = zend(3)
        sbuf1(9) = zsize(3)
        count = zsize(1)*zsize(2)*zsize(3)
     else if (ndir==1) then  ! X-pencil
        sbuf1(1) = xstart(1)
        sbuf1(2) = xend(1)
        sbuf1(3) = xsize(1)
        sbuf1(4) = xstart(2)
        sbuf1(5) = xend(2)
        sbuf1(6) = xsize(2)
        sbuf1(7) = xstart(3)
        sbuf1(8) = xend(3)
        sbuf1(9) = xsize(3)
        count = xsize(1)*xsize(2)*xsize(3)
     end if
     ! send partition information
     CALL MPI_SEND(sbuf1,9,MPI_INTEGER,0,nrank,MPI_COMM_WORLD,ierror)
     ! send data array
     CALL MPI_SEND(local,count,complex_type,0, &
          nrank+nproc,MPI_COMM_WORLD,ierror)
  end if

  return
end subroutine assemble_global

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Print out a global data array using special format that matches
! NAG library C06FXF Example Program Results for validation purpose
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine print_global(data,nx,ny,nz)

use decomp_2d

implicit none

integer, intent(IN) :: nx,ny,nz
complex(mytype), dimension(nx,ny,nz), intent(IN) :: data

integer :: i,j,k

do i=1,nx
   write(*,10) i
   write(*,*) ''
   do j=1,ny
      write(*,20) (real(data(i,j,k)),k=1,nz)
      write(*,21) (aimag(data(i,j,k)),k=1,nz)
      write(*,*) ''
   end do
end do
10 format(1x,'z(i,j,k) for i =', I6)
20 format(1x,'Real ', 4F10.3)
21 format(1x,'Imag ', 4F10.3)

return
end subroutine print_global


c     program DRSMPVAL
c     Demonstrates SMPDRV, SMPINT, and SMPVAL.
c>> 1997-05-29 DRSMPVAL Krogh Special code for C conversion.
c>> 1996-05-28 DRSMPVAL Krogh Added external statement.
c>> 1994-10-19 DRSMPVAL Krogh  Changes to use M77CON
c>> 1993-02-04 DRSMPVAL CLL
c>> 1987-12-09 DRSMPVAL Lawson  Initial Code.
c     ------------------------------------------------------------------
c--S replaces "?": DR?MPVAL, ?MPDRV, ?MPINT, ?MPVAL
c     ------------------------------------------------------------------
c++ Code for .C. is inactive
c%%   long int n;
c++ End
      integer NQ, NR
      external SMPVAL
      real                 P(6),Q(7),R(6),Z,SMPVAL
      data     P/ 5.E0, 2.E0, 4.E0, -4.E0, 12.E0, 16.E0 /
c     ------------------------------------------------------------------
      call SMPINT(P, 3,Q,NQ)
      call SMPDRV(Q,NQ,R,NR)
      Z = SMPVAL(Q,NQ,6.E0) - SMPVAL(Q,NQ,4.E0)
c++ Code for ~.C. is active
      print '(21x,''P ='',2f4.0,2x,4f7.2/)', P
      print '('' INTEGRAL OF P.      Q ='',2f4.0,2x,5f7.2/)', Q
      print '('' DERIVATIVE OF Q.    R ='',2f4.0,2x,4f7.2/)', R
      print '('' DEFINITE INTEGRAL.  Z ='',f20.8)', Z
c++ Code for .C. is inactive
c%%   printf( "                     P =%4.0f%4.0f", p[0], p[1] );
c%%   for(n=2L; n < (long)(sizeof(p)/sizeof(p[1])); n++)
c%%           printf( "%7.2f", p[n] );
c%%   printf( "\n" );
c%%   printf( " INTEGRAL OF P.      Q =%4.0f%4.0f", q[0], q[1] );
c%%   for(n=2L; n < (long)(sizeof(q)/sizeof(q[1])); n++)
c%%           printf( "%7.2f", q[n] );
c%%   printf( "\n" );
c%%   printf( " DERIVATIVE OF Q.    R =%4.0f%4.0f", r[0], r[1] );
c%%   for(n=2L; n < (long)(sizeof(r)/sizeof(r[1])); n++)
c%%           printf( "%7.2f", r[n] );
c%%   printf( "\n" );
c%%   printf( " DEFINITE INTEGRAL.  Z =%20.8f\n", z );
c++ End
      stop
      end


      program example1
!  page 27
      use funcs  ! for modern Fortran only, ex1.f90

      real :: a(5) = [27, 36, 29, 10, 1]   ! modern way, I dislike obsolete "DATA"

      print *, avrgII(a,5)

      print *, avrg77(a,5)

      print *, avrg(a)

      end program

      function avrgII(alist, n)
! Fortran II way
      dimension alist(5)

      sum = alist(1)

      do 10 i = 2, n
10    sum = sum + alist(i)

      avrgII = sum / real(n)

      end

      function avrg77(alist, n)
! Fortran 77 way
      dimension alist(n)

       sum = alist(1)

      do  i = 2, n
        sum = sum + alist(i)
      end do

      avrg77 = sum / real(n)

      end


C
C     file hwsplr.f
C
      SUBROUTINE HWSPLR (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N+1),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES A FINITE DIFFERENCE APPROXIMATION TO
C                        THE HELMHOLTZ EQUATION IN POLAR COORDINATES.
C                        THE EQUATION IS
C
C                            (1/R)(D/DR)(R(DU/DR)) +
C                            (1/R**2)(D/DTHETA)(DU/DTHETA) +
C                            LAMBDA*U = F(R,THETA).
C
C USAGE                  CALL HWSPLR (A,B,M,MBDCND,BDA,BDB,C,D,N,
C                                     NBDCND,BDC,BDD,ELMBDA,F,IDIMF,
C                                     PERTRB,IERROR,W)
C
C ARGUMENTS
C ON INPUT               A,B
C                          THE RANGE OF R, I.E., A .LE. R .LE. B.
C                          A MUST BE LESS THAN B AND A MUST BE
C                          NON-NEGATIVE.
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (A,B) IS SUBDIVIDED.  HENCE,
C                          THERE WILL BE M+1 GRID POINTS IN THE
C                          R-DIRECTION GIVEN BY R(I) = A+(I-1)DR,
C                          FOR I = 1,2,...,M+1,
C                          WHERE DR = (B-A)/M IS THE PANEL WIDTH.
C                          M MUST BE GREATER THAN 3.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITION
C                          AT R = A AND R = B.
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               R = A AND R = B.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               R = A AND THE DERIVATIVE OF
C                               THE SOLUTION WITH RESPECT TO R IS
C                               SPECIFIED AT R = B.
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               R = A (SEE NOTE BELOW) AND R = B.
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               R = A (SEE NOTE BELOW) AND THE
C                               SOLUTION IS SPECIFIED AT R = B.
C                          = 5  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = A = 0 AND THE SOLUTION IS
C                               SPECIFIED AT R = B.
C                          = 6  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = A = 0 AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO R IS SPECIFIED
C                               AT R = B.
C
C                          NOTE:
C                          IF A = 0, DO NOT USE MBDCND = 3 OR 4, BUT
C                          INSTEAD USE MBDCND = 1,2,5, OR 6  .
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE OF
C                          THE SOLUTION WITH RESPECT TO R AT R = A.
C
C                          WHEN MBDCND = 3 OR 4,
C                            BDA(J) = (D/DR)U(A,THETA(J)),
C                            J = 1,2,...,N+1  .
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDA IS
C                          A DUMMY VARIABLE.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE OF
C                          THE SOLUTION WITH RESPECT TO R AT R = B.
C
C                          WHEN MBDCND = 2,3, OR 6,
C                            BDB(J) = (D/DR)U(B,THETA(J)),
C                            J = 1,2,...,N+1  .
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDB IS
C                          A DUMMY VARIABLE.
C
C                        C,D
C                          THE RANGE OF THETA, I.E., C .LE.
C                          THETA .LE. D.  C MUST BE LESS THAN D.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (C,D) IS SUBDIVIDED.  HENCE,
C                          THERE WILL BE N+1 GRID POINTS IN THE
C                          THETA-DIRECTION GIVEN BY
C                          THETA(J) = C+(J-1)DTHETA FOR
C                          J = 1,2,...,N+1, WHERE
C                          DTHETA = (D-C)/N IS THE PANEL WIDTH.
C                          N MUST BE GREATER THAN 3.
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT THETA = C AND AT THETA = D.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN THETA,
C                               I.E., U(I,J) = U(I,N+J).
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = C AND THETA = D
C                               (SEE NOTE BELOW).
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = C AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO THETA IS
C                               SPECIFIED AT THETA = D
C                               (SEE NOTE BELOW).
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               AT THETA = C AND THE SOLUTION IS
C                               SPECIFIED AT THETA = D
C                               (SEE NOTE BELOW).
C
C                          NOTE:
C                          WHEN NBDCND = 1,2, OR 4, DO NOT USE
C                          MBDCND = 5 OR 6
C                          (THE FORMER INDICATES THAT THE SOLUTION
C                          IS SPECIFIED AT R = 0, THE LATTER INDICATES
C                          THE SOLUTION IS UNSPECIFIED AT R = 0).
C                          USE INSTEAD MBDCND = 1 OR 2  .
C
C                        BDC
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO THETA AT
C                          THETA = C.  WHEN NBDCND = 3 OR 4,
C
C                            BDC(I) = (D/DTHETA)U(R(I),C),
C                            I = 1,2,...,M+1  .
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDC IS
C                          A DUMMY VARIABLE.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO THETA AT
C                          THETA = D.  WHEN NBDCND = 2 OR 3,
C
C                            BDD(I) = (D/DTHETA)U(R(I),D),
C                            I = 1,2,...,M+1  .
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDD IS
C                          A DUMMY VARIABLE.
C
C                        ELMBDA
C                          THE CONSTANT LAMBDA IN THE HELMHOLTZ
C                          EQUATION.  IF LAMBDA .LT. 0, A SOLUTION
C                          MAY NOT EXIST.  HOWEVER, HWSPLR WILL
C                          ATTEMPT TO FIND A SOLUTION.
C
C                        F
C                          A TWO-DIMENSIONAL ARRAY, OF DIMENSION AT
C                          LEAST (M+1)*(N+1), SPECIFYING VALUES
C                          OF THE RIGHT SIDE OF THE HELMHOLTZ
C                          EQUATION AND BOUNDARY DATA (IF ANY).
C
C                          ON THE INTERIOR, F IS DEFINED AS FOLLOWS:
C                          FOR I = 2,3,...,M AND J = 2,3,...,N
C                          F(I,J) = F(R(I),THETA(J)).
C
C                          ON THE BOUNDARIES F IS DEFINED AS FOLLOWS:
C                          FOR J = 1,2,...,N+1 AND I = 1,2,...,M+1
C
C                          MBDCND   F(1,J)            F(M+1,J)
C                          ------   -------------     -------------
C
C                            1      U(A,THETA(J))     U(B,THETA(J))
C                            2      U(A,THETA(J))     F(B,THETA(J))
C                            3      F(A,THETA(J))     F(B,THETA(J))
C                            4      F(A,THETA(J))     U(B,THETA(J))
C                            5      F(0,0)            U(B,THETA(J))
C                            6      F(0,0)            F(B,THETA(J))
C
C                          NBDCND   F(I,1)            F(I,N+1)
C                          ------   ---------         ---------
C
C                            0      F(R(I),C)         F(R(I),C)
C                            1      U(R(I),C)         U(R(I),D)
C                            2      U(R(I),C)         F(R(I),D)
C                            3      F(R(I),C)         F(R(I),D)
C                            4      F(R(I),C)         U(R(I),D)
C
C                          NOTE:
C                          IF THE TABLE CALLS FOR BOTH THE SOLUTION
C                          U AND THE RIGHT SIDE F AT A CORNER THEN
C                          THEN THE SOLUTION MUST BE SPECIFIED.
C
C                        IDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          F AS IT APPEARS IN THE PROGRAM CALLING
C                          HWSPLR.  THIS PARAMETER IS USED TO SPECIFY
C                          THE VARIABLE DIMENSION OF F.  IDIMF MUST
C                          BE AT LEAST M+1.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          W MAY REQUIRE UP TO 4*(N+1) +
C                          (13 + INT(LOG2(N+1)))*(M+1) LOCATIONS.
C                          THE ACTUAL NUMBER OF LOCATIONS USED IS
C                          COMPUTED BY HWSPLR AND IS RETURNED IN
C                          LOCATION W(I).
C
C
C ON OUTPUT              F
C                          CONTAINS THE SOLUTION U(I,J) OF THE FINITE
C                          DIFFERENCE APPROXIMATION FOR THE GRID POINT
C                          (R(I),THETA(J)),
C                          I = 1,2,...,M+1, J = 1,2,...,N+1  .
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC, DERIVATIVE,
C                          OR UNSPECIFIED BOUNDARY CONDITIONS IS
C                          SPECIFIED FOR A POISSON EQUATION
C                          (LAMBDA = 0), A SOLUTION MAY NOT EXIST.
C                          PERTRB IS A CONSTANT, CALCULATED AND
C                          SUBTRACTED FROM F, WHICH ENSURES THAT A
C                          SOLUTION EXISTS.  HWSPLR THEN COMPUTES
C                          THIS SOLUTION, WHICH IS A LEAST SQUARES
C                          SOLUTION TO THE ORIGINAL APPROXIMATION.
C                          THIS SOLUTION PLUS ANY CONSTANT IS ALSO
C                          A SOLUTION.  HENCE, THE SOLUTION IS NOT
C                          UNIQUE.  PERTRB SHOULD BE SMALL COMPARED
C                          TO THE RIGHT SIDE. OTHERWISE, A SOLUTION
C                          IS OBTAINED TO AN ESSENTIALLY DIFFERENT
C                          PROBLEM.  THIS COMPARISON SHOULD ALWAYS
C                          BE MADE TO INSURE THAT A MEANINGFUL
C                          SOLUTION HAS BEEN OBTAINED.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS.  EXCEPT FOR NUMBERS 0 AND 11,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          =  0  NO ERROR.
C                          =  1  A .LT. 0  .
C                          =  2  A .GE. B.
C                          =  3  MBDCND .LT. 1 OR MBDCND .GT. 6  .
C                          =  4  C .GE. D.
C                          =  5  N .LE. 3
C                          =  6  NBDCND .LT. 0 OR .GT. 4  .
C                          =  7  A = 0, MBDCND = 3 OR 4  .
C                          =  8  A .GT. 0, MBDCND .GE. 5  .
C                          =  9  MBDCND .GE. 5, NBDCND .NE. 0
C                                AND NBDCND .NE. 3  .
C                          = 10  IDIMF .LT. M+1  .
C                          = 11  LAMBDA .GT. 0  .
C                          = 12  M .LE. 3
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING
C                          A POSSIBLY INCORRECT CALL TO HWSPLR, THE
C                          USER SHOULD TEST IERROR AFTER THE CALL.
C
C                        W
C                          W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C SPECIAL CONDITIONS     NONE
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       GENBUN, GNBNAUX, AND COMF
C FILES                  FROM FISHPACK
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN THE LATE
C                        1970'S.  RELEASED ON NCAR'S PUBLIC SOFTWARE
C                        LIBRARIES IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              THE ROUTINE DEFINES THE FINITE DIFFERENCE
C                        EQUATIONS, INCORPORATES BOUNDARY DATA, AND
C                        ADJUSTS THE RIGHT SIDE OF SINGULAR SYSTEMS
C                        AND THEN CALLS GENBUN TO SOLVE THE SYSTEM.
C
C TIMING                 FOR LARGE  M AND N, THE OPERATION COUNT
C                        IS ROUGHLY PROPORTIONAL TO
C                          M*N*(LOG2(N)
C                        BUT ALSO DEPENDS ON INPUT PARAMETERS NBDCND
C                        AND MBDCND.
C
C ACCURACY               THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS
C                        OF NO MORE THAN THREE SIGNIFICANT DIGITS FOR N
C                        AND M AS LARGE AS 64.  MORE DETAILS ABOUT
C                        ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR
C                        SUBROUTINE GENBUN WHICH IS THE ROUTINE THAT
C                        SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C REFERENCES             SWARZTRAUBER,P. AND R. SWEET, "EFFICIENT
C                        FORTRAN SUBPROGRAMS FOR THE SOLUTION OF
C                        ELLIPTIC EQUATIONS"
C                          NCAR TN/IA-109, JULY, 1975, 138 PP.
C***********************************************************************
      DIMENSION       F(IDIMF,*)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
C
C     CHECK FOR INVALID PARAMETERS.
C
      IERROR = 0
      IF (A .LT. 0.) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 3) IERROR = 5
      IF (NBDCND.LE.-1 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4)) IERROR = 7
      IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8
      IF (MBDCND.GE.5 .AND. NBDCND.NE.0 .AND. NBDCND.NE.3) IERROR = 9
      IF (IDIMF .LT. M+1) IERROR = 10
      IF (M .LE. 3) IERROR = 12
      IF (IERROR .NE. 0) RETURN
      MP1 = M+1
      DELTAR = (B-A)/FLOAT(M)
      DLRBY2 = DELTAR/2.
      DLRSQ = DELTAR**2
      NP1 = N+1
      DELTHT = (D-C)/FLOAT(N)
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
C
C     DEFINE RANGE OF INDICES I AND J FOR UNKNOWNS U(I,J).
C
      MSTART = 2
      MSTOP = MP1
      GO TO (101,105,102,103,104,105),MBDCND
  101 MSTOP = M
      GO TO 105
  102 MSTART = 1
      GO TO 105
  103 MSTART = 1
  104 MSTOP = M
  105 MUNK = MSTOP-MSTART+1
      NSTART = 1
      NSTOP = N
      GO TO (109,106,107,108,109),NP
  106 NSTART = 2
      GO TO 109
  107 NSTART = 2
  108 NSTOP = NP1
  109 NUNK = NSTOP-NSTART+1
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      ID2 = MUNK
      ID3 = ID2+MUNK
      ID4 = ID3+MUNK
      ID5 = ID4+MUNK
      ID6 = ID5+MUNK
      A1 = 2./DLRSQ
      IJ = 0
      IF (MBDCND.EQ.3 .OR. MBDCND.EQ.4) IJ = 1
      DO 110 I=1,MUNK
         R = A+FLOAT(I-IJ)*DELTAR
         J = ID5+I
         W(J) = R
         J = ID6+I
         W(J) = 1./R**2
         W(I) = (R-DLRBY2)/(R*DLRSQ)
         J = ID3+I
         W(J) = (R+DLRBY2)/(R*DLRSQ)
         J = ID2+I
         W(J) = -A1+ELMBDA
  110 CONTINUE
      GO TO (114,111,112,113,114,111),MBDCND
  111 W(ID2) = A1
      GO TO 114
  112 W(ID2) = A1
  113 W(ID3+1) = A1
  114 CONTINUE
C
C     ENTER BOUNDARY DATA FOR R-BOUNDARIES.
C
      GO TO (115,115,117,117,119,119),MBDCND
  115 A1 = W(1)
      DO 116 J=NSTART,NSTOP
         F(2,J) = F(2,J)-A1*F(1,J)
  116 CONTINUE
      GO TO 119
  117 A1 = 2.*DELTAR*W(1)
      DO 118 J=NSTART,NSTOP
         F(1,J) = F(1,J)+A1*BDA(J)
  118 CONTINUE
  119 GO TO (120,122,122,120,120,122),MBDCND
  120 A1 = W(ID4)
      DO 121 J=NSTART,NSTOP
         F(M,J) = F(M,J)-A1*F(MP1,J)
  121 CONTINUE
      GO TO 124
  122 A1 = 2.*DELTAR*W(ID4)
      DO 123 J=NSTART,NSTOP
         F(MP1,J) = F(MP1,J)-A1*BDB(J)
  123 CONTINUE
C
C     ENTER BOUNDARY DATA FOR THETA-BOUNDARIES.
C
  124 A1 = 1./DLTHSQ
      L = ID5-MSTART+1
      LP = ID6-MSTART+1
      GO TO (134,125,125,127,127),NP
  125 DO 126 I=MSTART,MSTOP
         J = I+LP
         F(I,2) = F(I,2)-A1*W(J)*F(I,1)
  126 CONTINUE
      GO TO 129
  127 A1 = 2./DELTHT
      DO 128 I=MSTART,MSTOP
         J = I+LP
         F(I,1) = F(I,1)+A1*W(J)*BDC(I)
  128 CONTINUE
  129 A1 = 1./DLTHSQ
      GO TO (134,130,132,132,130),NP
  130 DO 131 I=MSTART,MSTOP
         J = I+LP
         F(I,N) = F(I,N)-A1*W(J)*F(I,NP1)
  131 CONTINUE
      GO TO 134
  132 A1 = 2./DELTHT
      DO 133 I=MSTART,MSTOP
         J = I+LP
         F(I,NP1) = F(I,NP1)-A1*W(J)*BDD(I)
  133 CONTINUE
  134 CONTINUE
C
C     ADJUST RIGHT SIDE OF EQUATION FOR UNKNOWN AT POLE WHEN HAVE
C     DERIVATIVE SPECIFIED BOUNDARY CONDITIONS.
C
      IF (MBDCND.GE.5 .AND. NBDCND.EQ.3)
     1    F(1,1) = F(1,1)-(BDD(2)-BDC(2))*4./(FLOAT(N)*DELTHT*DLRSQ)
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 144,136,135
  135 IERROR = 11
      GO TO 144
  136 IF (NBDCND.NE.0 .AND. NBDCND.NE.3) GO TO 144
      S2 = 0.
      GO TO (144,144,137,144,144,138),MBDCND
  137 W(ID5+1) = .5*(W(ID5+2)-DLRBY2)
      S2 = .25*DELTAR
  138 A2 = 2.
      IF (NBDCND .EQ. 0) A2 = 1.
      J = ID5+MUNK
      W(J) = .5*(W(J-1)+DLRBY2)
      S = 0.
      DO 140 I=MSTART,MSTOP
         S1 = 0.
         IJ = NSTART+1
         K = NSTOP-1
         DO 139 J=IJ,K
            S1 = S1+F(I,J)
  139    CONTINUE
         J = I+L
         S = S+(A2*S1+F(I,NSTART)+F(I,NSTOP))*W(J)
  140 CONTINUE
      S2 = FLOAT(M)*A+DELTAR*(FLOAT((M-1)*(M+1))*.5+.25)+S2
      S1 = (2.+A2*FLOAT(NUNK-2))*S2
      IF (MBDCND .EQ. 3) GO TO 141
      S2 = FLOAT(N)*A2*DELTAR/8.
      S = S+F(1,1)*S2
      S1 = S1+S2
  141 CONTINUE
      PERTRB = S/S1
      DO 143 I=MSTART,MSTOP
         DO 142 J=NSTART,NSTOP
            F(I,J) = F(I,J)-PERTRB
  142    CONTINUE
  143 CONTINUE
  144 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY (R(I)*DELTHT)**2.
C
      DO 146 I=MSTART,MSTOP
         K = I-MSTART+1
         J = I+LP
         A1 = DLTHSQ/W(J)
         W(K) = A1*W(K)
         J = ID2+K
         W(J) = A1*W(J)
         J = ID3+K
         W(J) = A1*W(J)
         DO 145 J=NSTART,NSTOP
            F(I,J) = A1*F(I,J)
  145    CONTINUE
  146 CONTINUE
      W(1) = 0.
      W(ID4) = 0.
C
C     CALL GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      CALL GENBUN (NBDCND,NUNK,1,MUNK,W(1),W(ID2+1),W(ID3+1),IDIMF,
     1             F(MSTART,NSTART),IERR1,W(ID4+1))
      IWSTOR = W(ID4+1)+3.*FLOAT(MUNK)
      GO TO (157,157,157,157,148,147),MBDCND
C
C     ADJUST THE SOLUTION AS NECESSARY FOR THE PROBLEMS WHERE A = 0.
C
  147 IF (ELMBDA .NE. 0.) GO TO 148
      YPOLE = 0.
      GO TO 155
  148 CONTINUE
      J = ID5+MUNK
      W(J) = W(ID2)/W(ID3)
      DO 149 IP=3,MUNK
         I = MUNK-IP+2
         J = ID5+I
         LP = ID2+I
         K = ID3+I
         W(J) = W(I)/(W(LP)-W(K)*W(J+1))
  149 CONTINUE
      W(ID5+1) = -.5*DLTHSQ/(W(ID2+1)-W(ID3+1)*W(ID5+2))
      DO 150 I=2,MUNK
         J = ID5+I
         W(J) = -W(J)*W(J-1)
  150 CONTINUE
      S = 0.
      DO 151 J=NSTART,NSTOP
         S = S+F(2,J)
  151 CONTINUE
      A2 = NUNK
      IF (NBDCND .EQ. 0) GO TO 152
      S = S-.5*(F(2,NSTART)+F(2,NSTOP))
      A2 = A2-1.
  152 YPOLE = (.25*DLRSQ*F(1,1)-S/A2)/(W(ID5+1)-1.+ELMBDA*DLRSQ*.25)
      DO 154 I=MSTART,MSTOP
         K = L+I
         DO 153 J=NSTART,NSTOP
            F(I,J) = F(I,J)+YPOLE*W(K)
  153    CONTINUE
  154 CONTINUE
  155 DO 156 J=1,NP1
         F(1,J) = YPOLE
  156 CONTINUE
  157 CONTINUE
      IF (NBDCND .NE. 0) GO TO 159
      DO 158 I=MSTART,MSTOP
         F(I,NP1) = F(I,1)
  158 CONTINUE
  159 CONTINUE
      W(1) = IWSTOR
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


!> @brief
!> Module for Splines
!> @details
!> basic functions and routines for B-Splines
!> in 1D, 2D and 3D
!>
!> This file contains two modules
!> BSPLINE : basic functions and routines
!> BSP     : specific implementations for 1D,2D,3D
!> Externaly, the user should call BSP

module spl_m_pppack
implicit none
contains
include "interv.f90"
include "bsplpp.f90"
include "bsplvb.f90"
include "ppvalu.f90"

! .......................................................
!> @brief     Determine non zero elements
!>
!> @param[in] n number of control points  - 1
!> @param[in] p spline degree
!> @param[in] U Knot vector
!> @param[in] n_elements number of non-zero elements
!> @param[in] grid the corresponding grid
! .......................................................

end module spl_m_pppack


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! INPUT & OUTPUT:
! n_atoms:                    int
! atom_type:                  int (n_atoms)
! atom_coords:                real(n_atoms, 3)
! cutoff:                     real
! allow_neighbor_limit:       int, e.g. 80
! n_neighbor_limit:           int, e.g. 50
! small_face_thres:           real e.g. 0.05
! pbc:                        int(3), e.g. [1, 1, 1]
! bds:                        real(3, 2)
!
! n_neighbor_list:            int (n_atoms),
! neighbor_lists:             int (n_atoms, n_neighbor_limit)
! neighbor_area_lists:        real(n_atoms, n_neighbor_limit)
! neighbor_vol_lists:         real(n_atoms, n_neighbor_limit)
! neighbor_distance_lists:    real(n_atoms, n_neighbor_limit)
! neighbor_edge_lists:        int (n_atoms, n_neighbor_limit)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine determinant(face, deter_value)
    REAL(16), dimension(3, 3), intent(in) :: face
    REAL(16), intent(out) :: deter_value
    deter_value=(face(1,1)*face(2,2)*face(3,3)+face(1,2)*face(2,3)*face(3,1)&
            +face(1,3)*face(2,1)*face(3,2)&
            -face(3,1)*face(2,2)*face(1,3)-face(2,1)*face(1,2)*face(3,3)&
            -face(1,1)*face(3,2)*face(2,3))
    return
END subroutine determinant

subroutine voronoi(n_atoms, atom_type, atom_coords, cutoff, allow_neighbor_limit, &
    n_neighbor_limit, small_face_thres, pbc, bds, &
    n_neighbor_list, neighbor_lists, &
    neighbor_area_lists, neighbor_vol_lists, neighbor_distance_lists, neighbor_edge_lists, &
    print_freq)

    use :: distance

    integer :: n_atoms, allow_neighbor_limit, n_neighbor_limit
    REAL(8) :: cutoff, small_face_thres
    integer, dimension(3) :: pbc
    REAL(8), dimension(3, 2) :: bds
    integer, dimension(n_atoms):: atom_type, n_neighbor_list
    REAL(8), dimension(n_atoms, 3):: atom_coords
    integer, dimension(n_atoms, n_neighbor_limit):: neighbor_lists, neighbor_edge_lists
    REAL(8), dimension(n_atoms, n_neighbor_limit):: neighbor_area_lists
    REAL(8), dimension(n_atoms, n_neighbor_limit):: neighbor_vol_lists
    REAL(8), dimension(n_atoms, n_neighbor_limit):: neighbor_distance_lists
    integer :: print_freq

!f2py   intent(in) n_atoms, atom_type, atom_coords, cutoff, small_face_thres
!f2py   intent(in) allow_neighbor_limit, n_neighbor_limit, pbc, bds, print_freq
!f2py   intent(in, out) n_neighbor_list
!f2py   intent(in, out) neighbor_lists, neighbor_edge_lists
!f2py   intent(in, out) neighbor_area_lists, neighbor_vol_lists, neighbor_distance_lists
!f2py   intent(in) print_freq

    integer :: atom, i, j, l, k, s, possible_n_neighbor, CN_test
    integer, dimension(allow_neighbor_limit) :: bool, possible_neighbor_list, vertex_face
    integer, dimension(allow_neighbor_limit, allow_neighbor_limit) :: facetvoro
    REAL(8) :: d, d_temp, vertex(allow_neighbor_limit, 3)
    REAL(16) :: deter_value1, deter_value2, deter_value
    REAL(8) :: area_sum
    REAL(8), dimension(3) :: r, vv, a, vertex_x
    REAL(8), dimension(3,3) :: v
    REAL(16), dimension(3,3) :: face, face_2
    REAL(16), dimension(n_neighbor_limit):: neighbor_area_list_with_small
    REAL(16), dimension(n_neighbor_limit):: neighbor_vol_list_with_small
    integer, dimension(n_atoms) :: n_vertex_list
    integer, dimension(n_neighbor_limit, 3) :: vertex_info

    do atom = 1, n_atoms
      if (atom == 1) then
        write(*, *) "start voronoi nn"
      else if (mod(atom, print_freq) == 0) then
        write(*, *) "voronoi nn: atom", atom
      end if

      vertex = 0
      vertex_info = 0
      facetvoro = 0
      bool = 0
      possible_n_neighbor=0
      possible_neighbor_list = 0
      neighbor_area_list_with_small = 0
      neighbor_vol_list_with_small = 0
      vertex_face = 0
      do i = 1, n_atoms
        call distance_info(atom_coords(atom, :), atom_coords(i, :), bds, pbc, r, d)
!        write(*,*) r, d
        if((i /= atom).and.(d < cutoff)) then
          possible_n_neighbor = possible_n_neighbor + 1
          possible_neighbor_list(possible_n_neighbor) = i
        end if
      end do
!      write(*,*) possible_n_neighbor
!      write(*,*) possible_neighbor_list
      if(possible_n_neighbor > allow_neighbor_limit)    then
        write(*,*) "possible_n_neighbor OUT of allow_neighbor_limit"
      end if

      n_vertex_list(atom) = 0

      do i = 1, possible_n_neighbor
        call distance_info(atom_coords(atom, :), atom_coords(possible_neighbor_list(i), :), bds, pbc, r, d)
!        write(*, *) r
        v(1, :) = r(:)
        do j = i+1,possible_n_neighbor
          call distance_info(atom_coords(atom, :), atom_coords(possible_neighbor_list(j), :), bds, pbc, r, d)
          v(2, :) = r(:)
          do k = j+1,possible_n_neighbor
            call distance_info(atom_coords(atom, :), atom_coords(possible_neighbor_list(k), :), bds, pbc, r, d)
            v(3, :) = r(:)

            vv = 0
            do m = 1, 3
              do n = 1, 3
                vv(m) = vv(m) + v(m,n)*v(m,n)  !sum of |v|^2
              end do
            end do
!            write(*, *) vv

            do m = 1, 3
              do n = 1, 3
                face(m,n) = 2.0 * v(m,n) / vv(m)    !reciprocal space?
              end do
            end do

            face_2 = face
            do m = 1, 3
              face_2(m, 1)=1.0                      !set x = 1
            end do

            call determinant(face_2(1:3,1:3), deter_value1)
            call determinant(face(1:3,1:3), deter_value2)
!            deter_value1 = determinant(face_2(1:3,1:3))
!            deter_value2 = determinant(face(1:3,1:3))
            vertex_x(1)=deter_value1/deter_value2

            face_2 = face
            do m = 1, 3
              face_2(m, 2)=1.0                      !set y = 1
            end do

            call determinant(face_2(1:3,1:3), deter_value1)

!            deter_value1 = determinant(face_2(1:3,1:3))
!            deter_value2 = determinant(face(1:3,1:3))
            vertex_x(2)=deter_value1/deter_value2

            face_2 = face
            do m = 1, 3
              face_2(m, 3)=1.0                      !set y = 1
            end do

            call determinant(face_2(1:3,1:3), deter_value1)

!            deter_value1 = determinant(face_2(1:3, 1:3))
!            deter_value2 = determinant(face(1:3, 1:3))
            vertex_x(3)=deter_value1/deter_value2

            l=0
            s=0
            do l = 1, possible_n_neighbor
              call distance_info(atom_coords(atom, :), atom_coords(possible_neighbor_list(l), :), bds, pbc, r, d_temp)
              a(:) = vertex_x(:) * r(:) / d_temp**2
!              write(*,*) vertex_x, r, a

              !if found the fourth possible_neighbor_list, set s=1 and skip the following iteration
              if((a(1) + a(2) + a(3)) > 0.5000001D0) then
                s = 1
                exit
              end if
            end do

            if(s == 0) then
              bool(i) = 1
              bool(j) = 1
              bool(k) = 1
              n_vertex_list(atom) = n_vertex_list(atom) + 1
              vertex(n_vertex_list(atom), :) = vertex_x(:)
              vertex_info(n_vertex_list(atom), 1) = i
              vertex_info(n_vertex_list(atom), 2) = j
              vertex_info(n_vertex_list(atom), 3) = k
            end if

          end do
        end do
      end do
      ! calculate the area and vol of each part of the Voronoi polyhedra(cluster)
      !! start of i-iteration
      j=0
      k=0
      s=0
      n_neighbor_list(atom)=0
      area_sum = 0
      CN_test = 0

      do i = 1, possible_n_neighbor
        if (bool(i) == 1) then
          CN_test = CN_test + 1
!          write(*,*) CN_test
          k = 0
          do l = 1, n_vertex_list(atom)
            if ((vertex_info(l, 1) == i) .or. (vertex_info(l, 2) == i) .or. (vertex_info(l, 3) == i)) then
              k = k + 1
              facetvoro(i, k) = l        ! the edge number of atom-i is k

              exit
            end if
          end do

          j = l
          l = 1
!          write(*,*) 'j', j
!            write(*,*) 'k', k
!            write(*,*) 'vertex_info is ', vertex_info
          do while(l <= n_vertex_list(atom))

            if (((vertex_info(l,1) == i &
              .and.((vertex_info(l,2) == vertex_info(j,1)) &
              .or.(vertex_info(l,2) == vertex_info(j,2)) &
              .or.(vertex_info(l,2) == vertex_info(j,3)) &
              .or.(vertex_info(l,3) == vertex_info(j,1)) &
              .or.(vertex_info(l,3) == vertex_info(j,2)) &
              .or.(vertex_info(l,3) == vertex_info(j,3)))) &
             .or.(vertex_info(l,2) == i &
              .and.((vertex_info(l,1) == vertex_info(j,1)) &
              .or.(vertex_info(l,1) == vertex_info(j,2)) &
              .or.(vertex_info(l,1) == vertex_info(j,3)) &
              .or.(vertex_info(l,3) == vertex_info(j,1)) &
              .or.(vertex_info(l,3) == vertex_info(j,2)) &
              .or.(vertex_info(l,3) == vertex_info(j,3)))) &
             .or.(vertex_info(l,3) == i &
              .and.((vertex_info(l,1) == vertex_info(j,1)) &
              .or.(vertex_info(l,1) == vertex_info(j,2)) &
              .or.(vertex_info(l,1) == vertex_info(j,3)) &
              .or.(vertex_info(l,2) == vertex_info(j,1)) &
              .or.(vertex_info(l,2) == vertex_info(j,2)) &
              .or.(vertex_info(l,2) == vertex_info(j,3))))) &
             .and.(l /= facetvoro(i, 1)) &
             .and.(l /= facetvoro(i, k + 1*merge(-1, 0, k /= 1))) &
             .and.(l /= j)) then
!                write(*, *) 'l', l
              k = k + 1
!              if(k > (n_atoms)) then
              if(k > (allow_neighbor_limit)) then

                exit
              end if
              facetvoro(i, k) = l
!              write(*, *) 'goto 200'
              j = l
              l = 0
            end if
            l = l + 1
          end do
          vertex_face(i)=k

          neighbor_vol_list_with_small(i) = 0
          do l = 2, k - 1
            face_2(1, :) = vertex(facetvoro(i, 1), :)
            do m = 2, 3
              face_2(m, :)=vertex(facetvoro(i, l + m-2), :)
            end do

            call determinant(face_2(1:3, 1:3), deter_value)
!            deter_value = determinant(face_2(1:3, 1:3))
            neighbor_vol_list_with_small(i) = neighbor_vol_list_with_small(i) + abs(deter_value/6.0)
!            write(*, *) 'neighbor_vol_list_with_small', neighbor_vol_list_with_small(i)
          end do

          call distance_info(atom_coords(atom, :), atom_coords(possible_neighbor_list(i), :), bds, pbc, r, d)
          neighbor_area_list_with_small(i) = 6.0 * neighbor_vol_list_with_small(i)/d
          area_sum = area_sum + neighbor_area_list_with_small(i)
        end if
      end do

      if (small_face_thres > 0.0) then
        s = 0
        do i = 1, possible_n_neighbor
          if (bool(i) == 1) then
            if (neighbor_area_list_with_small(i) < small_face_thres * area_sum / CN_test) then  !5% percent
              bool(i) = 0
              CN_test = CN_test - 1
            else
!              write(*,*) "atom is : ", atom
!              write(*,*) n_neighbor_list(atom)

              s = s + 1;
              n_neighbor_list(atom) = n_neighbor_list(atom) + 1
              neighbor_lists(atom, s) = possible_neighbor_list(i)
              neighbor_area_lists(atom, s) = neighbor_area_list_with_small(i)
              neighbor_vol_lists(atom, s) = neighbor_vol_list_with_small(i)
              neighbor_edge_lists(atom, s) = vertex_face(i)
              call distance_info(atom_coords(atom, :), atom_coords(possible_neighbor_list(i), :), bds, pbc, r, d)
              neighbor_distance_lists(atom, s) = d
            end if
          end if
        end do
!        write(*,*) "atom is : ", atom
!        write(*,*) "__________________________"
!        write(*,*) n_neighbor_list(atom)
!        write(*,*) "__________________________"
!        write(*,*) neighbor_lists(atom, :)
!        write(*,*) "__________________________"
!        write(*,*) neighbor_area_lists(atom, :)
!        write(*,*) "__________________________"
!        write(*,*) neighbor_vol_lists(atom, :)
!        write(*,*) "__________________________"
!        write(*,*) neighbor_edge_lists(atom, :)
!        write(*,*) "__________________________"
      end if

!      if (n_neighbor_list(atom) > n_neighbor_max) then
!        n_neighbor_max = n_neighbor_list(atom)
!      end if
!
!      do m = 1, n_neighbor_list(atom)
!        if (neighbor_edge_lists(atom, m) > n_neighbor_max) then
!          n_edge_max = neighbor_edge_lists(atom, m)
!        end if
!      end do

    end do
    write(*, *) "finish voronoi nn for atoms: ", n_atoms
end subroutine voronoi


! The Computer Language Benchmarks Game
! http://shootout.alioth.debian.org/
!
! Contributed by Jason Blevins
! Adapted from Fortran versions by George R. Gonzalez and Simon Geard
!
! ifort -fast -openmp -o mandelbrot mandelbrot.f90
program mandelbrot
  implicit none

  integer, parameter :: dp = selected_real_kind(15, 307)
  integer, parameter :: int8 = selected_int_kind(2)
  integer, parameter :: iter = 50
  real(dp), parameter :: limit2 = 4.0_dp
  character(len=8) :: argv
  integer :: n, x, y, i, pos, bit_num
  integer(int8) :: byte
  real(dp) :: inv_2n, Zi, Zr, Ti, Tr, Cr, Ci
  integer(int8), dimension(:,:), allocatable :: buf

  ! read dimension from command line
  call get_command_argument(1, argv)
  read(argv, *) n

  ! allocate output buffer
  allocate(buf(ceiling(n / 8.0_dp), n))

  ! precalculate constants
  inv_2n = 2.0_dp / n

  ! pbm header
  write(*,'("P4",/,i0," ",i0)') n, n

  !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(n, inv_2n, buf)
  do y = 0, n - 1
     bit_num = 8 ! when moving left to right, bits are numbered 7 to 0
     byte = 0_int8
     pos = 0
     Ci = inv_2n * y - 1.0_dp
     do x = 0, n - 1
        bit_num = bit_num - 1

        Zr = 0.0_dp
        Zi = 0.0_dp
        Tr = 0.0_dp
        Ti = 0.0_dp

        Cr = inv_2n * x - 1.5_dp
        do i = 1, iter
           Zi = 2.0 * Zr * Zi + Ci
           Zr = Tr - Ti + Cr
           Ti = Zi * Zi
           Tr = Zr * Zr
           if (Tr + Ti > limit2) then
              exit
           end if
        end do

        ! We're in the set, set this bit to 0
        if (i > iter) byte = ibset(byte, bit_num)

        if (bit_num == 0 .or. x == n - 1) then
           ! All bits set or end of row, so store full byte
           pos = pos + 1
           buf(pos, y + 1) = byte
           byte = 0_int8
           bit_num = 8
        end if
     end do
  end do
  !$OMP END PARALLEL DO

  ! print output
  do y = 1, n
     write(*, '(10000000a1)', advance='no') buf(:, y)
  end do
  deallocate(buf)
end program mandelbrot


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pair_separate( n, c1, gg1, c2, gg2, qual, max_it, xh, v, intersect )

!  Determine if two non-concentric ellipsoids, E1 and E2, intersect.
!  If they do not intersect, determine a separating hyperplane.
!  If they do intersect, determine the hyperplane which is the
!     perpendicular bisector of the line of centers.

!  E1 is defined by:  (x-c1)^T * G1 * G1^T * (x-c1) <= 1.  The array
!  gg1 contains the lower triangular n x n matrix G1 in packed format.
!  Similarly for E2.

!  The hyperplane is defined by v^T * ( x - xh  ) = 0, where v is
!  a unit vector.  The quantity s(x) = v^T * ( x - xh  ) is the signed
!  distance of the point x from the hyperplane: s(c1) is negative, and
!  s(c2) is positive.  If E1 and E2 do not intersect, then s(x) is negative
!  for all points x in E1, and positive for all points x in E2.

!  Method:
!
!Phase I
!  1/ transform to y-space in which E1 is the unit ball: y = G1^T * ( x - c1 )
!  2/ find the point y2 in E2 that is closest to the origin
!  3/ if |y2| <= 1, then E1 and E2 intersect; otherwise...
!  4/ define y1 = y2/|y2|;  yh = (y1+y2)/2;  vy = y2-y1; then vy^T * ( y - yh )
!     is a separating hyperplane
!  5/ transform back to x-space to obtain xh and v (and x1 and x2)
!  6/ all done if qual <=0 or max_it <=0
!
!Phase II
!  The objective of phase II is to improve the quality of the separating hyperplane.
!  The quality q ( q <= 1 ) is defined by:
!     q= (distance between supporting hyperplanes)/|x1-x2|.
!  Starting from the value of x2 obtained in phase I, iterations are performed to:
!  7/ determine the point x1 in E1 closest to x2
!  8/ determine the point x2 in E2 closest to x1
!  9/ xh = (x1+x2)/2;  v = (x2-x1)/|x2-x1|
!  These operations (7-9) are performed iteratively until q >= qual, or the number
!  of iterations exceeds max_it.  The values of xh and v returned correspond to the
!  hyperplane of greatest separation encountered during (or before) the iterations
!  (which usually occurs on the final iteration).
!
!  Notes:
!  1/ For 7 and 8, the same algorithm is used as in ell_pt_near_far, but there are
!     efficiency gains in re-coding it here.
!  2/ A quadratic programming routine could be used to solve the whole problem.
!  3/ Convergence is slow if E1 and E2 nearly intersect; but then the separating
!     hyperplane obtained from phase I may be adequate.
!  4/ Aitken extrapolation could be used to speed up convergence.

!  S.B. Pope  6/13/04, 12/28/04

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n, max_it
real(k_dp), intent(in)  :: c1(n), gg1((n*(n+1))/2), c2(n), gg2((n*(n+1))/2), qual
real(k_dp), intent(out) :: xh(n), v(n)
logical, intent(out)    :: intersect

integer    :: itmax = 100  !  max. iterations in dgqt
integer    :: lu_diag = -1 !  logical unit for diagnostics (set < 0 to suppress)
real(k_dp) :: atol = 1.d-6, rtol = 1.d-6  !  tolerances for dgqt

integer    :: info, i, j, k, iter
real(k_dp) :: g1(n,n), g2(n,n), c2y(n), y2(n), y2norm, x1(n), x2(n), g2y(n,n), &
              dist, smin1, smax1, smin2, smax2, q, qual_tol, sep, sep_max, &
			  v_best(n), xh_best(n), gi(n,n), delta, par1, par2, f, &
              a1(n,n), a2(n,n), b(n), z(n), wa1(n), wa2(n)

! unpack gg1 and gg2  -----------------------------------------------------------
k  = 0
g1 = 0.d0
g2 = 0.d0
do j = 1, n
   do i = j, n
      k = k + 1
	  g1(i,j) = gg1(k)
	  g2(i,j) = gg2(k)
   end do
end do

! transform to y-space:  y = G1^T * (x-c1);  G2y = G1^{-1} * G2
g2y = g2
call dtrsm( 'L', 'L', 'N', 'N', n, n, 1.d0, g1, n, g2y, n )

c2y = c2 - c1  !  c2y = G1^T * ( c2 - c1 )
call dtrmv( 'L', 'T', 'N', n, g1, n, c2y, 1 )

!  find point y2 in E2 closest to the origin
v = 0.d0  ! origin
call ellu_pt_near_far( 1, n, c2y, g2y, v, y2 )

y2norm = sum( y2*y2 )  !  if y2 in unit ball then E1 and E2 intersect

if( y2norm <= 1.d0 ) then
   intersect = .true.           ! E1 and E2 intersect: all done
   xh   = 0.5d0 * (c1 + c2)     ! mid-point between centers
   v    = c2 - c1
   dist = sum( v*v )
   if( dist > 0.d0 ) then
      v = v / sqrt( dist )      ! unit vector from c1 to c2
   else
      v = 0.d0                  ! E1 and E2 are concentric
	  v(1) = 1.d0               ! set v = e_1
   endif

   return
endif

intersect = .false.

!  hyperplane in y-space is:  vy^T * ( y - yh ) = 0
y2norm = sqrt( y2norm )
v      = y2

!  transform back to x-space
call dtrsv( 'L', 'T', 'N', n, g1, n, y2, 1 )
x2 = y2        + c1  ! x2 = G1^{-T} * y2 + c1
x1 = y2/y2norm + c1
xh = 0.5d0 * ( x1 + x2 )

call dtrmv( 'L', 'N', 'N', n, g1, n, v, 1 )  ! v = G1 * vy
v     = v / sqrt( sum(v*v) )  !  make unit vector

!-----------  end of phase I  -------------------------------------------

if( max_it <=0  .or.  qual <= 0.d0 ) then
   return  !  accept existing separating hyperplane
else
   qual_tol = min( qual, 1.d0-1.d-6 )  !  qual must be less than unity
endif

!---  form matrices A1 and A2 used in minimization ----

gi = g1  !  start formation of a1
call dtrtri( 'L', 'N', n, gi, n, info )  !  gi = G1^{-1}

a1 = 0.d0  !  a1 = lower triangle of gi
do j = 1, n
   a1(j:n,j) = gi(j:n,j)
end do

call dtrmm ( 'R', 'L', 'T', 'N', n, n, 1.d0, gi, n, a1, n )  ! a1 =  = G1^{-1} * G1^{-T}

gi = g2  !  start formation of a2
call dtrtri( 'L', 'N', n, gi, n, info )  !  gi = G2^{-1}

a2 = 0.d0  !  a2 = lower triangle of gi
do j = 1, n
    a2(j:n,j) = gi(j:n,j)
end do

call dtrmm ( 'R', 'L', 'T', 'N', n, n, 1.d0, gi, n, a2, n )  ! a2 =  = G2^{-1} * G2^{-T}

!---  initialization prior to iteration
par1  = 0.d0
par2  = 0.d0
delta = 1.d0

v_best  = v
xh_best = xh

call ell_line_proj( n, c1, gg1, xh, v, smin1, smax1 )
call ell_line_proj( n, c2, gg2, xh, v, smin2, smax2 )
sep_max = smin2 - smax1  !  distance between supporting hyperplanes

do iter = 1, max_it  !------------------  iterations  --------------------------

!  determine point x1 in E1 closest to x2 ----------
   b = c1 - x2
   call dtrsv( 'L', 'N', 'N', n, g1, n, b, 1 )  !  b = G1^{-1} * [c1-x2]

   call dgqt(n,a1,n,b,delta,rtol,atol,itmax,par1,f,x1,info,z,wa1,wa2)

   if( info >= 3 ) then
      write(0,*)'ell_pair_separate: dgqt incomplete convergence, info = ', info
   endif

   call dtrsv( 'L', 'T', 'N', n, g1, n, x1, 1 )  !  x1 = G1^{-T} * y1 + c1
   x1 = x1 + c1

!  determine point x2 in E2 closest to x1 ----------

   b = c2 - x1
   call dtrsv( 'L', 'N', 'N', n, g2, n, b, 1 )  !  b = G2^{-1} * [c2-x1]

   call dgqt(n,a2,n,b,delta,rtol,atol,itmax,par2,f,x2,info,z,wa1,wa2)

   if( info >= 3 ) then
      write(0,*)'ell_pair_separate: dgqt incomplete convergence, info = ', info
   endif

   call dtrsv( 'L', 'T', 'N', n, g2, n, x2, 1 )  !  x2 = G2^{-T} * y2 + c2
   x2 = x2 + c2

!  determine hyperplane, dist=distance(x1,x2), sep=separation distance between
!  supporting hyperplanes, and q = quality = sep/dist         -------------

   v    = x2 - x1
   dist = sqrt( sum( v*v ) )  !  distance between "close" points
   v    = v / dist            !  unit vector from x1 to x2
   xh   = 0.5d0 * ( x1 + x2 ) !  mid-point between x1 and x2

   call ell_line_proj( n, c1, gg1, xh, v, smin1, smax1 )
   call ell_line_proj( n, c2, gg2, xh, v, smin2, smax2 )

   sep = smin2 - smax1  !  distance between supporting hyperplanes
   q   = sep / dist     !  quality of separating hyperplane

   if( lu_diag >= 0 ) write(lu_diag,'(a,i4,1p,10e13.4)')  &
      'iter, sep, dist, q = ', iter, sep, dist, q

   if( sep > sep_max ) then
      sep_max = sep  !  store xh and v with largest separation
	  xh_best = xh
	  v_best  = v
   endif

   if( q >= qual_tol ) exit

end do

xh = xh_best  !  return xh and v with largest separation
v  =  v_best

return
end subroutine ell_pair_separate


!{ dg-run }
!{ dg-options "-fno-range-check" }
! PR19310 and PR19904, allow disabling range check during compile.
! Contributed by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
program main
  real, parameter :: zero=0, nan=0/zero
  complex :: z = (-0.1,-2.2)/(0.0,0.0)
  complex :: z2 = (0.1,1)/0
  complex :: z3 = (1e300, -2e-200)/1234e-325
  complex :: z4 = (1e-300, -2e-200)/1234e325
  real :: a
  a = exp(1000.0)
  b = 1/exp(1000.0)
  print *, a
  print *, b
  print *, -1.0/b
  print *, b/0.0
  print *, 0.0/0.0
  print *, 1.0/-0.0
  print *, -2.0/0.0
  print *, 3.0/0.0
  print *, nan
  print *, z
  print *, z2
  print *, z3
  print *, z4

end program main
!{dg-output "      +Infinity"
!{dg-output "   0.000000"
!{dg-output "      -Infinity"
!{dg-output "            NaN"
!{dg-output "            NaN"
!{dg-output "      -Infinity"
!{dg-output "      -Infinity"
!{dg-output "      +Infinity"
!{dg-output "            NaN"
!{dg-output " (           NaN,           NaN)"
!{dg-output " (           NaN,           NaN)"
!{dg-output " (     +Infinity,     -Infinity)"
!{dg-output " (  0.000000    ,  0.000000    )"


      subroutine setprob()
      implicit none

      double precision pi
      common /compi/ pi

      pi = 4.d0*atan(1.d0)

      end


SUBROUTINE phi_nonlinear(k,x,z,omega,time,n_four_modes,zz,phix,phiz,phi,phit)
!
USE PRECISION
USE Constants
IMPLICIT NONE
INTEGER :: n_four_modes
REAL(KIND=long), INTENT(IN)  :: k,x,z,omega,time,zz(2*n_four_modes+10) ! GD: change zz(*)
REAL(KIND=long), INTENT(OUT) :: phix,phiz
REAL(KIND=long), INTENT(OUT), OPTIONAL :: phi,phit
   ! Local variables
REAL(KIND=long) :: kx, km, sinkmkx, sinhzh, temp1, e, b, e_inv, dir
INTEGER    :: m
!
dir = omega/ABS(omega) !direction of the wavefield
kx=k*x-omega*time
!
phix = zero
phiz = zero
IF(present(phit)) phit = zero
IF(present(phi))  phi  = zero
!
! FIXME: optimization of loops (remove tests inside?)
DO m=1,n_four_modes
   km=DBLE(m)
   sinkmkx = SIN(km*kx)
   e=EXP(km*(zz(1)+z))
   temp1=zz(n_four_modes+m+10)*half/COSH(km*zz(1))
   e_inv=one/e
   b=(e+e_inv)*temp1
   sinhzh=km*(e-e_inv)*temp1
   phiz=phiz+sinhzh*sinkmkx
   !
   temp1=b*km*COS(km*kx)
   phix=phix+temp1
   IF(present(phit)) phit=phit-omega*temp1
   IF(present(phi))  phi=phi+b*sinkmkx
ENDDO
!
phiz= dir*phiz
phix= dir*(phix + zz(5))

IF(present(phi))  phi = dir*(phi + kx*zz(5)) !it's k*x-omega*time      !check the time dependence...
IF(present(phit)) phit= dir*(phit)+(-zz(9)+zz(4)**2/2.d0)-dir*omega*zz(5) !check the time dependence...

END SUBROUTINE phi_nonlinear


  !> Test for ordinary differentiation
Program example_1
  use Mirana
  implicit none
  integer, parameter :: n1 = 1000, n2 = 500
  integer :: st1 = -500, st2 = -250
  double precision, parameter :: L = 2.0
  double precision :: h1,h2,x,y,e1,e2,e1h1,e1h2,e2h1,e2h2,e11,e22,e12,elp
  integer :: i,j,ed1,ed2
  double precision, dimension(:,:),allocatable :: p, px, py, pxh1, pxh2, pyh1, pyh2, ppxx, ppyy, ppxy, pl
  ed1 = st1 + n1 - 1
  ed2 = st2 + n2 - 1
  allocate(p(st1:ed1,st2:ed2))
  allocate(px(st1:ed1,st2:ed2))
  allocate(pxh1(st1:ed1,st2:ed2))
  allocate(pxh2(st1:ed1,st2:ed2))
  allocate(py(st1:ed1,st2:ed2))
  allocate(pyh1(st1:ed1,st2:ed2))
  allocate(pyh2(st1:ed1,st2:ed2))
  allocate(ppxx(st1:ed1,st2:ed2))
  allocate(ppyy(st1:ed1,st2:ed2))
  allocate(ppxy(st1:ed1,st2:ed2))
  allocate(pl(st1:ed1,st2:ed2))
  write(*,*) 'Hello, this is example_1, testing for ordinary differentiation'
  h1 = L / n1
  h2 = L / n2
  do i = st1,ed1
     do j = st2,ed2
        x = h1 * i
        y = h2 * j
        p(i,j) = sin(2*x)*cos(3*y)
     end do
  end do

  call d1(p, h1, st1, st2, px)
  call d2(p, h2, st1, st2, py)
  call d1h1(p, h1, st1, st2, pxh1)
  call d1h2(p, h1, st1, st2, pxh2)
  call d2h2(p, h2, st1, st2, pyh2)
  call d2h1(p, h2, st1, st2, pyh1)
  call d12(p, h1, h2, st1, st2, ppxy)
  call d11(p, h1, st1, st2, ppxx)
  call d22(p, h2, st1, st2, ppyy)
  call dlp(p, h1, h2, st1, st2, pl)

  e1 = 0
  e2 = 0
  e1h1 = 0
  e1h2 = 0
  e2h1 = 0
  e2h2 = 0
  e11 = 0
  e12 = 0
  e22 = 0
  elp = 0
  do i = st1,ed1
     do j = st2,ed2
        x = h1 * i
        y = h2 * j
        if (i<ed1) then
           e1h1 = e1h1 + abs( pxh1(i,j) - 2*cos(2*(x+h1*0.5))*cos(3*y) )
        end if
        if (j<ed2) then
           e2h2 = e2h2 + abs( pyh2(i,j) + 3*sin(2*x)*sin(3*(y+h2*0.5)) )
        end if
        if (i>st1 .and. i<ed1) then
           e1 = e1 + abs( px(i,j) - 2*cos(2*x)*cos(3*y) )
           e11 = e11 + abs( ppxx(i,j) + 4*sin(2*x)*cos(3*y) )
        end if
        if (j>st2 .and. j<ed2) then
           e2 = e2 + abs( py(i,j) + 3*sin(2*x)*sin(3*y) )
           e22 = e22 + abs( ppyy(i,j) + 9*sin(2*x)*cos(3*y) )
        end if
        if (i>st1 .and. j>st2 .and. i<ed1 .and. j<ed2) then
           e1h2 = e1h2 + abs( pxh2(i,j) - 2*cos(2*(x))*cos(3*(y+0.5*h2)) )
           e2h1 = e2h1 + abs( pyh1(i,j) + 3*sin(2*x+h1)*sin(3*y) )
           e12 = e12 + abs( ppxy(i,j) + 6*cos(2*x)*sin(3*y) )
           elp = elp + abs( pl(i,j) + 4*sin(2*x)*cos(3*y) + 9*sin(2*x)*cos(3*y) )
        end if
     end do
  end do

  write(*,*) "==========================="
  write(*,*) "Error noms: "
  write(*,*) "D1: ", e1/n1/n2
  write(*,*) "D2: ", e2/n1/n2
  write(*,*) "D1H1: ", e1h1/n1/n2
  write(*,*) "D1H2: ", e1h2/n1/n2
  write(*,*) "D2H1: ", e2h1/n1/n2
  write(*,*) "D1H1: ", e1h1/n1/n2
  write(*,*) "D11: ", e11/n1/n2
  write(*,*) "D12: ", e12/n1/n2
  write(*,*) "D22: ", e22/n1/n2
  write(*,*) "Dlp: ", elp/n1/n2
  write(*,*) "==========================="

  deallocate( p )
  deallocate( px )
  deallocate( py )
  deallocate( pyh2 )
  deallocate( pxh1 )
  deallocate( ppxx )
  deallocate( ppyy )
  deallocate( ppxy )
end Program example_1


      subroutine dwpowe(v,pr,pi,rr,ri,ierr)
c!purose
c     computes v^p with v double precision and p complex
c!calling sequence
c     subroutine dwpowe(v,pr,pi,rr,ri,ierr)
c     integer ierr
c     double precision v,pr,pi,rr,ri
c
c     pr   : exponent real part
c     pi   : exponent imaginary part
c     rr   : result's real part
c     ri   : result's imaginary part
c     ierr : error flag
c            ierr=0 if ok
c            ierr=1 if 0**0
c            ierr=2 if  0**k with k<0
c!origin
c Serge Steer INRIA 1996
c!
c     Copyright INRIA
      integer ierr
      double precision v,pr,pi,sr,si,rr,ri,infinity
c
      ierr=0
c
      if(pi.eq.0.0d+0) then
c     p real
         call ddpowe(v,pr,rr,ri,ierr,iscmpl)
      else
         if(v.ne.0.0d+0) then
            call wlog(v,0.0d0,sr,si)
            call wmul(sr,si,pr,pi,sr,si)
            sr=exp(sr)
            rr=sr*cos(si)
            ri=sr*sin(si)
         else
            if(pr.gt.0.0d+0) then
               rr=0.0d+0
               ri=0.0d+0
            elseif(pr.lt.0.0d+0) then
               ri=0.0d+0
               rr=infinity(ri)
               ierr=2
            else
               rr=1.0d+0
               ri=0.0d+0
            endif
         endif
      endif
c
      return
      end


! Copyright 2018 Timothy Hume
!
! Permission to use, copy, modify, and/or distribute this software for any
! purpose with or without fee is hereby granted, provided that the above
! copyright notice and this permission notice appear in all copies.
!
! THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
! REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
! INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
! LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
! OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
! PERFORMANCE OF THIS SOFTWARE.

module mbmath
use, intrinsic  :: iso_fortran_env
use mbtypes                             ! For the realmb type.

contains

subroutine fillplane(cr, ci, nx, ny, zoom, itermax, niter)
    implicit none

    real(kind=realmb), intent(in)                       :: cr
    real(kind=realmb), intent(in)                       :: ci
    integer(kind=int32), intent(in)                     :: nx
    integer(kind=int32), intent(in)                     :: ny
    real(kind=realmb), intent(in)                       :: zoom
    integer(kind=int64), intent(in)                     :: itermax
    real(kind=real64), intent(out),  dimension(nx, ny)  :: niter

    real(kind=realmb)                                   :: inc
    real(kind=realmb)                                   :: dx, dy
    integer(kind=int32)                                 :: i, j
    complex(kind=realmb)                                :: c

    inc = 1.0/real(ny,realmb)/zoom

    do j=1,ny
        dy = (j-ny/2)*inc
        do i=1,nx
            dx = (i-nx/2)*inc
                c = cmplx(cr+dx, ci+dy, realmb)
                niter(i, j) = mbpoint(c, itermax)
        end do
    end do

end subroutine

function mbpoint(c, nmax) result(nr)
    implicit none

    complex(kind=realmb), intent(in)     :: c        ! Point being tested
    integer(kind=int64), intent(in)      :: nmax     ! Maximum iterations
    integer(kind=int64)                  :: n        ! Number of iterations
    real(kind=real64)                    :: nr       ! Real version of n
    complex(kind=realmb)                 :: z
    complex(kind=realmb)                 :: zprev    ! Previous value of z
    real(kind=realmb)                    :: mag2     ! abs(z)^2
    real(kind=realmb)                    :: logzn, nu

    n = 1
    z = (0, 0)
    mag2 = 0
    zprev = (0, 0)

    do while ((mag2 < 65536) .and. (n < nmax))
        zprev = z
        z = z**2 + c
        !
        ! If z is the same as at the previous iteration, we can
        ! break out of the loop because we must be in the Mandelbrot
        ! set.
        !

        if (zprev == z) then
            n = nmax
        else
            mag2 = real(z, realmb)**2 + aimag(z)**2
            n = n + 1
        end if
    end do

    if (n < nmax) then
        logzn = log(mag2)/2.0
        nu = log(logzn/log(2.0))/log(2.0)
        nr = real(n, real64) + 1.0 - real(nu, real64)
    else
        nr = 0.0
    end if

end function

end module