!##############################################################################
!# ****************************************************************************
!# <name> stokes2d_method2_sv </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module is a demonstation program how to solve a Stokes
!# problem on a simple domain.
!#
!# The routine splits up the tasks of reading the domain, creating
!# triangulations, discretisation, solving, postprocessing and creanup into
!# different subroutines. The communication between these subroutines
!# is done using an application-specific structure saving problem data
!# as well as a collection structure for the communication with callback
!# routines.
!#
!# The routine uses the simple-VANKA smoother/preconditioner for
!# 2D saddle point problems, Jacobi-Type.
!# </purpose>
!##############################################################################

module stokes2d_method2_sv

  use fsystem
  use storage
  use genoutput
  use boundary
  use cubature
  use derivatives
  use matrixfilters
  use vectorfilters
  use linearalgebra
  use discretebc
  use bcassembly
  use triangulation
  use element
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock
  use spdiscprojection
  use scalarpde
  use bilinearformevaluation
  use linearformevaluation
  use discretebc
  use filtersupport
  use coarsegridcorrection
  use linearsolver
  use ucd
  use pprocerror
  use genoutput

  use collection

  use stokes2d_callback

  implicit none

!<types>

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

  type t_problem_lvl

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

    ! An object specifying the block discretisation
    ! (size of subvectors in the solution vector, trial/test functions,...)
    type(t_blockDiscretisation), pointer :: p_rdiscretisation

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

    ! A system matrix for that specific level.
    type(t_matrixBlock) :: rmatrix

    ! B1-matrix for that specific level.
    type(t_matrixScalar) :: rmatrixB1

    ! B2-matrix for that specific level.
    type(t_matrixScalar) :: rmatrixB2

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

    ! A filter chain that describes how to filter the matrix/vector
    ! before/during the solution process. The filters usually implement
    ! boundary conditions.
    type(t_filterChain), dimension(1) :: RfilterChain

    ! Number of filters in the filter chain
    integer :: nfilters

  end type

!</typeblock>

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

  type t_problem

    ! Minimum refinement level; = Level i in RlevelInfo
    integer :: ilvmin

    ! Maximum refinement level
    integer :: ilvmax

    ! Viscosity parameter nu = 1/Re
    real(DP) :: dnu

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

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

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

    ! An array of t_problem_lvl structures, each corresponding
    ! to one level of the discretisation.
    type(t_problem_lvl), dimension(:), pointer :: RlevelInfo

    ! A collection object that saves structural data and some
    ! problem-dependent information which is e.g. passed to
    ! callback routines.
    type(t_collection) :: rcollection

  end type

!</typeblock>

!</types>

contains

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

!<subroutine>

  subroutine st1_initParamTriang (ilvmin,ilvmax,rproblem)

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

!<input>
  ! Minimum refinement level of the mesh; = coarse grid = level 1
  integer, intent(in) :: ilvmin

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

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

!</subroutine>

  ! local variables
  integer :: i

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

    ! Initialise the level in the problem structure
    rproblem%ilvmin = ilvmin
    rproblem%ilvmax = ilvmax
    allocate(rproblem%RlevelInfo(ilvmin:ilvmax))

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

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

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

    ! Refine the mesh up to the minimum level
    call tria_quickRefine2LevelOrdering(rproblem%ilvmin-1,&
        rproblem%RlevelInfo(rproblem%ilvmin)%rtriangulation,rproblem%rboundary)

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

    ! Now, refine to level up to nlmax.
    do i=rproblem%ilvmin+1,rproblem%ilvmax
      call tria_refine2LevelOrdering (rproblem%RlevelInfo(i-1)%rtriangulation,&
          rproblem%RlevelInfo(i)%rtriangulation, rproblem%rboundary)
      call tria_initStandardMeshFromRaw (rproblem%RlevelInfo(i)%rtriangulation,&
          rproblem%rboundary)
    end do

  end subroutine

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

!<subroutine>

  subroutine st1_initDiscretisation (rproblem)

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

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

!</subroutine>

  ! local variables
  integer :: I

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

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

    ! An object for the block discretisation on one level
    type(t_blockDiscretisation), pointer :: p_rdiscretisation

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

    do i=rproblem%ilvmin,rproblem%ilvmax
      ! Ask the problem structure to give us the boundary and triangulation.
      ! We need it for the discretisation.
      p_rboundary => rproblem%rboundary
      p_rtriangulation => rproblem%RlevelInfo(i)%rtriangulation

      ! Get the cubature information structure
      p_rcubatureInfo => rproblem%RlevelInfo(i)%rcubatureInfo

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

      ! Save the discretisation structure to our local LevelInfo structure
      ! for later use.
      rproblem%RlevelInfo(i)%p_rdiscretisation => p_rdiscretisation

      ! p_rdiscretisation%Rdiscretisations is a list of scalar
      ! discretisation structures for every component of the solution vector.
      ! We have a solution vector with three components:
      !  Component 1 = X-velocity
      !  Component 2 = Y-velocity
      !  Component 3 = Pressure
      ! For simplicity, we set up one discretisation structure for the
      ! velocity...
      call spdiscr_initDiscr_simple ( &
                  p_rdiscretisation%RspatialDiscr(1), &
                  EL_EM30, p_rtriangulation, p_rboundary)

      ! ...and copy this structure also to the discretisation structure
      ! of the 2nd component (Y-velocity). This needs no additional memory,
      ! as both structures will share the same dynamic information afterwards.
      call spdiscr_duplicateDiscrSc(p_rdiscretisation%RspatialDiscr(1),&
          p_rdiscretisation%RspatialDiscr(2))

      ! For the pressure (3rd component), we set up a separate discretisation
      ! structure, as this uses different finite elements for trial and test
      ! functions.
      call spdiscr_deriveSimpleDiscrSc (p_rdiscretisation%RspatialDiscr(1), &
          EL_Q0, p_rdiscretisation%RspatialDiscr(3))

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

  end subroutine

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

!<subroutine>

  subroutine st1_initMatVec (rproblem)

!<description>
  ! Calculates the system matrix and RHS vector of the linear system
  ! by discretising the problem with the default discretisation structure
  ! in the problem structure.
  ! Sets up a solution vector for the linear system.
!</description>

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

!</subroutine>

  ! local variables
  integer :: i

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

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

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

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

    do i=rproblem%ilvmin,rproblem%ilvmax
      ! Ask the problem structure to give us the discretisation structure
      p_rdiscretisation => rproblem%RlevelInfo(i)%p_rdiscretisation

      p_rmatrix => rproblem%RlevelInfo(i)%rmatrix

      ! Get the cubature information structure
      p_rcubatureInfo => rproblem%RlevelInfo(i)%rcubatureInfo

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

      ! Inform the matrix that we build a saddle-point problem.
      ! Normally, imatrixSpec has the value LSYSBS_MSPEC_GENERAL,
      ! but probably some solvers can use the special structure later.
      p_rmatrix%imatrixSpec = LSYSBS_MSPEC_SADDLEPOINT

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

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

      ! In the Stokes problem, the matrix for the Y-velocity is identical to
      ! the matrix for the X-velocity; both are Laplace-matrices!
      ! Therefore, we can simply make a copy of the matrix for the X-velocity.
      ! This we do later after the entries are created.
      !
      ! In the global system, there are two coupling matrices B1 and B2.
      ! Both have the same structure.
      !
      !    ( A         B1 )
      !    (      A    B2 )
      !    ( B1^T B2^T    )
      !
      ! Create the matrices structure of the pressure using the 3rd
      ! spatial discretisation structure in p_rdiscretisation%RspatialDiscr.
      call bilf_createMatrixStructure (&
                p_rdiscretisation%RspatialDiscr(3),LSYSSC_MATRIX9,&
                rproblem%RlevelInfo(i)%rmatrixB1,&
                p_rdiscretisation%RspatialDiscr(1))

      ! Duplicate the B1 matrix structure to the B2 matrix, so use
      ! lsyssc_duplicateMatrix to create B2. Share the matrix
      ! structure between B1 and B2 (B1 is the parent and B2 the child).
      ! Do not create a content array yet, it will be created by
      ! the assembly routines later.
      call lsyssc_duplicateMatrix (rproblem%RlevelInfo(i)%rmatrixB1,&
                  rproblem%RlevelInfo(i)%rmatrixB2,LSYSSC_DUP_COPY,LSYSSC_DUP_REMOVE)

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

      rform%itermCount = 2
      rform%Idescriptors(1,1) = DER_DERIV_X
      rform%Idescriptors(2,1) = DER_DERIV_X
      rform%Idescriptors(1,2) = DER_DERIV_Y
      rform%Idescriptors(2,2) = DER_DERIV_Y

      ! In the standard case, we have constant coefficients:
      rform%ballCoeffConstant = .true.
      rform%Dcoefficients(1)  = rproblem%dnu
      rform%Dcoefficients(2)  = rproblem%dnu

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

      ! Duplicate the matrix to the Y-velocity matrix, share structure and
      ! content between them (as the matrices are the same).
      call lsyssc_duplicateMatrix (p_rmatrix%RmatrixBlock(1,1),&
          p_rmatrix%RmatrixBlock(2,2),LSYSSC_DUP_SHARE,LSYSSC_DUP_SHARE)

      ! Manually change the discretisation structure of the Y-velocity
      ! matrix to the Y-discretisation structure.
      ! Ok, we use the same discretisation structure for both, X- and Y-velocity,
      ! so this is not really necessary - we do this for sure...
      call lsyssc_assignDiscretisation (p_rmatrix%RmatrixBlock(2,2),&
          p_rdiscretisation%RspatialDiscr(2))

      ! Build the first pressure matrix B1.
      ! Again first set up the bilinear form, then call the matrix assembly.
      rform%itermCount = 1
      rform%Idescriptors(1,1) = DER_FUNC
      rform%Idescriptors(2,1) = DER_DERIV_X

      ! In the standard case, we have constant coefficients:
      rform%ballCoeffConstant = .true.
      rform%Dcoefficients(1)  = -1.0_DP

      call bilf_buildMatrixScalar (rform,.true.,rproblem%RlevelInfo(i)%rmatrixB1,&
          p_rcubatureInfo,coeff_Pressure_2D,rproblem%rcollection)

      ! Build the second pressure matrix B2.
      ! Again first set up the bilinear form, then call the matrix assembly.
      rform%itermCount = 1
      rform%Idescriptors(1,1) = DER_FUNC
      rform%Idescriptors(2,1) = DER_DERIV_Y

      ! In the standard case, we have constant coefficients:
      rform%ballCoeffConstant = .true.
      rform%Dcoefficients(1)  = -1.0_DP

      call bilf_buildMatrixScalar (rform,.true.,rproblem%RlevelInfo(i)%rmatrixB2,&
          p_rcubatureInfo,coeff_Pressure_2D,rproblem%rcollection)

      ! The B1/B2 matrices exist up to now only in our local problem structure.
      ! Put a copy of them into the block matrix.
      !
      ! Note that we share the structure of B1/B2 with those B1/B2 of the
      ! block matrix, while we create copies of the entries. The reason is
      ! that these matrices are modified for boundary conditions later.
      call lsyssc_duplicateMatrix (rproblem%RlevelInfo(i)%rmatrixB1, &
                                   p_rmatrix%RmatrixBlock(1,3),&
                                   LSYSSC_DUP_SHARE,LSYSSC_DUP_COPY)

      call lsyssc_duplicateMatrix (rproblem%RlevelInfo(i)%rmatrixB2, &
                                   p_rmatrix%RmatrixBlock(2,3),&
                                   LSYSSC_DUP_SHARE,LSYSSC_DUP_COPY)

      ! Furthermore, put B1^T and B2^T to the block matrix.
      call lsyssc_transposeMatrix (rproblem%RlevelInfo(i)%rmatrixB1, &
                                   p_rmatrix%RmatrixBlock(3,1),&
                                   LSYSSC_TR_VIRTUAL)

      call lsyssc_transposeMatrix (rproblem%RlevelInfo(i)%rmatrixB2, &
                                   p_rmatrix%RmatrixBlock(3,2),&
                                   LSYSSC_TR_VIRTUAL)

    end do

    ! (Only) on the finest level, we need to calculate a RHS vector
    ! and to allocate a solution vector.

    p_rrhs    => rproblem%rrhs
    p_rvector => rproblem%rvector

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

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

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

    ! ... and then discretise the RHS to the first two subvectors of
    ! the block vector using the discretisation structure of the
    ! corresponding blocks.
    !
    ! We pass our collection structure as well to this routine,
    ! so the callback routine has access to everything what is
    ! in the collection.
    !
    ! Note that the vector is unsorted after calling this routine!

    p_rcubatureInfo => rproblem%RlevelInfo(rproblem%ilvmax)%rcubatureInfo

    call linf_buildVectorScalar (&
        rlinform,.true.,p_rrhs%RvectorBlock(1),&
        p_rcubatureInfo,coeff_RHS_X_2D,rproblem%rcollection)

    call linf_buildVectorScalar (&
        rlinform,.true.,p_rrhs%RvectorBlock(2),&
        p_rcubatureInfo,coeff_RHS_Y_2D,rproblem%rcollection)

    ! The third subvector must be zero - as it represents the RHS of
    ! the equation "div(u) = 0".
    call lsyssc_clearVector(p_rrhs%RvectorBlock(3))

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

  end subroutine

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

!<subroutine>

  subroutine st1_discretiseBC (rdiscretisation,rdiscreteBC)

!<description>
  ! This routine discretises the current boundary conditions for
  ! the discretisation specified by rdiscretisation.
!</description>

!<input>
  ! A discretisation structure specifying the current discretisation.
  type(t_blockDiscretisation), intent(in) :: rdiscretisation
!</input>

!<inputoutput>
  ! A structuree that receives the discretised boundary conditions.
  type(t_discreteBC), intent(inout) :: rdiscreteBC
!</inputoutput>

!</subroutine>

    ! local variables
    type(t_boundaryRegion) :: rboundaryRegion
    type(t_boundary), pointer :: p_rboundary

    p_rboundary => rdiscretisation%p_rboundary

    ! We first set up the boundary conditions for the X-velocity, then those
    ! of the Y-velocity.
    !
    ! We "know" already (from the problem definition) that we have four boundary
    ! segments in the domain. Each of these, we want to use for enforcing
    ! some kind of boundary condition.
    !
    ! We ask the boundary routines to create a "boundary region" - which is
    ! simply a part of the boundary corresponding to a boundary segment.
    ! A boundary region roughly contains the type, the min/max parameter value
    ! and whether the endpoints are inside the region or not.
    call boundary_createRegion(p_rboundary,1,1,rboundaryRegion)

    ! The endpoint of this segment should also be Dirichlet. We set this by
    ! changing the region properties in rboundaryRegion.
    rboundaryRegion%iproperties = BDR_PROP_WITHSTART + BDR_PROP_WITHEND

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

    ! Edge 2 is Neumann boundary, so it is commented out.
    ! CALL boundary_createRegion(p_rboundary,1,2,rboundaryRegion)
    ! CALL bcasm_newDirichletBConRealBD (rdiscretisation,1,&
    !                                    rboundaryRegion,rdiscreteBC,&
    !                                    getBoundaryValues_2D)

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

    ! Edge 4 of boundary component 1. That is it.
    call boundary_createRegion(p_rboundary,1,4,rboundaryRegion)
    call bcasm_newDirichletBConRealBD (rdiscretisation,1,&
                                      rboundaryRegion,rdiscreteBC,&
                                      getBoundaryValues_2D)

    ! Now continue with defining the boundary conditions of the Y-velocity:
    !
    ! Define edge 1.
    call boundary_createRegion(p_rboundary,1,1,rboundaryRegion)

    ! Edge with start- and endpoint.
    rboundaryRegion%iproperties = BDR_PROP_WITHSTART + BDR_PROP_WITHEND

    ! As we define the Y-velocity, we now set icomponent=2 in the following call.
    call bcasm_newDirichletBConRealBD (rdiscretisation,2,&
                                      rboundaryRegion,rdiscreteBC,&
                                      getBoundaryValues_2D)

    ! Edge 2 is Neumann boundary, so it is commented out.
    ! CALL boundary_createRegion(p_rboundary,1,2,rboundaryRegion)
    ! CALL bcasm_newDirichletBConRealBD (rdiscretisation,2,&
    !                                    rboundaryRegion,rdiscreteBC,&
    !                                    getBoundaryValues_2D)

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

    ! Edge 4 of boundary component 1. That is it.
    call boundary_createRegion(p_rboundary,1,4,rboundaryRegion)
    call bcasm_newDirichletBConRealBD (rdiscretisation,2,&
                                      rboundaryRegion,rdiscreteBC,&
                                      getBoundaryValues_2D)

  end subroutine

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

!<subroutine>

  subroutine st1_initDiscreteBC (rproblem)

!<description>
  ! This calculates the discrete version of the boundary conditions and
  ! assigns it to the system matrix and RHS vector.
!</description>

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

!</subroutine>

  ! local variables
  integer :: i

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

    do i=rproblem%ilvmin,rproblem%ilvmax

      ! From the matrix or the RHS we have access to the discretisation and the
      ! analytic boundary conditions.
      p_rdiscretisation => rproblem%RlevelInfo(i)%p_rdiscretisation

      ! For implementing boundary conditions, we use a `filter technique with
      ! discretised boundary conditions`. This means, we first have to calculate
      ! a discrete version of the analytic BC, which we can implement into the
      ! solution/RHS vectors using the corresponding filter.
      !
      ! Create a t_discreteBC structure where we store all discretised boundary
      ! conditions.
      call bcasm_initDiscreteBC(rproblem%RlevelInfo(i)%rdiscreteBC)

      ! Discretise the boundary conditions.
      call st1_discretiseBC (p_rdiscretisation,rproblem%RlevelInfo(i)%rdiscreteBC)

    end do

  end subroutine

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

!<subroutine>

  subroutine st1_implementBC (rproblem)

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

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

!</subroutine>

  ! local variables
  integer :: i,ilvmax

    ! A pointer to the system matrix and the RHS vector as well as
    ! the discretisation
    type(t_matrixBlock), pointer :: p_rmatrix
    type(t_vectorBlock), pointer :: p_rrhs,p_rvector
    type(t_discreteBC), pointer :: p_rdiscreteBC

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

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

    p_rdiscreteBC => rproblem%RlevelInfo(ilvmax)%rdiscreteBC

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

    ! Implement discrete boundary conditions into the matrices on all
    ! levels, too. Call the appropriate matrix filter to modify
    ! all matrices according to the attached discrete boundary conditions.
    do i=rproblem%ilvmin,rproblem%ilvmax
      p_rmatrix => rproblem%RlevelInfo(i)%rmatrix
      p_rdiscreteBC => rproblem%RlevelInfo(i)%rdiscreteBC
      call matfil_discreteBC (p_rmatrix,p_rdiscreteBC)
    end do

  end subroutine

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

!<subroutine>

  subroutine st1_solve (rproblem)

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

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

!</subroutine>

  ! local variables
    integer :: ilvmin,ilvmax
    integer :: i

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

    ! A pointer to the system matrix and the RHS vector as well as
    ! the discretisation
    type(t_matrixBlock), pointer :: p_rmatrix
    type(t_vectorBlock), pointer :: p_rrhs,p_rvector
    type(t_vectorBlock), target :: rtempBlock

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

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

    ! One level of multigrid
    type(t_linsolMG2LevelInfo), pointer :: p_rlevelInfo

    ilvmin = rproblem%ilvmin
    ilvmax = rproblem%ilvmax

    ! Get our right hand side / solution / matrix on the finest
    ! level from the problem structure.
    p_rrhs    => rproblem%rrhs
    p_rvector => rproblem%rvector
    p_rmatrix => rproblem%RlevelInfo(ilvmax)%rmatrix

    ! Create a temporary vector we need that for some preparation.
    call lsysbl_createVectorBlock (p_rrhs, rtempBlock, .false.)

    ! Now we have to build up the level information for multigrid.
    !
    ! Create a Multigrid-solver. Attach the above filter chain
    ! to the solver, so that the solver automatically filters
    ! the vector during the solution process.
    call linsol_initMultigrid2 (p_rsolverNode,ilvmax-ilvmin+1)

    ! Then set up smoothers / coarse grid solver:
    do i=ilvmin,ilvmax

      ! During the linear solver, the boundary conditions must
      ! frequently be imposed to the vectors. This is done using
      ! a filter chain. As the linear solver does not work with
      ! the actual solution vectors but with defect vectors instead,
      ! a filter for implementing the real boundary conditions
      ! would be wrong.
      ! Therefore, create a filter chain with one filter only,
      ! which implements Dirichlet-conditions into a defect vector.
      call filter_initFilterChain (rproblem%RlevelInfo(i)%RfilterChain,&
          rproblem%RlevelInfo(i)%nfilters)
      call filter_newFilterDiscBCDef (rproblem%RlevelInfo(i)%RfilterChain,&
          rproblem%RlevelInfo(i)%nfilters,rproblem%RlevelInfo(i)%rdiscreteBC)

      ! On the coarsest grid, set up a coarse grid solver and no smoother
      ! On finer grids, set up a smoother but no coarse grid solver.
      nullify(p_rpreconditioner)
      nullify(p_rsmoother)
      nullify(p_rcoarseGridSolver)
      if (i .eq. ilvmin) then
        ! Set up a BiCGStab solver with VANKA preconditioning as coarse grid solver:
        call linsol_initVANKA (p_rpreconditioner,1.0_DP,LINSOL_VANKA_2DNAVST)
        call linsol_initBiCGStab (p_rcoarseGridSolver,p_rpreconditioner,&
            rproblem%RlevelInfo(i)%RfilterChain)
        !p_rcoarseGridSolver%ioutputLevel = 2

        ! Setting up UMFPACK coarse grid solver would be:
        ! CALL linsol_initUMFPACK4 (p_rcoarseGridSolver)

      else
        ! Set up the VANKA smoother for multigrid with damping parameter 0.7,
        ! 4 smoothing steps:
        call linsol_initVANKA (p_rsmoother,1.0_DP,LINSOL_VANKA_2DNAVST)
        call linsol_convertToSmoother (p_rsmoother,4,0.7_DP)
      end if

      ! And add this multi-grid level. We will use the same smoother
      ! for pre- and post-smoothing.
      call linsol_getMultigrid2Level (p_rsolverNode,i-ilvmin+1,p_rlevelInfo)
      p_rlevelInfo%p_rcoarseGridSolver => p_rcoarseGridSolver
      p_rlevelInfo%p_rpresmoother => p_rsmoother
      p_rlevelInfo%p_rpostsmoother => p_rsmoother
      p_rlevelInfo%p_rfilterChain => rproblem%RlevelInfo(i)%RfilterChain
    end do

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

    ! Attach the system matrices to the solver.
    !
    ! We copy our matrices to a big matrix array and transfer that
    ! to the setMatrices routines. This intitialises then the matrices
    ! on all levels according to that array. Note that this does not
    ! allocate new memory, we create only "links" to existing matrices
    ! into Rmatrices(:)!
    allocate(Rmatrices(ilvmin:ilvmax))
    do i=ilvmin,ilvmax
      call lsysbl_duplicateMatrix (rproblem%RlevelInfo(i)%rmatrix,&
          Rmatrices(i),LSYSSC_DUP_SHARE,LSYSSC_DUP_SHARE)
    end do

    call linsol_setMatrices(p_RsolverNode,Rmatrices(ilvmin:ilvmax))

    ! We can release Rmatrices immediately -- as long as we do not
    ! release rproblem%RlevelInfo(i)%rmatrix!
    do i=ilvmin,ilvmax
      call lsysbl_releaseMatrix (Rmatrices(i))
    end do
    deallocate(Rmatrices)

    ! 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) then
      call output_line("Matrix structure invalid!",OU_CLASS_ERROR)
      call sys_halt()
    end if

    call linsol_initData (p_rsolverNode, ierror)

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

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

    ! 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 filter chain
    do i=ilvmin,ilvmax
      call filter_doneFilterChain (rproblem%RlevelInfo(i)%RfilterChain,&
          rproblem%RlevelInfo(i)%nfilters)
    end do

    ! Release the temporary vector
    call lsysbl_releaseVector (rtempBlock)

  end subroutine

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

!<subroutine>

  subroutine st1_postprocessing (rproblem)

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

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

!</subroutine>

  ! local variables

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

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

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

    ! A vector accepting Q1 data
    type(t_vectorBlock) :: rprjVector

    ! A discretisation structure for Q1
    type(t_blockDiscretisation) :: rprjDiscretisation

    ! Discrete boundary conditions for the output vector
    type(t_discreteBC), target :: rdiscreteBC

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

    ! The solution vector is probably not in the way, GMV likes it!
    ! GMV for example does not understand Q1~ vectors!
    ! Therefore, we first have to convert the vector to a form that
    ! GMV understands.
    ! GMV understands only Q1 solutions! So the task is now to create
    ! a Q1 solution from p_rvector and write that out.
    !
    ! For this purpose, first create a "derived" simple discretisation
    ! structure based on Q1 by copying the main guiding block discretisation
    ! structure and modifying the discretisation structures of the
    ! two velocity subvectors:

    call spdiscr_duplicateBlockDiscr (p_rvector%p_rblockDiscr,rprjDiscretisation)

    call spdiscr_deriveSimpleDiscrSc (&
                 p_rvector%p_rblockDiscr%RspatialDiscr(1), &
                 EL_Q1, rprjDiscretisation%RspatialDiscr(1))

    call spdiscr_deriveSimpleDiscrSc (&
                 p_rvector%p_rblockDiscr%RspatialDiscr(2), &
                 EL_Q1, rprjDiscretisation%RspatialDiscr(2))

    ! The pressure discretisation substructure stays the old.
    !
    ! Now set up a new solution vector based on this discretisation,
    ! allocate memory.
    call lsysbl_createVecBlockByDiscr (rprjDiscretisation,rprjVector,.false.)

    ! Then take our original solution vector and convert it according to the
    ! new discretisation:
    call spdp_projectSolution (p_rvector,rprjVector)

    ! Discretise the boundary conditions according to the Q1/Q1/Q0
    ! discretisation:
    call bcasm_initDiscreteBC(rdiscreteBC)
    call st1_discretiseBC (rprjDiscretisation,rdiscreteBC)

    ! Send the vector to the boundary-condition implementation filter.
    ! This modifies the vector according to the attached discrete boundary
    ! conditions.
    call vecfil_discreteBCsol (rprjVector,rdiscreteBC)

    ! Now we have a Q1/Q1/Q0 solution in rprjVector.
    !
    ! From the attached discretisation, get the underlying triangulation
    p_rtriangulation => &
      p_rvector%RvectorBlock(1)%p_rspatialDiscr%p_rtriangulation

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

    ! p_rvector now contains our solution. We can now
    ! start the postprocessing.
    ! Start UCD export to VTK file:
    call ucd_startVTK (rexport,UCD_FLAG_STANDARD,p_rtriangulation,&
                       trim(sucddir)//"/u2d_2_sv.vtk")

    ! Write velocity field
    call lsyssc_getbase_double (rprjVector%RvectorBlock(1),p_Ddata)
    call lsyssc_getbase_double (rprjVector%RvectorBlock(2),p_Ddata2)

    ! In case we use the VTK exporter, which supports vector output, we will
    ! pass the X- and Y-velocity at once to the ucd module.
    call ucd_addVarVertBasedVec(rexport,"velocity",p_Ddata,p_Ddata2)

    ! If we use the GMV exporter, we might replace the line above by the
    ! following two lines:
    !CALL ucd_addVariableVertexBased (rexport,"X-vel",UCD_VAR_XVELOCITY, p_Ddata)
    !CALL ucd_addVariableVertexBased (rexport,"Y-vel",UCD_VAR_YVELOCITY, p_Ddata2)

    ! Write pressure
    call lsyssc_getbase_double (rprjVector%RvectorBlock(3),p_Ddata)
    call ucd_addVariableElementBased (rexport,"pressure",UCD_VAR_STANDARD, p_Ddata)

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

    ! Release the auxiliary vector
    call lsysbl_releaseVector (rprjVector)

    ! Release the discretisation structure.
    call spdiscr_releaseBlockDiscr (rprjDiscretisation)

    ! Throw away the discrete BC`s - not used anymore.
    call bcasm_releaseDiscreteBC (rdiscreteBC)

  end subroutine

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

!<subroutine>
  subroutine st1_calcErrors (rproblem)

!<description>
  ! Calculates L2- and H1-errors against analytic solution
!</description>

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

!</subroutine>

  ! Error data structures for post-processing
  type(t_errorScVec) :: rerrorU, rerrorP

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

  ! Error arrays for post-processing
  real(DP), dimension(2), target :: DerrorUL2, DerrorUH1
  real(DP), dimension(1), target :: DerrorPL2

    ! Get the cubature information structure
    p_rcubatureInfo => rproblem%RlevelInfo(rproblem%ilvmax)%rcubatureInfo

    ! Store the viscosity parameter nu in the collection"s quick access array
    rproblem%rcollection%DquickAccess(1) = rproblem%dnu

    ! Set up the error structure for velocity
    rerrorU%p_RvecCoeff => rproblem%rvector%RvectorBlock(1:2)
    rerrorU%p_DerrorL2 => DerrorUL2
    rerrorU%p_DerrorH1 => DerrorUH1

    ! Set up the error structure for pressure
    rerrorP%p_RvecCoeff => rproblem%rvector%RvectorBlock(3:3)
    rerrorP%p_DerrorL2 => DerrorPL2

    ! Calculate errors of velocity and pressure against analytic solutions.
    call pperr_scalarVec(rerrorU, funcVelocity2D, rproblem%rcollection, rcubatureInfo=p_rcubatureInfo)
    call pperr_scalarVec(rerrorP, funcPressure2D, rproblem%rcollection, rcubatureInfo=p_rcubatureInfo)

    ! Print the errors.
    call output_lbrk()
    call output_line("|u - u_h|_L2 = " // trim(sys_sdEL(DerrorUL2(1), 10)) &
                                // " " // trim(sys_sdEL(DerrorUL2(2), 10)))
    call output_line("|u - u_h|_H1 = " // trim(sys_sdEL(DerrorUH1(1), 10)) &
                                // " " // trim(sys_sdEL(DerrorUH1(2), 10)))
    call output_line("|p - p_h|_L2 = " // trim(sys_sdEL(derrorPL2(1), 10)))

  end subroutine

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

!<subroutine>

  subroutine st1_doneMatVec (rproblem)

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

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

!</subroutine>

    integer :: i

    ! Release matrices and vectors on all levels
    do i=rproblem%ilvmax,rproblem%ilvmin,-1
      ! Delete the matrix
      call lsysbl_releaseMatrix (rproblem%RlevelInfo(i)%rmatrix)

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

      ! Release B1 and B2 matrix
      call lsyssc_releaseMatrix (rproblem%RlevelInfo(i)%rmatrixB2)
      call lsyssc_releaseMatrix (rproblem%RlevelInfo(i)%rmatrixB1)

    end do

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

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

  end subroutine

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

!<subroutine>

  subroutine st1_doneBC (rproblem)

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

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

!</subroutine>

  ! local variables
  integer :: i

    do i=rproblem%ilvmax,rproblem%ilvmin,-1
      ! Release our discrete version of the boundary conditions
      call bcasm_releaseDiscreteBC (rproblem%RlevelInfo(i)%rdiscreteBC)
    end do

  end subroutine

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

!<subroutine>

  subroutine st1_doneDiscretisation (rproblem)

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

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

!</subroutine>

  ! local variables
  integer :: i

    do i=rproblem%ilvmax,rproblem%ilvmin,-1
      ! Release the cubature info structure.
      call spdiscr_releaseCubStructure(rproblem%RlevelInfo(i)%rcubatureInfo)

      ! Remove the block discretisation structure and all substructures.
      call spdiscr_releaseBlockDiscr(rproblem%RlevelInfo(i)%p_rdiscretisation)

      ! Remove the discretisation from the heap.
      deallocate(rproblem%RlevelInfo(i)%p_rdiscretisation)
    end do

  end subroutine

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

!<subroutine>

  subroutine st1_doneParamTriang (rproblem)

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

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

!</subroutine>

  ! local variables
  integer :: i

    do i=rproblem%ilvmax,rproblem%ilvmin,-1
      ! Release the triangulation
      call tria_done (rproblem%RlevelInfo(i)%rtriangulation)
    end do

    deallocate(rproblem%RlevelInfo)

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

  end subroutine

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

!<subroutine>

  subroutine stokes2d_2_sv

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

!</subroutine>

    ! NLMIN receives the minimal level where to discretise for supporting
    ! the solution process.
    ! NLMAX receives the level where we want to solve.
    integer :: NLMIN,NLMAX
    real(DP) :: dnu

    ! A problem structure for our problem
    type(t_problem), target :: rproblem

    integer :: i

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

    NLMIN = 2
    NLMAX = 7

    ! Viscosity parameter:
    dnu = 1E0_DP

    rproblem%dnu = dnu

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

    ! So now the different steps - one after the other.
    !
    ! Initialisation
    call st1_initParamTriang (NLMIN,NLMAX,rproblem)
    call st1_initDiscretisation (rproblem)
    call st1_initMatVec (rproblem)
    call st1_initDiscreteBC (rproblem)

    ! Implementation of boundary conditions
    call st1_implementBC (rproblem)

    ! Solve the problem
    call st1_solve (rproblem)

    ! Postprocessing
    call st1_postprocessing (rproblem)
    call st1_calcErrors (rproblem)

    ! Cleanup
    call st1_doneMatVec (rproblem)
    call st1_doneBC (rproblem)
    call st1_doneDiscretisation (rproblem)
    call st1_doneParamTriang (rproblem)

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

    ! Finally release the collection.
    call collct_done (rproblem%rcollection)

  end subroutine

end module


! { dg-do run }
! Tests the fix for PR31867, in which the interface evaluation
! of the character length of 'join' (ie. the length available in
! the caller) was wrong.
!
! Contributed by <beliavsky@aol.com>
!
module util_mod
  implicit none
contains
  function join (words, sep) result(str)
    character (len=*), intent(in)        :: words(:),sep
    character (len = (size (words) - 1) * len_trim (sep) + &
               sum (len_trim (words)))   :: str
    integer                              :: i,nw
    nw  = size (words)
    str = ""
    if (nw < 1) then
      return
    else
      str = words(1)
    end if
    do i=2,nw
      str = trim (str) // trim (sep) // words(i)
    end do
  end function join
end module util_mod
!
program xjoin
  use util_mod, only: join
  implicit none
  integer yy
  character (len=5) :: words(5:8) = (/"two  ","three","four ","five "/), sep = "^#^"
  character (len=5) :: words2(4) = (/"bat  ","ball ","goal ","stump"/), sep2 = "&"

  if (join (words, sep) .ne. "two^#^three^#^four^#^five") call abort ()
  if (len (join (words, sep)) .ne. 25) call abort ()

  if (join (words(5:6), sep) .ne. "two^#^three") call abort ()
  if (len (join (words(5:6), sep)) .ne. 11) call abort ()

  if (join (words(7:8), sep) .ne. "four^#^five") call abort ()
  if (len (join (words(7:8), sep)) .ne. 11) call abort ()

  if (join (words(5:7:2), sep) .ne. "two^#^four") call abort ()
  if (len (join (words(5:7:2), sep)) .ne. 10) call abort ()

  if (join (words(6:8:2), sep) .ne. "three^#^five") call abort ()
  if (len (join (words(6:8:2), sep)) .ne. 12) call abort ()

  if (join (words2, sep2) .ne. "bat&ball&goal&stump") call abort ()
  if (len (join (words2, sep2)) .ne. 19) call abort ()

  if (join (words2(1:2), sep2) .ne. "bat&ball") call abort ()
  if (len (join (words2(1:2), sep2)) .ne. 8) call abort ()

  if (join (words2(2:4:2), sep2) .ne. "ball&stump") call abort ()
  if (len (join (words2(2:4:2), sep2)) .ne. 10) call abort ()

end program xjoin


MODULE Banded_Solve
! Solve systems of linear banded equations.
! Based upon routines from the Naval Surface Warfare Center Mathematics Library

! If A is an m x n banded matrix, then this module assumes that it is stored
! in banded form.
! e.g. if A has 8 rows and 7 columns but only 4 bands:

!      a11  a12  a13   0    0    0    0
!      a21  a22  a23  a24   0    0    0
!       0   a32  a33  a34  a35   0    0
!       0    0   a43  a44  a45  a46   0
!       0    0    0   a54  a55  a56  a57
!       0    0    0    0   a65  a66  a67
!       0    0    0    0    0   a76  a77
!       0    0    0    0    0    0   a87

! Then the banded form of storage is as:

!       0   a11  a12  a13
!      a21  a22  a23  a24
!      a32  a33  a34  a35
!      a43  a44  a45  a46
!      a54  a55  a56  a57
!      a65  a66  a67   0
!      a76  a77   0    0
!      a87   0    0    0

! The number of lower diagonals in this case is ml = 1.
! The number of upper diagonals is mu = 2.

! N.B. dbslv requires ml extra columns to be added at the right-hand side.

! Code converted using TO_F90 by Alan Miller
! Date: 2000-07-16  Time: 19:31:30

IMPLICIT NONE
INTEGER, PARAMETER, PUBLIC  :: dp = SELECTED_REAL_KIND(12, 60)

PRIVATE
PUBLIC  :: dbslv

CONTAINS

SUBROUTINE dswap(n, dx, incx, dy, incy)
!
!     INTERCHANGES TWO VECTORS.
!     USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE.
!     JACK DONGARRA, LINPACK, 3/11/78.
!
INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: dx(:)
INTEGER, INTENT(IN)        :: incx
REAL (dp), INTENT(IN OUT)  :: dy(:)
INTEGER, INTENT(IN)        :: incy

! Local variables

REAL (dp) :: dtemp
INTEGER   :: i, ix, iy, m, mp1
!
IF (n <= 0) RETURN
IF (incx /= 1 .OR. incy /= 1) THEN
!
!       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL TO 1
!
  ix = 1
  iy = 1
  IF (incx < 0) ix = (-n+1) * incx + 1
  IF (incy < 0) iy = (-n+1) * incy + 1
  DO  i = 1, n
    dtemp = dx(ix)
    dx(ix) = dy(iy)
    dy(iy) = dtemp
    ix = ix + incx
    iy = iy + incy
  END DO
  RETURN
END IF
!
!       CODE FOR BOTH INCREMENTS EQUAL TO 1
!
!
!       CLEAN-UP LOOP
!
m = MOD(n,3)
IF (m /= 0) THEN
  DO  i = 1, m
    dtemp = dx(i)
    dx(i) = dy(i)
    dy(i) = dtemp
  END DO
  IF (n < 3) RETURN
END IF
mp1 = m + 1
DO  i = mp1, n, 3
  dtemp = dx(i)
  dx(i) = dy(i)
  dy(i) = dtemp
  dtemp = dx(i+1)
  dx(i+1) = dy(i+1)
  dy(i+1) = dtemp
  dtemp = dx(i+2)
  dx(i+2) = dy(i+2)
  dy(i+2) = dtemp
END DO

RETURN
END SUBROUTINE dswap

SUBROUTINE dbslv(m0, a, ka, n, ml, mu, b, ierr)

! N.B. Argument IWK has been removed.

! ----------------------------------------------------------------------
!  DBSLV EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE
!  THE NxN BANDED LINEAR SYSTEM AX = B.  THE ARGUMENT M0 SPECIFIES
!  IF DBSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
!  RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
!  ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPOSITION
!  OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED.
!  ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED
!  USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO DBSLV.
!
!
!  INPUT ARGUMENTS WHEN M0=0 ---
!
!  A,KA      2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE
!            KA >= N AND M >= 2*ML + MU + 1.  THE FIRST ML+MU+1
!            COLUMNS CONTAIN THE MATRIX A IN BANDED FORM.
!
!  N         NUMBER OF EQUATIONS AND UNKNOWNS.
!
!  ML        NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
!
!  MU        NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
!
!  B         ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND SIDE DATA.
!
!
!  OUTPUT ARGUMENTS WHEN M0=0 ---
!
!  A         AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
!            THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
!
!  B         THE SOLUTION OF THE EQUATIONS.
!
!  IWK       ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES.
!
!  IERR      INTEGER SPECIFYING THE STATUS OF THE RESULTS.
!            IERR=0 IF THE SOLUTION OF AX = B IS OBTAINED.
!            OTHERWISE IERR.NE.0.
!
!
!  AFTER AN INITIAL CALL TO DBSLV, THE ROUTINE MAY BE RECALLED WITH M0.NE.0
!  FOR A NEW B.  WHEN M0.NE.0 IT IS ASSUMED THAT A,KA,N,ML,MU,IWK HAVE NOT
!  BEEN MODIFIED.  DBSLV RETRIEVES THE LU DECOMPOSITION WHICH WAS OBTAINED
!  ON THE INITIAL CALL TO DBSLV AND SOLVES THE NEW EQUATIONS AX = B.
!  IN THIS CASE IERR IS NOT REFERENCED.
! ----------------------------------------------------------------------

INTEGER, INTENT(IN)        :: m0
REAL (dp), INTENT(IN OUT)  :: a(:,:)   ! a(ka,*)
INTEGER, INTENT(IN)        :: ka
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: ml
INTEGER, INTENT(IN)        :: mu
REAL (dp), INTENT(IN OUT)  :: b(:)
INTEGER, INTENT(OUT)       :: ierr

! Local variables

INTEGER  :: i, iwk(n)

IF (m0 == 0) THEN
!
!     ERROR CHECKING
!
  IF (n <= 0 .OR. n > ka) GO TO 10
  IF (ml < 0 .OR. ml >= n) GO TO 20
  IF (mu < 0 .OR. mu >= n) GO TO 30
!
!     OBTAIN AN LU DECOMPOSITION OF A
!
  CALL dbfa(a, n, ml, mu, iwk, ierr)
  IF (ierr /= 0) RETURN
END IF
!
!     SOLVE THE SYSTEM OF EQUATIONS
!
CALL dbsl(a, n, ml, mu, iwk, b, 0)
RETURN
!
!     ERROR RETURN
!
10 ierr = -1
RETURN

20 ierr = -2
RETURN

30 ierr = -3
RETURN
END SUBROUTINE dbslv

SUBROUTINE dbfa(a, n, ml, mu, ipvt, info)

! N.B. Argument LDA has been removed.

! ----------------------------------------------------------------------
!
!            DBFA FACTORS A REAL BAND MATRIX BY ELIMINATION.
!
!                            --------
!  ON ENTRY
!
!     A       REAL (dp)(LDA, NC)
!             CONTAINS THE MATRIX IN BAND STORAGE.  THE ROWS
!             OF THE ORIGINAL MATRIX ARE STORED IN THE ROWS
!             OF A AND THE DIAGONALS OF THE ORIGINAL MATRIX
!             ARE STORED IN COLUMNS 1 THROUGH ML+MU+1 OF A.
!             NC MUST BE >= 2*ML+MU+1.
!             SEE THE COMMENTS BELOW FOR DETAILS.
!
!     LDA     INTEGER
!             THE LEADING DIMENSION OF THE ARRAY A.  IT IS
!             ASSUMED THAT LDA >= N.
!
!     N       INTEGER
!             THE ORDER OF THE ORIGINAL MATRIX.
!
!     ML      INTEGER
!             NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
!             0 <= ML < N .
!
!     MU      INTEGER
!             NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
!             0 <= MU < N .
!             MORE EFFICIENT IF ML <= MU .
!
!  ON RETURN
!
!     A       AN UPPER TRIANGULAR MATRIX IN BAND STORAGE
!             AND THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
!             THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
!             L IS A PRODUCT OF PERMUTATION AND UNIT LOWER
!             TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR.
!
!     IPVT    INTEGER(N)
!             AN INTEGER VECTOR OF PIVOT INDICES.
!
!     INFO    INTEGER
!             =0  NORMAL VALUE
!             =K  IF  U(K,K) .EQ. 0. THIS IS NOT AN ERROR CONDITION FOR THIS
!                 SUBROUTINE, BUT IT DOES INDICATE THAT DBSL WILL DIVIDE BY
!                 ZERO IF IT IS CALLED.
!
!  BAND STORAGE
!
!        IF A0 IS THE MATRIX THEN THE FOLLOWING CODE WILL STORE
!        A0 IN BAND FORM.
!
!                ML = (BAND WIDTH BELOW THE DIAGONAL)
!                MU = (BAND WIDTH ABOVE THE DIAGONAL)
!                DO 20 I = 1, N
!                   J1 = MAX(1, I-ML)
!                   J2 = MIN(N, I+MU)
!                   DO 10 J = J1, J2
!                      K = J - I + ML + 1
!                      A(I,K) = A0(I,J)
!             10    CONTINUE
!             20 CONTINUE
!
!        THIS USES COLUMNS 1 THROUGH  ML + MU + 1  OF A.
!        FURTHERMORE, ML ADDITIONAL COLUMNS ARE NEEDED IN A (STARTING WITH
!        COLUMN  ML+MU+2) FOR ELEMENTS GENERATED DURING THE TRIANGULARIZATION.
!        THE TOTAL NUMBER OF COLUMNS NEEDED IN A IS  2*ML+MU+1 .
!
!  EXAMPLE..  IF THE ORIGINAL MATRIX IS
!
!        11 12 13  0  0  0
!        21 22 23 24  0  0
!         0 32 33 34 35  0
!         0  0 43 44 45 46
!         0  0  0 54 55 56
!         0  0  0  0 65 66
!
!   THEN  N = 6, ML = 1, MU = 2, LDA >= 6  AND A SHOULD CONTAIN
!
!           11 12 13  +     , + = USED FOR PIVOTING
!        21 22 23 24  +
!        32 33 34 35  +
!        43 44 45 46  +
!        54 55 56  +  +
!        65 66  +  +  +
!
!  WRITTEN BY E.A.VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY.
!  MODIFIED BY A.H.MORRIS, NAVAL SURFACE WEAPONS CENTER.
!
!  SUBROUTINES AND FUNCTIONS
!     MIN,DSWAP
! ----------------------------------------------------------------------

REAL (dp), INTENT(IN OUT)  :: a(:,:)   ! a(lda,*)
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: ml
INTEGER, INTENT(IN)        :: mu
INTEGER, INTENT(OUT)       :: ipvt(:)
INTEGER, INTENT(OUT)       :: info

! Local variables

REAL (dp) :: t
INTEGER   :: i, j, j1, jj, k, l, ll, lm, lm1, lm2, lmk, m, mb, ml1, mp, n1
!
info = 0
IF (ml /= 0) THEN
  m = ml + mu + 1
!
!     SET FILL-IN COLUMNS TO ZERO
!
  DO  j = 1, ml
    jj = m + j
    a(1:n,jj) = 0.d0
  END DO
!
!     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
!
  ml1 = ml + 1
  mb = ml + mu
  n1 = n - 1
!  ldb = lda - 1              ! False dimension
  DO  k = 1, n1
    lm = MIN(n-k,ml)
    lmk = lm + k
    lm1 = lm + 1
    lm2 = ml1 - lm
!
!     SEARCH FOR PIVOT INDEX
!
!     l = -idamax(lm1, a(lmk,lm2), ldb) + lm1 + k
    t = ABS(a(lmk,lm2))
    l = 1
    DO j = 1, lm-1
      IF (ABS(a(lmk-j,lm2+j)) > t) THEN
        t = ABS(a(lmk-j,lm2+j))
        l = j + 1
      END IF
    END DO
    l = lm1 + k - l
    ipvt(k) = l
    mp = MIN(mb, n-k)
!
!     SWAP ROWS IF NECESSARY
!
    ll = ml1 + k - l
    IF (l /= k) CALL dswap(mp+1, a(k,ml1:), 1, a(l,ll:), 1)
!
!     SKIP COLUMN REDUCTION IF PIVOT IS ZERO
!
    IF (a(k,ml1) == 0.d0) THEN
      info = k
    ELSE
!
!     COMPUTE MULTIPLIERS
!
      t = -1.d0 / a(k,ml1)
!      CALL dscal(lm, t, a(lmk,lm2), ldb)
      DO j = 0, lm-1
        a(lmk-j,lm2+j) = t * a(lmk-j,lm2+j)
      END DO
!
!     ROW ELIMINATION WITH COLUMN INDEXING
!
      DO  j = 1, mp
        jj = ml1 + j
        j1 = lm2 + j
!        CALL daxpy(lm, a(k,jj), a(lmk,lm2), ldb, a(lmk,j1), ldb)
        DO i = 0, lm-1
          a(lmk-i,j1+i) = a(lmk-i,j1+i) + a(k,jj) * a(lmk-i,lm2+i)
        END DO
      END DO
    END IF
  END DO
!
  ipvt(n) = n
  IF (a(n,ml1) == 0.d0) info = n
  RETURN
END IF
!
!     CASE WHEN ML = 0
!
DO  k = 1, n
  ipvt(k) = k
  IF (a(k,1) == 0.d0) info = k
END DO

RETURN
END SUBROUTINE dbfa

SUBROUTINE dbsl(a, n, ml, mu, ipvt, b, job)

! N.B. Argument LDA has been removed.

! ----------------------------------------------------------------------
!
!  DBSL SOLVES THE REAL BAND SYSTEM A*X = B OR TRANS(A)*X = B
!  USING THE FACTORS COMPUTED BY DBFA.
!
!                      ----------
!  ON ENTRY
!
!     A       REAL (dp)(LDA, NC)
!             THE OUTPUT FROM DBFA.
!             NC MUST BE >= 2*ML+MU+1 .
!
!     LDA     INTEGER
!             THE LEADING DIMENSION OF THE ARRAY A.
!
!     N       INTEGER
!             THE ORDER OF THE ORIGINAL MATRIX.
!
!     ML      INTEGER
!             NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
!
!     MU      INTEGER
!             NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
!
!     IPVT    INTEGER(N)
!             THE PIVOT VECTOR FROM DBFA.
!
!     B       REAL (dp)(N)
!             THE RIGHT HAND SIDE VECTOR.
!
!     JOB     INTEGER
!             = 0         TO SOLVE  A*X = B .
!             = NONZERO   TO SOLVE  TRANS(A)*X = B , WHERE
!                         TRANS(A)  IS THE TRANSPOSE.
!
!  ON RETURN
!
!     B       THE SOLUTION VECTOR  X .
!
!  ERROR CONDITION
!
!     A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A ZERO ON
!     THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY BUT IT IS OFTEN
!     CAUSED BY IMPROPER ARGUMENTS OR IMPROPER SETTING OF LDA.  IT WILL NOT
!     OCCUR IF DBFA AND DBSL ARE CALLED CORRECTLY AND DBFA HAS SET INFO = 0.
!
!  WRITTEN BY E.A. VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY.
!  MODIFIED BY A.H. MORRIS, NAVAL SURFACE WEAPONS CENTER.
!
!  SUBROUTINES AND FUNCTIONS
!   DAXPY
!
!  FORTRAN  MIN
! ----------------------------------------------------------------------

REAL (dp), INTENT(IN)      :: a(:,:)   ! a(lda,*)
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: ml
INTEGER, INTENT(IN)        :: mu
INTEGER, INTENT(IN)        :: ipvt(:)
REAL (dp), INTENT(IN OUT)  :: b(:)
INTEGER, INTENT(IN)        :: job

! Local variables

REAL (dp) :: t
INTEGER   :: i, ii, k, kb, klm, l, lb, lm, m, ml1, ml2, mlm, nm1
!
m = mu + ml + 1
IF (m /= 1) THEN
  ml1 = ml + 1
  ml2 = ml + 2
  nm1 = n - 1
!  ldb = 1 - lda              ! False dimension
  IF (job == 0) THEN
!
!     JOB = 0 , SOLVE  A * X = B
!       FIRST SOLVE L*Y = B
!
    IF (ml /= 0) THEN
      DO  k = 1, nm1
        lm = MIN(ml,n-k)
        l = ipvt(k)
        t = b(l)
        IF (l /= k) THEN
          b(l) = b(k)
          b(k) = t
        END IF
        klm = k + lm
        mlm = ml1 - lm
!        CALL daxpy(lm, t, a(klm,mlm), ldb, b(k+1), 1)
        DO i = 0, lm-1
          ii = lm-1-i
          b(k+1+i) = b(k+1+i) + t * a(klm-ii,mlm+ii)
        END DO
      END DO
    END IF
!
!       NOW SOLVE  U*X = Y
!
    k = n
    DO  kb = 2, n
      b(k) = b(k) / a(k,ml1)
      lm = MIN(k,m) - 1
      lb = k - lm
      t = -b(k)
!      CALL daxpy(lm, t, a(k-1,ml2), ldb, b(lb), 1)
      DO i = 0, lm-1
        ii = lm-1-i
        b(lb+i) = b(lb+i) + t * a(k-1-ii,ml2+ii)
      END DO
      k = k - 1
    END DO
    b(1) = b(1) / a(1,ml1)
    RETURN
  END IF
!
!     JOB = NONZERO, SOLVE TRANS(A) * X = B
!       FIRST SOLVE  TRANS(U)*Y = B
!
  b(1) = b(1) / a(1,ml1)
  DO  k = 2, n
    lm = MIN(k,m) - 1
    lb = k - lm
!    t = ddot(lm, a(k-1,ml2), ldb, b(lb), 1)
    t = 0.0_dp
    DO i = 0, lm-1
      ii = lm-1-i
      t = t + a(k-1-ii,ml2+ii) * b(lb+i)
    END DO
    b(k) = (b(k)-t) / a(k,ml1)
  END DO
  IF (ml == 0) RETURN
!
!       NOW SOLVE TRANS(L)*X = Y
!
  DO  kb = 1, nm1
    k = n - kb
    lm = MIN(ml,n-k)
    klm = k + lm
    mlm = ml1 - lm
!    b(k) = b(k) + ddot(lm, a(klm,mlm), ldb, b(k+1), 1)
    DO i = 0, lm-1
      ii = lm-1-i
      b(k) = b(k) + a(klm-ii,mlm+ii) * b(k+1+i)
    END DO
    l = ipvt(k)
    IF (l /= k) THEN
      t = b(l)
      b(l) = b(k)
      b(k) = t
    END IF
  END DO
  RETURN
END IF
!
!     CASE WHEN ML = 0 AND MU = 0
!
b(1:n) = b(1:n) / a(1:n,1)

RETURN
END SUBROUTINE dbsl

END MODULE Banded_Solve

PROGRAM t_dbslv
USE Banded_Solve
IMPLICIT NONE

! N.B. Even though A has only 4 bands, the solver needs an extra ML
!      columns to use to store pivots.   Here ML = 1.

REAL (dp)  :: a(8,5), x(8)
INTEGER    :: i, ind, ka = 8, n = 8, ml = 1, mu = 2

! Form the matrix A

a = 0.0_dp
DO i = 1, ka
  IF (i > 1)   a(i,1) = 10*i + i - 1   ! Below the diagonal
               a(i,2) = 10*i + i       ! On the diagonal
  IF (i < n)   a(i,3) = 10*i + i + 1   ! 1st band above the diagonal
  IF (i < n-1) a(i,4) = 10*i + i + 2   ! 2nd band above the diagonal
END DO
x = (/ 12.0_dp, -2.0_dp, 2.0_dp, -2.0_dp, 2.0_dp, -2.0_dp, -77.0_dp, -1.0_dp /)

CALL dbslv(0, a, ka, n, ml, mu, x, ind)
WRITE(*, *) 'IND =', ind
WRITE(*, *) 'Solution:'
WRITE(*, '(8f9.5)') x
WRITE(*, *) 'On exit, matrix A contains:'
DO i = 1, ka
  WRITE(*, '(5f10.5)') a(i,1:5)
END DO

STOP
END PROGRAM t_dbslv