!##############################################################################
!# ****************************************************************************
!# <name> hadaptaux </name>
!# ****************************************************************************
!#
!# <purpose>
!#
!# WARNING: Do not USE this module in your applications unless you really
!#          know what you are doing. This module does no error checking!!!
!#
!# This module contains the basic data structures and auxiliary routines
!# which are required for performing h-adaptivity in.
!#
!# The following routines are available:
!#
!#  1.) hadapt_getNVE / hadapt_getNNVE
!#      -> return the (maximum ) number of vertices per element
!#
!#  2.) hadapt_setVertexCoords1D
!#      -> Set the coordinates of vertices to the adaptivity structure in 1D
!#
!#  3.) hadapt_getVertexCoords1D
!#      -> Get the coordinates of vertices from the adaptivity structure in 1D
!#
!#  4.) hadapt_setVertexCoords2D
!#      -> Set the coordinates of vertices to the adaptivity structure in 2D
!#
!#  5.) hadapt_getVertexCoords2D
!#      -> Get the coordinates of vertices from the adaptivity structure in 2D
!#
!#  6.) hadapt_setVertexCoords3D
!#      -> Set the coordinates of vertices to the adaptivity structure in 3D
!#
!#  7.) hadapt_getVertexCoords3D
!#      -> Get the coordinates of vertices from the adaptivity structure in 3D
!#
!#  8.) hadapt_setVerticesAtElement
!#      -> Set the "vertices-at-element" structure to the adaptivity structure
!#
!#  9.) hadapt_getVerticesAtElement
!#      -> Get the "vertices-at-element" structure from the adaptivity structure
!#
!# 10.) hadapt_setNeighboursAtElement
!#      -> Set the "neighbours-at-element" structure to the adaptivity structure
!#
!# 11.) hadapt_getNeighboursAtElement
!#      -> Get the "neighbours-at-element" structure from the adaptivity structure
!#
!# 12.) hadapt_setNelOfType
!#      -> Set the "InelOfType" array to the adaptivity structure
!#
!# 13.) hadapt_getNelOfType
!#      -> Get the "InelOfType" array from the adaptivity structure
!#
!# 14.) hadapt_setBoundary
!#      -> Set the boundary structure to the adaptivity structure
!#
!# 15.) hadapt_getBoundary
!#      -> Get the boundary structure form the adaptivity structure
!#
!# 16.) hadapt_setNodalProperty
!#      -> Set the "nodal property" list to the adaptivity structure
!#
!# 17.) hadapt_getNodalProperty
!#      -> Get the "nodal property" list from the adaptivity structure
!#
!# 18.) hadapt_genElementsAtVertex
!#      -> Generate the "elements-at-vertex" data structure
!#
!# </purpose>
!##############################################################################

module hadaptaux

!$ use omp_lib
  use arraylistInt
  use basicgeometry
  use fsystem
  use genoutput
  use linearalgebra
  use mapInt_DP
  use octreeDP
  use quadtreeDP
  use sort
  use storage
  use triangulation

  implicit none

  private
  public :: t_hadapt
  public :: hadapt_genElementsAtVertex
  public :: hadapt_getSubdivisonLevel
  public :: hadapt_getBoundary
  public :: hadapt_getNVE
  public :: hadapt_getNNVE
  public :: hadapt_getNeighboursAtElement
  public :: hadapt_getNelOfType
  public :: hadapt_getNodalProperty
  public :: hadapt_getVertexCoords1D
  public :: hadapt_getVertexCoords2D
  public :: hadapt_getVertexCoords3D
  public :: hadapt_getVerticesAtElement
  public :: hadapt_setBoundary
  public :: hadapt_setNeighboursAtElement
  public :: hadapt_setNelOfType
  public :: hadapt_setNodalProperty
  public :: hadapt_setVertexCoords1D
  public :: hadapt_setVertexCoords2D
  public :: hadapt_setVertexCoords3D
  public :: hadapt_setVerticesAtElement

!<constants>

!<constantblock description="Global flags for mesh refinement/coarsening">

  ! No refinement and coarsening
  integer, parameter, public :: HADAPT_NOADAPTATION = 0

  ! Red-Green refinement and coarsening strategy (R. Banks et al.)
  integer, parameter, public :: HADAPT_REDGREEN     = 1

  ! Longest edge bisection strategy (M. Rivara)
  integer, parameter, public :: HADAPT_LONGESTEDGE  = 2

!</constantblock>

!<constantblock description="Bitfield identifiers for state of adaptation">

  ! Adaptation is undefined
  integer(I32), parameter, public :: HADAPT_NONE             = 0_I32

  ! Parameters of adaptivity structure are initialised
  integer(I32), parameter, public :: HADAPT_HAS_PARAMETERS   = 2_I32**0

  ! Map/quadtree/octree for vertex coordinates is generated
  integer(I32), parameter, public :: HADAPT_HAS_COORDS       = 2_I32**1

  ! Array for IverticesAtElement is generated
  integer(I32), parameter, public :: HADAPT_HAS_VERTATELEM   = 2_I32**2

  ! Array for IneighboursAtElement is generated
  integer(I32), parameter, public :: HADAPT_HAS_NEIGHATELEM  = 2_I32**3

  ! Array for ImidneighboursAtElement is generated
  integer(I32), parameter, public :: HADAPT_HAS_MIDNEIGH     = 2_I32**4

  ! Boundary data is generated
  integer(I32), parameter, public :: HADAPT_HAS_BOUNDARY     = 2_I32**5

  ! Nodal property is generated
  integer(I32), parameter, public :: HADAPT_HAS_NODALPROP    = 2_I32**6

  ! Number of elements for predefined type
  integer(I32), parameter, public :: HADAPT_HAS_NELOFTYPE    = 2_I32**7

  ! Array for IelementsAtVertex is generated
  integer(I32), parameter, public :: HADAPT_HAS_ELEMATVERTEX = 2_I32**8

  ! Dynamic data structures in 1D are all generated
  integer(I32), parameter, public :: HADAPT_HAS_DYNAMICDATA1D  = HADAPT_HAS_PARAMETERS+&
                                                                 HADAPT_HAS_COORDS+&
                                                                 HADAPT_HAS_VERTATELEM+&
                                                                 HADAPT_HAS_NEIGHATELEM+&
                                                                 HADAPT_HAS_NODALPROP+&
                                                                 HADAPT_HAS_NELOFTYPE+&
                                                                 HADAPT_HAS_ELEMATVERTEX

  ! Dynamic data structures in 2D are all generated
  integer(I32), parameter, public :: HADAPT_HAS_DYNAMICDATA2D  = HADAPT_HAS_PARAMETERS+&
                                                                 HADAPT_HAS_COORDS+&
                                                                 HADAPT_HAS_VERTATELEM+&
                                                                 HADAPT_HAS_NEIGHATELEM+&
                                                                 HADAPT_HAS_MIDNEIGH+&
                                                                 HADAPT_HAS_NODALPROP+&
                                                                 HADAPT_HAS_NELOFTYPE+&
                                                                 HADAPT_HAS_ELEMATVERTEX

  ! Dynamic data structures in 3D are all generated
  integer(I32), parameter, public :: HADAPT_HAS_DYNAMICDATA3D  = HADAPT_HAS_PARAMETERS+&
                                                                 HADAPT_HAS_COORDS+&
                                                                 HADAPT_HAS_VERTATELEM+&
                                                                 HADAPT_HAS_NEIGHATELEM+&
                                                                 HADAPT_HAS_NODALPROP+&
                                                                 HADAPT_HAS_NELOFTYPE+&
                                                                 HADAPT_HAS_ELEMATVERTEX

  ! Cells are marked for refinement
  integer(I32), parameter, public :: HADAPT_MARKEDREFINE     = 2_I32**9

  ! Cells are marked for coarsening
  integer(I32), parameter, public :: HADAPT_MARKEDCOARSEN    = 2_I32**10

  ! Cells are marked
  integer(I32), parameter, public :: HADAPT_MARKED           = HADAPT_MARKEDREFINE+&
                                                               HADAPT_MARKEDCOARSEN

!</constantblock>

!<constantblock description="Global constants for grid modification operations">

  ! Operation identifier for initialization of callback function
  integer, parameter, public :: HADAPT_OPR_INITCALLBACK     = -1

  ! Operation identifier for finalization of callback function
  integer, parameter, public :: HADAPT_OPR_DONECALLBACK     = -2

  ! Operation identifier for adjustment of vertex dimension
  integer, parameter, public :: HADAPT_OPR_ADJUSTVERTEXDIM  = 1

  ! Operation identifier for vertex insertion at edge midpoint
  integer, parameter, public :: HADAPT_OPR_INSERTVERTEXEDGE = 2

  ! Operation identifier for vertex insertion at element centroid
  integer, parameter, public :: HADAPT_OPR_INSERTVERTEXCENTR= 3

  ! Operation identifier for vertex removal
  integer, parameter, public :: HADAPT_OPR_REMOVEVERTEX     = 4

  ! Operation identifier for refinment: 1-tria : 2-tria
  integer, parameter, public :: HADAPT_OPR_REF_TRIA2TRIA    = 5

  ! Operation identifier for refinment: 1-tria : 3-tria
  integer, parameter, public :: HADAPT_OPR_REF_TRIA3TRIA12  = 6

  ! Operation identifier for refinment: 1-tria : 3-tria
  integer, parameter, public :: HADAPT_OPR_REF_TRIA3TRIA23  = 7

  ! Operation identifier for refinment: 1-tria : 4-tria
  integer, parameter, public :: HADAPT_OPR_REF_TRIA4TRIA    = 8

  ! Operation identifier for refinment: 1-quad : 2-quad
  integer, parameter, public :: HADAPT_OPR_REF_QUAD2QUAD    = 9

  ! Operation identifier for refinment: 1-quad : 3-tria
  integer, parameter, public :: HADAPT_OPR_REF_QUAD3TRIA    = 10

  ! Operation identifier for refinment: 1-quad : 4-tria
  integer, parameter, public :: HADAPT_OPR_REF_QUAD4TRIA    = 11

  ! Operation identifier for refinment: 1-quad : 4-quad
  integer, parameter, public :: HADAPT_OPR_REF_QUAD4QUAD    = 12

  ! Operation identifier for conversion: 2-tria : 4-tria
  integer, parameter, public :: HADAPT_OPR_CVT_TRIA2TRIA    = 13

  ! Operation identifier for conversion: 2-quad : 4-tria
  integer, parameter, public :: HADAPT_OPR_CVT_QUAD2QUAD    = 14

  ! Operation identifier for conversion: 3-tria : 4-quad
  integer, parameter, public :: HADAPT_OPR_CVT_QUAD3TRIA    = 15

  ! Operation identifier for conversion: 4-tria : 4-quad
  integer, parameter, public :: HADAPT_OPR_CVT_QUAD4TRIA    = 16

  ! Operation identifier for coarsening: 2-tria : 1-tria
  integer, parameter, public :: HADAPT_OPR_CRS_2TRIA1TRIA   = 17

  ! Operation identifier for coarsening: 4-tria : 1-tria
  integer, parameter, public :: HADAPT_OPR_CRS_4TRIA1TRIA   = 18

  ! Operation identifier for coarsening: 4-tria : 2-tria
  integer, parameter, public :: HADAPT_OPR_CRS_4TRIA2TRIA1  = 19

  ! Operation identifier for coarsening: 4-tria : 2-tria
  integer, parameter, public :: HADAPT_OPR_CRS_4TRIA2TRIA2  = 20

  ! Operation identifier for coarsening: 4-tria : 2-tria
  integer, parameter, public :: HADAPT_OPR_CRS_4TRIA2TRIA3  = 21

  ! Operation identifier for coarsening: 4-quad : 1-quad
  integer, parameter, public :: HADAPT_OPR_CRS_4QUAD1QUAD   = 22

  ! Operation identifier for coarsening: 4-quad : 2-quad
  integer, parameter, public :: HADAPT_OPR_CRS_4QUAD2QUAD   = 23

  ! Operation identifier for coarsening: 4-quad : 3-tria
  integer, parameter, public :: HADAPT_OPR_CRS_4QUAD3TRIA   = 24

  ! Operation identifier for coarsening: 4-quad : 4-tria
  integer, parameter, public :: HADAPT_OPR_CRS_4QUAD4TRIA   = 25

  ! Operation identifier for coarsening: 2-quad : 1-quad
  integer, parameter, public :: HADAPT_OPR_CRS_2QUAD1QUAD   = 26

  ! Operation identifier for coarsening: 2-quad : 3-tria
  integer, parameter, public :: HADAPT_OPR_CRS_2QUAD3TRIA   = 27

  ! Operation identifier for coarsening: 3-tria : 1-quad
  integer, parameter, public :: HADAPT_OPR_CRS_3TRIA1QUAD   = 28

  ! Operation identifier for coarsening: 4-tria : 1-quad
  integer, parameter, public :: HADAPT_OPR_CRS_4TRIA1QUAD   = 29

  ! Operation identifier for coarsening: 4-tria : 3-tria
  integer, parameter, public :: HADAPT_OPR_CRS_4TRIA3TRIA2  = 30

  ! Operation identifier for coarsening: 4-tria : 3-tria
  integer, parameter, public :: HADAPT_OPR_CRS_4TRIA3TRIA3  = 31

  ! Operation identifier for refinement: 1-line : 2-line
  integer, parameter, public :: HADAPT_OPR_REF_LINE2LINE    = 32

  ! Operation identifier for coarsening: 2-line : 1-line
  integer, parameter, public :: HADAPT_OPR_CRS_2LINE1LINE   = 33

!</constantblock>

!<constantblock
! description="Duplication flags. Specifies which information is shared between adaptivity structures">

  integer(I32), parameter, public :: HADAPT_SHARE_IMARKER            = 2_I32**0
  integer(I32), parameter, public :: HADAPT_SHARE_IVERTEXAGE         = 2_I32**1
  integer(I32), parameter, public :: HADAPT_SHARE_INODALPROPERTY     = 2_I32**2
  integer(I32), parameter, public :: HADAPT_SHARE_IVERTICESATELEMENT = 2_I32**3
  integer(I32), parameter, public :: HADAPT_SHARE_INEIGHATELEMENT    = 2_I32**4
  integer(I32), parameter, public :: HADAPT_SHARE_IMIDNEIGHATELEMENT = 2_I32**5
  integer(I32), parameter, public :: HADAPT_SHARE_RVERTEXCOORDINATES = 2_I32**6
  integer(I32), parameter, public :: HADAPT_SHARE_RBOUNDARY          = 2_I32**7
  integer(I32), parameter, public :: HADAPT_SHARE_RELEMENTSATVERTEX  = 2_I32**8

!</constantblock>

!</constants>

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

!<types>

  !<typeblock>

  ! This type contains all data structures to handle
  ! adaptive grid refinement and grid coarsening.
  type :: t_hadapt
    ! Format Tag: Specifies the state of adaptation
    integer(I32) :: iSpec = HADAPT_NONE

    ! Duplication flag. Bitfield that indicates which information is
    ! shared with another adaptivity structure.
    ! When a bit is set to 1, the corresponding array is
    ! maintained by another adaptivity structure and must
    ! not be deleted by hadapt_releaseAdaptation.
    ! When the bit is 0, the array is a real copy of another array
    ! and must be deleted in hadapt_releaseAdaptation.
    integer(I32) :: iduplicationFlag = 0_I32

    ! Tag: Specifies the strategy for grid refinement and coarsening
    integer :: iadaptationStrategy = HADAPT_NOADAPTATION

    ! Maximum number of subdivisions from the original mesh
    integer :: nsubdividemax = 0

    ! Total number of grid refinement steps
    integer :: nRefinementSteps = 0

    ! Total number of grid coarsening steps
    integer :: nCoarseningSteps = 0

    ! Total number of grid smoothing steps
    integer :: nSmoothingSteps = 0

    ! Tolerance for refinement
    real(DP) :: drefinementTolerance = 0

    ! Tolerance for coarsening
    real(DP) :: dcoarseningTolerance = 0

    ! Dimension of the triangulation
    integer :: ndim = 0

    ! Total number of vertices (initially)
    integer :: NVT0 = 0

    ! Total number of vertices
    integer :: NVT = 0

    ! Increment of vertices
    integer :: increaseNVT = 0

    ! Total number of boundary vertives (initially)
    integer :: NVBD0 = 0

    ! Total number of boundary vertives
    integer :: NVBD = 0

    ! Total number of boundary components (should not change)
    integer :: NBCT = 0

    ! Total number of elements (initially)
    integer :: NEL0 = 0

    ! Total number of elements
    integer :: NEL = 0

    ! Maximum number of elements (before reallocation)
    integer :: NELMAX = 0

    ! Total number of green elements (required internally)
    integer :: nGreenElements = 0

    ! Nuber of elements with a defined number of vertices per element.
    ! InelOfType(TRIA_NVELINE1D) = number of lines in the mesh (1D).
    ! InelOfType(TRIA_NVETRI2D)  = number of triangles in the mesh (2D).
    ! InelOfType(TRIA_NVEQUAD2D) = number of quadrilaterals in the mesh (2D).
    integer, dimension(TRIA_MAXNVE) :: InelOfType = 0

    ! Same as InelOfType but this array stores the number of elements
    ! which are initially present in the mesh
    integer, dimension(TRIA_MAXNVE) :: InelOfType0 = 0

    ! Element marker array.
    ! Handle to
    !       p_Imarker = array [1..NEL] of integer.
    ! For each element there is one identifier [0,..,31] in the marker.
    ! BIT0: Is 0 for triangle and 1 for quadrilateral
    ! BIT1: Is 0 if first edge is not subdivided, 1 otherwise.
    ! BIT2: Is 0 if second edge is not subdivided, 1 otherwise.
    ! BIT3: Is 0 if third edge is not subdivided, 1 otherwise.
    ! BIT4: Is 0 if fourth edge is not subdivided, 1 otherwise.
    integer :: h_Imarker = ST_NOHANDLE

    ! Vertex age array.
    ! Handle to
    !       p_IvertexAge = array [1..NVT] of integer
    ! Each node has an individual age which is used to determine
    ! the type of the element (green/red triangle/quadrilateral).
    ! The nodes of the initial grid are assigned age 0 by default.
    ! Each node which is introduced at the midpoint of one edge (I,J)
    ! is given the age MAX(AGE(I),AGE(J))+1. For vertices which are
    ! inserted at the center of a quadrilateral, the maximum age of
    ! all four surrounding vertices is adopted and increased by one.
    ! A negative age means, the the vertex is lockes, that is, it
    ! cannot be removed. By definition, vertices of the initial
    ! triangulation cannot be removed and are always locked.
    integer :: h_IvertexAge = ST_NOHANDLE

    ! Pointer to h_IvertexAge.
    ! This array is introduced to increase performance and must
    ! not be modified by the user
    integer, dimension(:), pointer :: p_IvertexAge => null()

    ! Nodal property array.
    ! Handle to
    !       p_InodalProperty = array [1..NVT+NMT] of integer
    ! p_InodalProperty(i) defines for each vertex i=(1..NVT)
    ! and each edge i=(NVT+1..NVT+NMT) its function inside of the
    ! geometry. Generally said, the range of the p_InodalProperty-array
    ! characterises the type of the node (=vertex/edge):
    ! = 0    : The vertex/edge is an inner vertex/edge
    ! > 0    : The vertex/edge is a boundary vertex/edge on the real
    !           boundary. KNPR(.) defines the number of the boundary
    !           component.
    integer :: h_InodalProperty = ST_NOHANDLE

    ! Pointer to h_InodalProperty.
    ! This array is introduced to increase performance and must
    ! not be modified by the user
    integer, dimension(:), pointer :: p_InodalProperty => null()

    ! Vertices adjacent to an element.
    ! Handle to
    !       p_IverticesAtElement = array [1..TRIA_MAXNVE2D,1..NEL] of integer.
    ! For each element the node numbers of the corner-vertices
    ! in mathematically positive sense.
    integer :: h_IverticesAtElement = ST_NOHANDLE

    ! Pointer to h_IverticesAtElement.
    ! This array is introduced to increase performance and must
    ! not be modified by the user
    integer, dimension(:,:), pointer :: p_IverticesAtElement => null ()

    ! Neighbour elements adjacent to an element.
    ! Handle to
    !       p_IneighboursAtElement = array [1..TRIA_MAXNME2D,1..NEL] of integer
    ! For each element, the numbers of adjacent elements in mathematically
    ! positive sense, metting the element in an edge.
    integer :: h_IneighboursAtElement = ST_NOHANDLE

    ! Pointer to h_IneighboursAtElement.
    ! This array is introduced to increase performance and must
    ! not be modified by the user
    integer, dimension(:,:), pointer :: p_IneighboursAtElement => null ()

    ! Midneighbour elements adjacent to an element.
    ! Handle to
    !       p_ImidneighboursAtElement = array [1..TRIA_MAXNME2D,1..NEL] of integer
    ! H-adaptivity is performed element-by-element. If one element is
    ! refined, then its neighbors need to be informed that there
    ! are possibly two elements adjacent along one edge. This is a
    ! nonconforming state. When time comes to process the other
    ! element (with hanging node), the element knows which elements
    ! are adjacent along the first and the second half of the edge.
    integer :: h_ImidneighboursAtElement = ST_NOHANDLE

    ! Pointer to h_ImidneighboursAtElement.
    ! This array is introduced to increase performance and must
    ! not be modified by the user
    integer, dimension(:,:), pointer :: p_ImidneighboursAtElement => null ()

    ! Handle to h_DVertexCoords in 1D
    integer :: h_DvertexCoords1D

    ! Pointer to handle h_DvertexCoords in 1D
    real(DP), dimension(:,:), pointer :: p_DvertexCoords1D => null()

    ! Quadtree storing the nodal coordinates in 2D
    type(t_quadtreeDP) :: rVertexCoordinates2D

    ! Octree storing the nodal coordinates in 2D
    type(t_octreeDP) :: rVertexCoordinates3D

    ! Array of maps storing the boundary data
    ! p_IboundaryCpIdx and p_IverticesAtBoundary
    type(t_mapInt_DP), dimension(:), pointer :: rBoundary => null()

    ! Arraylist for elements-meeting-at-vertex structure
    type(t_arraylistInt) :: rElementsAtVertex
  end type t_hadapt

  !</typeblock>

!</types>

contains

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

!<function>

  pure function hadapt_getNVE(rhadapt, iel) result(nve)

!<description>
    ! This function returns the number of vertices present in the given element
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt

    ! Number of the element
    integer, intent(in) :: iel
!</input>

!<result>
    ! Number of vertices per element
    integer :: nve
!</result>
!</function>

    do nve = ubound(rhadapt%p_IverticesAtElement,1), 1, -1
      if (rhadapt%p_IverticesAtElement(nve,iel) .ne. 0) return
    end do
  end function hadapt_getNVE

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

!<function>

  pure function hadapt_getNNVE(rhadapt) result(nnve)

!<description>
    ! This function returns the maximum number of vertices
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt
!</input>

!<result>
    ! Maximum number of vertices per element
    integer :: nnve
!</result>
!</function>

    do nnve = ubound(rhadapt%InelOfType,1), 1, -1
      if (rhadapt%InelOfType(nnve) .ne. 0) return
    end do
  end function hadapt_getNNVE

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

!<subroutine>

  subroutine hadapt_setVertexCoords1D(rhadapt, h_DvertexCoords, nvt)

!<description>
    ! This subroutine sets the vertex coordinates given by the handle
    ! h_DvertexCoords that points to the two-dimensional array
    ! p_DvertexCoords and stores them in the map.
!</description>

!<input>
    ! Handle to the vertex coordinates
    integer, intent(in) :: h_DvertexCoords

    ! Number of vertices
    integer, intent(in) :: nvt
!</input>

!<inputoutput>
    ! Adaptivity structure
    type(t_hadapt), intent(inout) :: rhadapt
!</inputoutput>
!</subroutine>

    ! Check if handle is not empty
    if (h_DvertexCoords .eq. ST_NOHANDLE) then
      call output_line('Invalid handle!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_setVertexCoords1D')
      call sys_halt()
    end if

    ! Check if structure is already generated, then remove old structure first
    if (iand(rhadapt%iSpec, HADAPT_HAS_COORDS) .eq.&
                            HADAPT_HAS_COORDS) then
      if (rhadapt%h_DvertexCoords1D .ne. ST_NOHANDLE)&
          call storage_free(rhadapt%h_DvertexCoords1D)
    end if

    ! Copy handle and set pointer
    call storage_copy(h_DvertexCoords, rhadapt%h_DvertexCoords1D)
    call storage_getbase_double2D(rhadapt%h_DvertexCoords1D,&
                                  rhadapt%p_DvertexCoords1D)

    ! Set specifier for structure
    rhadapt%iSpec = ior(rhadapt%iSpec, HADAPT_HAS_COORDS)

    ! Set dimensions
    rhadapt%ndim = NDIM1D
    rhadapt%NVT  = nvt
  end subroutine hadapt_setVertexCoords1D

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

!<subroutine>

  subroutine hadapt_getVertexCoords1D(rhadapt, h_DvertexCoords, nvt, ndim)

!<description>
    ! This subroutine gets the vertex coordinates from the structure
    ! and stores them in the two-dimensional array associated to the
    ! handle h_DvertexCoords. Note that the allocated memory will
    ! be reallocated if is does not provide the correct dimensions.
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt
!</input>

!<inputoutput>
    ! Handlt to the vertex coordinate vector
    integer, intent(inout) :: h_DvertexCoords
!</inputoutput>

!<output>
    ! OPTIONAL: number of vertices
    integer, intent(out), optional :: nvt

    ! OPTIONAL: number of spatial dimensions
    integer, intent(out), optional :: ndim
!</output>
!</subroutine>

    ! local variables
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    real(DP), dimension(:,:), pointer :: p_Ddata
    integer, dimension(2) :: Isize

    ! Check if coordinates exists
    if (iand(rhadapt%iSpec, HADAPT_HAS_COORDS) .ne.&
                            HADAPT_HAS_COORDS) then
      call output_line('Coords do not exist!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getVertexCoords1D')
      call sys_halt()
    end if

    ! Check if coordinates are given in 1D
    if (rhadapt%ndim .ne. NDIM1D) then
      call output_line('Invalid spatial dimension!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getVertexCoords1D')
      call sys_halt()
    end if

    ! Check if given handle is valid
    if (h_DvertexCoords .eq. ST_NOHANDLE) then
      Isize=(/1,rhadapt%NVT/)
      call storage_new('hadapt_getVertexCoords1D', 'DCORVG', Isize,&
                       ST_DOUBLE, h_DvertexCoords, ST_NEWBLOCK_NOINIT)
    else
      call storage_getsize(h_DvertexCoords, Isize)
      if (Isize(1) .ne. 1) then
        call output_line('First component of DvertexCoords must be 1!',&
                         OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getVertexCoords1D')
        call sys_halt()
      end if

      if (Isize(2) .lt. rhadapt%NVT) then
        call storage_realloc('hadapt_getVertexCoords1D', rhadapt%NVT,&
                             h_DvertexCoords, ST_NEWBLOCK_NOINIT, .false.)
      end if
    end if

    ! Set pointers
    call storage_getbase_double2D(rhadapt%h_DvertexCoords1D,&
                                  p_Ddata, rhadapt%NVT)
    call storage_getbase_double2D(h_DvertexCoords, p_DvertexCoords)

    ! Copy data
    call lalg_copyVector(p_Ddata, p_DvertexCoords, 1, rhadapt%NVT)

    ! Set dimension
    if (present(ndim)) ndim = rhadapt%ndim
    if (present(nvt))  nvt  = rhadapt%NVT
  end subroutine hadapt_getVertexCoords1D

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

!<subroutine>

  subroutine hadapt_setVertexCoords2D(rhadapt, h_DvertexCoords, nvt)

!<description>
    ! This subroutine sets the vertex coordinates given by the handle
    ! h_DvertexCoords that points to the two-dimensional array
    ! p_DvertexCoords and stores them in the quadtree.
!</description>

!<input>
    ! Handle to the vertex coordinates
    integer, intent(in) :: h_DvertexCoords

    ! Number of vertices
    integer, intent(in) :: nvt
!</input>

!<inputoutput>
    ! Adaptivity structure
    type(t_hadapt), intent(inout) :: rhadapt
!</inputoutput>
!</subroutine>

    ! local variables
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    real(DP) :: xmin,xmax,ymin,ymax
    integer  :: nnode

    ! Check if handle is not empty
    if (h_DvertexCoords .eq. ST_NOHANDLE) then
      call output_line('Invalid handle!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_setVertexCoords2D')
      call sys_halt()
    end if

    ! Check if quadtree is already generated, then remove old quadtree/octree first
    if (iand(rhadapt%iSpec, HADAPT_HAS_COORDS) .eq.&
                            HADAPT_HAS_COORDS) then
      call qtree_release(rhadapt%rVertexCoordinates2D)
    end if

    ! Set pointer
    call storage_getbase_double2D(h_DvertexCoords, p_DvertexCoords, nvt)

    ! Get outer bounding-box of vertex coordinates
    xmin = minval(p_DvertexCoords(1,:))
    xmax = maxval(p_DvertexCoords(1,:))
    ymin = minval(p_DvertexCoords(2,:))
    ymax = maxval(p_DvertexCoords(2,:))

    ! Estimate number of initial quadrilaterals
    nnode = int(0.5_DP*nvt)

    ! Create quadtree for vertices
    call qtree_create(rhadapt%rVertexCoordinates2D, nvt,&
                      nnode, xmin, ymin, xmax, ymax)

    ! Copy vertex coordinates to quadtree
    call qtree_copy(p_DvertexCoords, rhadapt%rVertexCoordinates2D)

    ! Set specifier for quadtree
    rhadapt%iSpec = ior(rhadapt%iSpec, HADAPT_HAS_COORDS)

    ! Set dimensions
    rhadapt%ndim = NDIM2D
    rhadapt%NVT  = nvt
  end subroutine hadapt_setVertexCoords2D

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

!<subroutine>

  subroutine hadapt_getVertexCoords2D(rhadapt, h_DvertexCoords, nvt, ndim)

!<description>
    ! This subroutine gets the vertex coordinates from the quadtree
    ! and stores them in the two-dimensional array associated to the
    ! handle h_DvertexCoords. Note that the allocated memory will
    ! be reallocated if is does not provide the correct dimensions.
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt
!</input>

!<inputoutput>
    ! Handlt to the vertex coordinate vector
    integer, intent(inout) :: h_DvertexCoords
!</inputoutput>

!<output>
    ! OPTIONAL: number of vertices
    integer, intent(out), optional :: nvt

    ! OPTIONAL: number of spatial dimensions
    integer, intent(out), optional :: ndim
!</output>
!</subroutine>

    ! Check if coordinates exists
    if (iand(rhadapt%iSpec, HADAPT_HAS_COORDS) .ne.&
                            HADAPT_HAS_COORDS) then
      call output_line('Quadtree does not exist!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getVertexCoords2D')
      call sys_halt()
    end if

    ! Check if coordinates are given in 2D
    if (rhadapt%ndim .ne. NDIM2D) then
      call output_line('Invalid spatial dimension!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getVertexCoords2D')
      call sys_halt()
    end if

    ! Copy quadtree to handle h_DvertexCoords
    call qtree_copy(rhadapt%rVertexCoordinates2D, h_DvertexCoords)

    ! Set dimension
    if (present(ndim)) ndim = rhadapt%ndim
    if (present(nvt))  nvt  = rhadapt%NVT
  end subroutine hadapt_getVertexCoords2D

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

!<subroutine>

  subroutine hadapt_setVertexCoords3D(rhadapt, h_DvertexCoords, nvt)

!<description>
    ! This subroutine sets the vertex coordinates given by the handle
    ! h_DvertexCoords that points to the three-dimensional array
    ! p_DvertexCoords and stores them in the octree.
!</description>

!<input>
    ! Handle to the vertex coordinates
    integer, intent(in) :: h_DvertexCoords

    ! Number of vertices
    integer, intent(in) :: nvt
!</input>

!<inputoutput>
    ! Adaptivity structure
    type(t_hadapt), intent(inout)    :: rhadapt
!</inputoutput>
!</subroutine>

    ! local variables
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    real(DP) :: xmin,xmax,ymin,ymax,zmin,zmax
    integer  :: nnode

    ! Check if handle is not empty
    if (h_DvertexCoords .eq. ST_NOHANDLE) then
      call output_line('Invalid handle!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_setVertexCoords3D')
      call sys_halt()
    end if

    ! Check if quadtree is already generated, then remove old quadtree/octree first
    if (iand(rhadapt%iSpec, HADAPT_HAS_COORDS) .eq.&
                            HADAPT_HAS_COORDS) then
      call otree_release(rhadapt%rVertexCoordinates3D)
    end if

    ! Set pointer
    call storage_getbase_double2D(h_DvertexCoords, p_DvertexCoords, nvt)

    ! Get outer bounding-box of vertex coordinates
    xmin = minval(p_DvertexCoords(1,:))
    xmax = maxval(p_DvertexCoords(1,:))
    ymin = minval(p_DvertexCoords(2,:))
    ymax = maxval(p_DvertexCoords(2,:))
    zmin = minval(p_DvertexCoords(3,:))
    zmax = maxval(p_DvertexCoords(3,:))

    ! Estimate number of initial quadrilaterals
    nnode = int(0.5_DP*nvt)

    ! Create octree for vertices
    call otree_create(rhadapt%rVertexCoordinates3D, nvt,&
                            nnode, xmin, ymin, zmin, xmax, ymax, zmax)

    ! Copy vertex coordinates to octree
    call otree_copy(p_DvertexCoords, rhadapt%rVertexCoordinates3D)

    ! Set specifier for quadtree
    rhadapt%iSpec=ior(rhadapt%iSpec, HADAPT_HAS_COORDS)

    ! Set dimensions
    rhadapt%ndim = NDIM3D
    rhadapt%NVT  = nvt
  end subroutine hadapt_setVertexCoords3D

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

!<subroutine>

  subroutine hadapt_getVertexCoords3D(rhadapt, h_DvertexCoords, nvt, ndim)

!<description>
    ! This subroutine gets the vertex coordinates from the octree
    ! and stores them in the three-dimensional array associated to the
    ! handle h_DvertexCoords. Note that the allocated memory will
    ! be reallocated if is does not provide the correct dimensions.
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt
!</input>

!<inputoutput>
    ! Handlt to the vertex coordinate vector
    integer, intent(inout) :: h_DvertexCoords
!</inputoutput>

!<output>
    ! OPTIONAL: number of vertices
    integer, intent(out), optional :: nvt

    ! OPTIONAL: number of spatial dimensions
    integer, intent(out), optional :: ndim
!</output>
!</subroutine>

    ! Check if coordinates exists
    if (iand(rhadapt%iSpec, HADAPT_HAS_COORDS) .ne.&
                            HADAPT_HAS_COORDS) then
      call output_line('Octree does not exist!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getVertexCoords3D')
      call sys_halt()
    end if

    ! Check if coordinates are given in 2D
    if (rhadapt%ndim .ne. NDIM3D) then
      call output_line('Invalid spatial dimension!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getVertexCoords3D')
      call sys_halt()
    end if

    ! Copy octree to handle h_DvertexCoords
    call otree_copy(rhadapt%rVertexCoordinates3D, h_DvertexCoords)

    ! Set dimension
    if (present(ndim)) ndim = rhadapt%ndim
    if (present(nvt))  nvt  = rhadapt%NVT
  end subroutine hadapt_getVertexCoords3D

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

!<subroutine>

  subroutine hadapt_setVerticesAtElement(rhadapt, h_IverticesAtElement, nel)

!<description>
    ! This routine assigns the handle to the "vertices-at-element" array
    ! to the adaptivity structure and sets up internal links.
!</description>

!<input>
    ! Handle to p_IverticesAtElement
    integer, intent(in) :: h_IverticesAtElement

    ! Total number of elements
    integer, intent(in) :: nel
!</input>

!<inputoutput>
    ! adaptivity structure
    type(t_hadapt), intent(inout) :: rhadapt
!</inputoutput>
!</subroutine>

    ! Check if handle is not empty
    if (h_IverticesAtElement .eq. ST_NOHANDLE) then
      call output_line('Invalid handle!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_setVerticesAtElement')
      call sys_halt()
    end if

    rhadapt%h_IverticesAtElement = h_IverticesAtElement
    call storage_getbase_int2D(rhadapt%h_IverticesAtElement,&
                               rhadapt%p_IverticesAtElement)

    ! Set specifier for IverticesAtElement
    rhadapt%iSpec = ior(rhadapt%iSpec, HADAPT_HAS_VERTATELEM)

    ! Set dimensions
    rhadapt%NEL = nel
  end subroutine hadapt_setVerticesAtElement

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

!<subroutine>

  subroutine hadapt_getVerticesAtElement(rhadapt, h_IverticesAtElement, nel)

!<description>
    ! This routine assigns the "vertices-at-element" array from the
    ! adaptivity structure to the given handle.
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt
!</input>

!<inputoutput>
    ! Hande to p_IverticesAtElement
    integer, intent(inout) :: h_IverticesAtElement
!</inputoutput>

!<output>
    ! OPTIONAL: number of elements
    integer, intent(out), optional :: nel
!</output>
!</subroutine>

    ! Check if "vertices-at-element" array exists
    if (iand(rhadapt%iSpec, HADAPT_HAS_VERTATELEM) .ne.&
                            HADAPT_HAS_VERTATELEM) then
      call output_line('Structure does not exist!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getVerticesAtElement')
      call sys_halt()
    end if

    ! Check if handle needs to be freed first
    if ((h_IverticesAtElement .ne. ST_NOHANDLE) .and.&
        (h_IverticesAtElement .ne. rhadapt%h_IverticesAtElement))&
        call storage_free(h_IverticesAtElement)

    ! Assign handle
    h_IverticesAtElement = rhadapt%h_IverticesAtElement

    ! Set dimensions
    if(present(nel))   nel = rhadapt%NEL
  end subroutine hadapt_getVerticesAtElement

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

!<subroutine>

  subroutine hadapt_setNeighboursAtElement(rhadapt, h_IneighboursAtElement)

!<description>
    ! This routine assigns the handle to the "neighbours-at-element" array
    ! to the adaptivity structure and sets up internal links.
!</description>

!<input>
    ! Handle to p_IneighboursAtElement
    integer, intent(in) :: h_IneighboursAtElement
!</input>

!<inputoutput>
    ! adaptivity structure
    type(t_hadapt), intent(inout) :: rhadapt
!</inputoutput>
!</subroutine>

    ! Check if handle is not empty
    if (h_IneighboursAtElement .eq. ST_NOHANDLE) then
      call output_line('Invalid handle!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_setNeighboursAtElement')
      call sys_halt()
    end if

    rhadapt%h_IneighboursAtElement = h_IneighboursAtElement
    call storage_getbase_int2D(rhadapt%h_IneighboursAtElement,&
                               rhadapt%p_IneighboursAtElement)

    ! What spatial dimension are we?
    select case(rhadapt%ndim)
    case (NDIM1D,&
          NDIM3D)
      ! Do nothing

    case(NDIM2D)
      ! Create structure of "mid-adjacent" neighbours
      call storage_copy(rhadapt%h_IneighboursAtElement,&
                        rhadapt%h_ImidneighboursAtElement)
      call storage_getbase_int2D(rhadapt%h_ImidneighboursAtElement,&
                                 rhadapt%p_ImidneighboursAtElement)

      ! Set specifier for ImidneighboursAtElement
      rhadapt%iSpec = ior(rhadapt%iSpec, HADAPT_HAS_MIDNEIGH)

    case default
      call output_line('Unsupported spatial dimension!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_setNeighboursAtElement')
      call sys_halt()
    end select

    ! Set specifier for IverticesAtElement
    rhadapt%iSpec = ior(rhadapt%iSpec, HADAPT_HAS_NEIGHATELEM)
  end subroutine hadapt_setNeighboursAtElement

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

!<subroutine>

  subroutine hadapt_getNeighboursAtElement(rhadapt,&
                                           h_IneighboursAtElement, nel)

!<description>
    ! This routine assigns the "neighbours-at-element" array from the
    ! adaptivity structure to the given handle
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt
!</input>

!<inputoutput>
    ! Hande to p_IneighboursAtElement
    integer, intent(inout) :: h_IneighboursAtElement
!</inputoutput>

!<output>
    ! OPTIONAL: number of elements
    integer, intent(out), optional :: nel
!</output>
!</subroutine>

    ! Check if "neighbours-at-element" array exists
    if (iand(rhadapt%iSpec, HADAPT_HAS_NEIGHATELEM) .ne.&
                            HADAPT_HAS_NEIGHATELEM) then
      call output_line('Structure does not exist!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getNeighboursAtElement')
      call sys_halt()
    end if

    ! Check if handle needs to be freed first
    if ((h_IneighboursAtElement .ne. ST_NOHANDLE) .and.&
        (h_IneighboursAtElement .ne. rhadapt%h_IneighboursAtElement))&
        call storage_free(h_IneighboursAtElement)

    ! Assign handle
    h_IneighboursAtElement = rhadapt%h_IneighboursAtElement

    ! Set dimensions
    if(present(nel))   nel = rhadapt%NEL
  end subroutine hadapt_getNeighboursAtElement

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

!<subroutine>

  subroutine hadapt_setNelOfType(rhadapt, InelOfType)

!<description>
    ! This subroutine sets the number of elements with a defined number
    ! of vertices per elements, that is, InelOfType(TRIA_MAXNVE)
!</description>

!<input>
    ! Number of elements with a defined number of vertices per element.
    integer, dimension(TRIA_MAXNVE), intent(in) :: InelOfType
!</input>

!<inputoutput>
    ! Adaptivity structure
    type(t_hadapt), intent(inout) :: rhadapt
!</inputoutput>
!</subroutine>

    rhadapt%InelOfType = InelOfType

    ! Set specifier for InelOfType
    rhadapt%iSpec = ior(rhadapt%iSpec, HADAPT_HAS_NELOFTYPE)
  end subroutine hadapt_setNelOfType

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

!<subroutine>

  subroutine hadapt_getNelOfType(rhadapt, InelOfType)

!<description>
    ! This subroutine returns the number of elements with a defined number
    ! of vertices per elements, that is, InelOfType(TRIA_MAXNVE)
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt
!</input>

!<output>
    ! Number of elements with a defined number of vertices per element.
    integer, dimension(TRIA_MAXNVE), intent(out) :: InelOfType
!</output>
!</subroutine>

    ! Check if "InelOfType" array exists
    if (iand(rhadapt%iSpec, HADAPT_HAS_NELOFTYPE) .ne.&
                            HADAPT_HAS_NELOFTYPE) then
      call output_line('Structure does not exist!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getNelOfType')
      call sys_halt()
    end if

    InelOfType = rhadapt%InelOfType
  end subroutine hadapt_getNelOfType

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

!<subroutine>

  subroutine hadapt_setBoundary(rhadapt, h_IboundaryCpIdx, h_IverticesAtBoundary,&
                                h_DvertexParameterValue, nbct, nvbd)

!<description>
    ! This subroutine sets the boundary structure to the
    ! adaptivity structure and initialises internal data
!</description>

!<input>
    ! Handle to p_IboundaryCpIdx
    integer, intent(in) :: h_IboundaryCpIdx

    ! Handle to p_IverticesAtBoundary
    integer, intent(in) :: h_IverticesAtBoundary

    ! Handle to p_DvertexParameterValue
    integer, intent(in) :: h_DvertexParameterValue

    ! Number of boundary components
    integer, intent(in) :: nbct

    ! Number of vertices at the boundary
    integer, intent(in) :: nvbd
!</input>

!<inputoutput>
    ! Adaptivity structure
    type(t_hadapt), intent(inout) :: rhadapt
!</inputoutput>
!</subroutine>

    ! local variables
    type(it_mapInt_DP) :: rmapIter
    real(DP), dimension(:), pointer   :: p_DvertexParameterValue
    integer, dimension(:), pointer    :: p_IboundaryCpIdx
    integer, dimension(:), pointer    :: p_IverticesAtBoundary
    real(DP), dimension(3) :: Ddata
    integer :: ibct,ioff,ivbd,ivbdEnd,ivbdStart,lvbd

    ! Check if handle are not empty
    if ((h_IboundaryCpIdx .eq. ST_NOHANDLE) .or.&
        (h_IverticesAtBoundary .eq. ST_NOHANDLE) .or.&
        (h_DvertexParameterValue .eq. ST_NOHANDLE)) then
      call output_line('Invalid handle!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_setBoundary')
      call sys_halt()
    end if

    ! Check if boundary structure exists and remove it
    if (associated(rhadapt%rBoundary)) then
      do ibct = 1, size(rhadapt%rBoundary,1)
        call map_release(rhadapt%rBoundary(ibct))
      end do
      deallocate(rhadapt%rBoundary)
    end if

    ! Set pointers
    call storage_getbase_double(h_DvertexParameterValue,&
                                p_DvertexParameterValue, nvbd)
    call storage_getbase_int(h_IboundaryCpIdx,&
                             p_IboundaryCpIdx, nbct+1)
    call storage_getbase_int(h_IverticesAtBoundary,&
                             p_IverticesAtBoundary, nvbd)

    ! Allocate array of maps
    allocate(rhadapt%rBoundary(nbct))

    ! Initialization
    ioff = 0

    do ibct = 1, nbct

      ! Create a separate map for each boundary component
      lvbd = p_IboundaryCpIdx(ibct+1)-p_IboundaryCpIdx(ibct)
      call map_create(rhadapt%rBoundary(ibct), lvbd, 3)

      ! Set subdimensions
      ivbdStart = ioff+1
      ivbdEnd   = ioff+lvbd
      ioff      = ioff+lvbd

      ! Insert first element into map
      Ddata(1) =      p_DvertexParameterValue(ivbdStart)
      Ddata(2) = real(p_IverticesAtBoundary(ivbdEnd),DP)
      Ddata(3) = real(p_IverticesAtBoundary(ivbdStart+1),DP)

      rmapIter = map_insert(rhadapt%rBoundary(ibct),&
                            p_IverticesAtBoundary(ivbdStart), Ddata)

      ! Insert second to last but one element into map
      do ivbd = ivbdStart+1, ivbdEnd-1
        Ddata(1) =      p_DvertexParameterValue(ivbd)
        Ddata(2) = real(p_IverticesAtBoundary(ivbd-1),DP)
        Ddata(3) = real(p_IverticesAtBoundary(ivbd+1),DP)

        rmapIter = map_insert(rhadapt%rBoundary(ibct),&
                              p_IverticesAtBoundary(ivbd), Ddata)
      end do

      ! Insert last element into map
      Ddata(1) =      p_DvertexParameterValue(ivbdEnd)
      Ddata(2) = real(p_IverticesAtBoundary(ivbdEnd-1),DP)
      Ddata(3) = real(p_IverticesAtBoundary(ivbdStart),DP)

      rmapIter = map_insert(rhadapt%rBoundary(ibct),&
                            p_IverticesAtBoundary(ivbdEnd), Ddata)
    end do

    ! Set dimensions
    rhadapt%NBCT  = nbct
    rhadapt%NVBD  = nvbd
    rhadapt%NVBD0 = nvbd

    ! Set specifier for boundary
    rhadapt%iSpec = ior(rhadapt%iSpec, HADAPT_HAS_BOUNDARY)

  end subroutine hadapt_setBoundary

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

!<function>

  function hadapt_getSubdivisonLevel(rhadapt) result(isubdivisionLevel)

!<description>
    ! This function calculates the deepest subdivision level present
    ! in the adaptivity structure. If the structure is not
    ! initialised, then this routine returns -1.
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt
!</input>

!<result>
    ! Deepest subdivision level
    integer :: IsubdivisionLevel
!</result>
!</function>

    ! local variable
    integer, dimension(:), pointer :: p_IvertexAge

    if (rhadapt%h_IvertexAge .eq. ST_NOHANDLE) then
      isubdivisionLevel = -1
    else
      call storage_getbase_int(rhadapt%h_IvertexAge, p_IvertexAge)
      isubdivisionLevel = maxval(p_IvertexAge)
    end if

  end function hadapt_getSubdivisonLevel

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

!<subroutine>

  subroutine hadapt_getBoundary(rhadapt, h_IboundaryCpIdx, h_IverticesAtBoundary,&
                                h_DvertexParameterValue, nvbd, nbct)

!<description>
    ! This subroutine extracts the boundary data from the adaptivity structure
    ! and generates the the arrays p_IboundaryCpIdx, p_IverticesAtBoundary and
    ! p_DvertexParameterValue. If the optional parameter nvbd is given
    ! then the number of boundary vertices is assigned.
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt
!</input>

!<inputoutput>
    ! Handle to p_IboundaryCpIdx
    integer, intent(inout) :: h_IboundaryCpIdx

    ! Handle to p_IverticesAtBoundary
    integer, intent(inout) :: h_IverticesAtBoundary

    ! Handle to p_DvertexParameterValue
    integer, intent(inout) :: h_DvertexParameterValue

    ! OPTIONAL: number of vertices at the boundary
    integer, intent(out), optional :: nvbd

    ! OPTIONAL: number of boundary components
    integer, intent(out), optional :: nbct
!</inputoutput>
!</subroutine>

    ! local variables
    type(it_mapInt_DP) :: rmapIter
    real(DP), dimension(:), pointer :: p_DvertexParameterValue, p_Ddata
    integer, dimension(:), pointer  :: p_IboundaryCpIdx
    integer, dimension(:), pointer  :: p_IverticesAtBoundary
    integer :: ibct,ioff,isize,ivbd,ivbdEnd,ivbdStart,lvbd

    ! Check if boundary data exists
    if (iand(rhadapt%iSpec, HADAPT_HAS_BOUNDARY) .ne.&
                            HADAPT_HAS_BOUNDARY) then
      call output_line('Structure does not exist!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getBoundary')
      call sys_halt()
    end if

    ! Due to the fact, that the boundary data may be stored in
    ! multiple maps (one for each component) the static arrays are
    ! pre-allocated and filled step-by-step from the dynamic data in
    ! the boundary map(s).

    ! Check if the arrays p_IboundaryCpIdx, p_IverticesAtBoundary and
    ! p_DvertexParameterValue have correct dimension
    if (h_IboundaryCpIdx .eq. ST_NOHANDLE) then
      call storage_new('hadapt_getBoundary', 'p_IboundaryCpIdx',&
                       rhadapt%NBCT+1, ST_INT, h_IboundaryCpIdx,&
                       ST_NEWBLOCK_NOINIT)
    else
      call storage_getsize(h_IboundaryCpIdx, isize)
      if (isize < rhadapt%NBCT+1) then
        call storage_realloc('hadapt_getBoundary', rhadapt%NBCT+1,&
                             h_IboundaryCpIdx, ST_NEWBLOCK_NOINIT, .false.)
      end if
    end if

    if (h_IverticesAtBoundary .eq. ST_NOHANDLE) then
      call storage_new('hadapt_getBoundary', 'p_IverticesAtBoundary',&
                       rhadapt%NVBD, ST_INT, h_IverticesAtBoundary,&
                       ST_NEWBLOCK_NOINIT)
    else
      call storage_getsize(h_IverticesAtBoundary, isize)
      if (isize < rhadapt%NVBD) then
        call storage_realloc('hadapt_getBoundary', rhadapt%NVBD,&
                             h_IverticesAtBoundary, ST_NEWBLOCK_NOINIT, .false.)
      end if
    end if

    if (h_DvertexParameterValue .eq. ST_NOHANDLE) then
      call storage_new('hadapt_getBoundary', 'p_DvertexParameterValue',&
                       rhadapt%NVBD, ST_DOUBLE, h_DvertexParameterValue,&
                       ST_NEWBLOCK_NOINIT)
    else
      call storage_getsize(h_DvertexParameterValue, isize)
      if (isize < rhadapt%NVBD) then
        call storage_realloc('hadapt_getBoundary', rhadapt%NVBD,&
                             h_DvertexParameterValue, ST_NEWBLOCK_NOINIT, .false.)
      end if
    end if

    ! Set pointers
    call storage_getbase_int(h_IboundaryCpIdx,&
                             p_IboundaryCpIdx, rhadapt%NBCT+1)
    call storage_getbase_int(h_IverticesAtBoundary,&
                             p_IverticesAtBoundary, rhadapt%NVBD)
    call storage_getbase_double(h_DvertexParameterValue,&
                                p_DvertexParameterValue, rhadapt%NVBD)

    ! Initialization
    p_IboundaryCpIdx(1) = 1
    ioff = 0
    ivbd = 0

    do ibct = 1, rhadapt%NBCT

      ! Set subdimensions
      lvbd      = map_size(rhadapt%rBoundary(ibct))
      ivbdStart = ioff+1
      ivbdEnd   = ioff+lvbd
      ioff      = ioff+lvbd

      ! Set index for next boundary component
      p_IboundaryCpIdx(ibct+1) = ioff+1

      ! Get static boundary data from map
      rmapIter = map_begin(rhadapt%rBoundary(ibct))

      do while(.not.map_isNull(rmapIter))

        ! Increase counter
        ivbd = ivbd+1

        ! Get key value
        p_IverticesAtBoundary(ivbd) = map_get(rhadapt%rBoundary(ibct), rmapIter)

        ! Get auxiliary data
        call map_getbase_data(rhadapt%rBoundary(ibct), rmapIter, p_Ddata)
        p_DvertexParameterValue(ivbd) = p_Ddata(1)

        ! Increase iterators
        call map_next(rmapIter)
      end do

      ! Consistency check
      if (ivbd .ne. ivbdEnd) then
        call output_line('An internal error occured!',&
            OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getBoundary')
        call sys_halt()
      end if

      ! Sort array w.r.t. increasing parameter values
      call sort_dp(p_DvertexParameterValue(ivbdStart:ivbdEnd),&
                   SORT_QUICK, p_IverticesAtBoundary(ivbdStart:ivbdEnd))
    end do

    ! Set dimension
    if(present(nvbd)) nvbd = rhadapt%NVBD
    if(present(nbct)) nbct = rhadapt%NBCT
  end subroutine hadapt_getBoundary

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

!<subroutine>

  subroutine hadapt_setNodalProperty(rhadapt, h_InodalProperty)

!<description>
    ! This subroutine sets the nodal property list to the adaptivity structure
!</description>

!<input>
    ! Handle to p_InodalProperty
    integer, intent(in) :: h_InodalProperty
!</input>

!<inputoutput>
    ! Adaptivity structure
    type(t_hadapt), intent(inout) :: rhadapt
!</inputoutput>
!</subroutine>

    ! Check if handle is not empty
    if (h_InodalProperty .eq. ST_NOHANDLE) then
      call output_line('Invalid handle!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_setNodalProperty')
      call sys_halt()
    end if

    rhadapt%h_InodalProperty = h_InodalProperty
    call storage_getbase_int(rhadapt%h_InodalProperty,&
                             rhadapt%p_InodalProperty)

    ! Set specifier for InodalProperty
    rhadapt%iSpec = ior(rhadapt%iSpec, HADAPT_HAS_NODALPROP)
  end subroutine hadapt_setNodalProperty

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

!<subroutine>

  subroutine hadapt_getNodalProperty(rhadapt, h_InodalProperty)

!<description>
    ! This subroutine assignes the "nodal property" array from the
    ! adaptivity structure to the given handle
!</description>

!<input>
    ! Adaptivity structure
    type(t_hadapt), intent(in) :: rhadapt
!</input>

!<inputoutput>
    ! Hande to p_InodalProperty
    integer, intent(inout) :: h_InodalProperty
!</inputoutput>
!</subroutine>

    ! Check if "nodal property" list exits
    if (iand(rhadapt%iSpec, HADAPT_HAS_NODALPROP) .ne.&
                            HADAPT_HAS_NODALPROP) then
      call output_line('Structure does not exist!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_getNodalProperty')
      call sys_halt()
    end if

    ! Check if handle needs to be freed first
    if ((h_InodalProperty .ne. ST_NOHANDLE) .and.&
        (h_InodalProperty .ne. rhadapt%h_InodalProperty))&
        call storage_free(h_InodalProperty)

    ! Assign handle
    h_InodalProperty = rhadapt%h_InodalProperty
  end subroutine hadapt_getNodalProperty

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

!<subroutine>

  subroutine hadapt_genElementsAtVertex(rhadapt)

!<description>
    ! This subroutine generates a list of arrays for the "elements-at-vertex"
    ! structure. This is an internal structure of the adaptivity structure
    ! which is used, e.g., in the removel of vertices.
!</description>

!<inputoutput>
    ! Adaptivity structur
    type(t_hadapt), intent(inout) :: rhadapt
!</inputoutput>
!</subroutine>

    ! local variables
    integer :: iel,ive

    ! Check if "vertices-at-element" list exists
    if (iand(rhadapt%iSpec, HADAPT_HAS_VERTATELEM) .ne.&
                            HADAPT_HAS_VERTATELEM) then
      call output_line('Structure does not exist!',&
                       OU_CLASS_ERROR,OU_MODE_STD,'hadapt_genElementsAtVertex')
      call sys_halt()
    end if

    ! Create arraylist
    call alst_create(rhadapt%relementsAtVertex, 2*rhadapt%NVT, 8*rhadapt%NEL)

    ! Fill arraylist
    do iel = 1, rhadapt%NEL
      do ive = 1, hadapt_getNVE(rhadapt,iel)
        call alst_push_back(rhadapt%relementsAtVertex,&
                            rhadapt%p_IverticesAtElement(ive,iel), iel)
      end do
    end do

    ! Set specifier for relementsAtVertex
    rhadapt%iSpec = ior(rhadapt%iSpec, HADAPT_HAS_ELEMATVERTEX)
  end subroutine hadapt_genElementsAtVertex

end module hadaptaux


      subroutine rsedyr

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine writes the yearly reach output to the .sed file

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name         |units        |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    rch_dakm(:)  |km**2        |total drainage area contributing to flow at
!!                               |the outlet (pour point) of the reach in
!!                               |square kilometers
!!    subgis(:)    |none         |GIS code printed to output files(output.sub,.rch)
!!    subtot       |none         |number of subbasins in watershed
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ii          |none          |counter
!!    j           |none          |counter (reach number)
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j

      do j = 1, subtot
          rchyro(58,j) = rchyro(58,j)/dfloat(idlast)
          write (84,5000) j, subgis(j), iyr, rch_dakm(j),
     &       rchyro(3,j), rchyro(4,j),(rchyro(ii,j),ii=42,58)
      end do

      return
 5000 format ('REACH ',i4,1x,i8,1x,i5,20e12.4)
      end


! This code is part of
! RRTM for GCM Applications - Parallel (RRTMGP)
!
! Eli Mlawer and Robert Pincus
! Andre Wehe and Jennifer Delamere
! email:  rrtmgp@aer.com
!
! Copyright 2017,  Atmospheric and Environmental Research and
! Regents of the University of Colorado.  All right reserved.
!
! Use and duplication is permitted under the terms of the
!    BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause
!

!
! This module provides an interface to RRTMGP for a common use case --
!   users want to start from gas concentrations, pressures, and temperatures,
!   and compute clear-sky (aerosol plus gases) and all-sky fluxes.
! The routines here have the same names as those in mo_rrtmgp_[ls]w; normally users
!   will use either this module or the underling modules, but not both
!
module mo_rrtmgp_clr_all_sky
  use mo_rte_kind,   only: FT
  use mo_gas_optics, &
                        only: ty_gas_optics
  use mo_gas_concentrations, &
                        only: ty_gas_concs
  use mo_optical_props, only: ty_optical_props, &
                              ty_optical_props_arry, ty_optical_props_1scl, ty_optical_props_2str, ty_optical_props_nstr
  use mo_source_functions, &
                        only: ty_source_func_lw
  use mo_fluxes,        only: ty_fluxes
  use mo_rte_lw,        only: base_rte_lw => rte_lw
  use mo_rte_sw,        only: base_rte_sw => rte_sw
  implicit none
  private

  public :: rte_lw, rte_sw
contains
  ! --------------------------------------------------
  !
  ! Interfaces using clear (gas + aerosol) and all-sky categories, starting from
  !   pressures, temperatures, and gas amounts for the gas contribution
  !
  ! --------------------------------------------------
  function rte_lw(k_dist, gas_concs, p_lay, t_lay, p_lev,    &
                     t_sfc, sfc_emis, cloud_props,           &
                     allsky_fluxes, clrsky_fluxes,           &
                     aer_props, col_dry, t_lev, inc_flux, n_gauss_angles) result(error_msg)
    class(ty_gas_optics),              intent(in   ) :: k_dist       !< derived type with spectral information
    type(ty_gas_concs),                intent(in   ) :: gas_concs    !< derived type encapsulating gas concentrations
    real(FT), dimension(:,:),          intent(in   ) :: p_lay, t_lay !< pressure [Pa], temperature [K] at layer centers (ncol,nlay)
    real(FT), dimension(:,:),          intent(in   ) :: p_lev        !< pressure at levels/interfaces [Pa] (ncol,nlay+1)
    real(FT), dimension(:),            intent(in   ) :: t_sfc     !< surface temperature           [K]  (ncol)
    real(FT), dimension(:,:),          intent(in   ) :: sfc_emis  !< emissivity at surface         []   (nband, ncol)
    class(ty_optical_props_arry),      intent(in   ) :: cloud_props !< cloud optical properties (ncol,nlay,ngpt)
    class(ty_fluxes),                  intent(inout) :: allsky_fluxes, clrsky_fluxes

    ! Optional inputs
    class(ty_optical_props_arry),  &
              optional,       intent(in ) :: aer_props   !< aerosol optical properties
    real(FT), dimension(:,:), &
              optional,       intent(in ) :: col_dry !< Molecular number density (ncol, nlay)
    real(FT), dimension(:,:), target, &
              optional,       intent(in ) :: t_lev     !< temperature at levels [K] (ncol, nlay+1)
    real(FT), dimension(:,:), target, &
              optional,       intent(in ) :: inc_flux   !< incident flux at domain top [W/m2] (ncol, ngpts)
    integer,  optional,       intent(in ) :: n_gauss_angles ! Number of angles used in Gaussian quadrature (no-scattering solution)
    character(len=128)                    :: error_msg
    ! --------------------------------
    ! Local variables
    !
    class(ty_optical_props_arry), allocatable :: optical_props
    type(ty_source_func_lw)                   :: sources

    integer :: ncol, nlay, ngpt, nband, nstr
    logical :: top_at_1
    ! --------------------------------
    ! Problem sizes
    !
    error_msg = ""

    ncol  = size(p_lay, 1)
    nlay  = size(p_lay, 2)
    ngpt  = k_dist%get_ngpt()
    nband = k_dist%get_nband()

    top_at_1 = p_lay(1, 1) < p_lay(1, nlay)

    ! ------------------------------------------------------------------------------------
    !  Error checking
    !
    if(present(aer_props)) then
      if(any([aer_props%get_ncol(), &
              aer_props%get_nlay()] /= [ncol, nlay])) &
        error_msg = "rrtmpg_lw: aerosol properties inconsistently sized"
      if(.not. any(aer_props%get_ngpt() /= [ngpt, nband])) &
        error_msg = "rrtmpg_lw: aerosol properties inconsistently sized"
    end if

    if(present(t_lev)) then
      if(any([size(t_lev, 1), &
              size(t_lev, 2)] /= [ncol, nlay+1])) &
        error_msg = "rrtmpg_lw: t_lev inconsistently sized"
    end if

    if(present(inc_flux)) then
      if(any([size(inc_flux, 1), &
              size(inc_flux, 2)] /= [ncol, ngpt])) &
        error_msg = "rrtmpg_lw: incident flux inconsistently sized"
    end if
    if(len_trim(error_msg) > 0) return

    ! ------------------------------------------------------------------------------------
    ! Optical properties arrays
    !
    select type(cloud_props)
      class is (ty_optical_props_1scl) ! No scattering
        allocate(ty_optical_props_1scl::optical_props)
      class is (ty_optical_props_2str)
        allocate(ty_optical_props_2str::optical_props)
      class is (ty_optical_props_nstr)
        allocate(ty_optical_props_nstr::optical_props)
        nstr = size(cloud_props%tau,1)
    end select

    error_msg = optical_props%init(k_dist)
    if(len_trim(error_msg) > 0) return
    select type (optical_props)
      class is (ty_optical_props_1scl) ! No scattering
        error_msg = optical_props%alloc_1scl(ncol, nlay)
      class is (ty_optical_props_2str)
        error_msg = optical_props%alloc_2str(ncol, nlay)
      class is (ty_optical_props_nstr)
        error_msg = optical_props%alloc_nstr(nstr, ncol, nlay)
    end select
    if (error_msg /= '') return

    !
    ! Source function
    !
    error_msg = sources%init(k_dist)
    error_msg = sources%alloc(ncol, nlay)
    if (error_msg /= '') return
    ! ------------------------------------------------------------------------------------
    ! Clear skies
    !
    ! Gas optical depth -- pressure need to be expressed as Pa
    !
    error_msg = k_dist%gas_optics(p_lay, p_lev, t_lay, t_sfc, gas_concs, &
                                  optical_props, sources,                &
                                  col_dry, t_lev)
    if (error_msg /= '') return
    ! ----------------------------------------------------
    ! Clear sky is gases + aerosols (if they're supplied)
    !
    if(present(aer_props)) error_msg = aer_props%increment(optical_props)
    if(error_msg /= '') return

    error_msg = base_rte_lw(optical_props, top_at_1, sources, &
                            sfc_emis, clrsky_fluxes,          &
                            inc_flux, n_gauss_angles)
    if(error_msg /= '') return
    ! ------------------------------------------------------------------------------------
    ! All-sky fluxes = clear skies + clouds
    !
    error_msg = cloud_props%increment(optical_props)
    if(error_msg /= '') return

    error_msg = base_rte_lw(optical_props, top_at_1, sources, &
                            sfc_emis, allsky_fluxes,          &
                            inc_flux, n_gauss_angles)

    call sources%finalize()
  end function rte_lw
  ! --------------------------------------------------
  function rte_sw(k_dist, gas_concs, p_lay, t_lay, p_lev, &
                                 mu0, sfc_alb_dir, sfc_alb_dif, cloud_props, &
                                 allsky_fluxes, clrsky_fluxes,           &
                                 aer_props, col_dry, inc_flux, tsi_scaling) result(error_msg)
    class(ty_gas_optics),              intent(in   ) :: k_dist       !< derived type with spectral information
    type(ty_gas_concs),                intent(in   ) :: gas_concs    !< derived type encapsulating gas concentrations
    real(FT), dimension(:,:),          intent(in   ) :: p_lay, t_lay !< pressure [Pa], temperature [K] at layer centers (ncol,nlay)
    real(FT), dimension(:,:),          intent(in   ) :: p_lev        !< pressure at levels/interfaces [Pa] (ncol,nlay+1)
    real(FT), dimension(:  ),          intent(in   ) :: mu0          !< cosine of solar zenith angle
    real(FT), dimension(:,:),          intent(in   ) :: sfc_alb_dir, sfc_alb_dif
                                                        !  surface albedo for direct and diffuse radiation (band, col)
    class(ty_optical_props_arry),      intent(in   ) :: cloud_props !< cloud optical properties (ncol,nlay,ngpt)
    class(ty_fluxes),                  intent(inout) :: allsky_fluxes, clrsky_fluxes

    ! Optional inputs
    class(ty_optical_props_arry),   target, &
              optional,       intent(in ) :: aer_props   !< aerosol optical properties
    real(FT), dimension(:,:), &
              optional,       intent(in ) :: col_dry, &  !< Molecular number density (ncol, nlay)
                                             inc_flux    !< incident flux at domain top [W/m2] (ncol, ngpts)
    real(FT), optional,       intent(in ) :: tsi_scaling !< Optional scaling for total solar irradiance

    character(len=128)                    :: error_msg
    ! --------------------------------
    ! Local variables
    !
    class(ty_optical_props_arry), allocatable :: optical_props
    real(FT), dimension(:,:),     allocatable :: toa_flux
    integer :: ncol, nlay, ngpt, nband, nstr
    logical :: top_at_1
    ! --------------------------------
    ! Problem sizes
    !
    error_msg = ""

    ncol  = size(p_lay, 1)
    nlay  = size(p_lay, 2)
    ngpt  = k_dist%get_ngpt()
    nband = k_dist%get_nband()

    top_at_1 = p_lay(1, 1) < p_lay(1, nlay)

    ! ------------------------------------------------------------------------------------
    !  Error checking
    !
    if(present(inc_flux) .and. present(tsi_scaling)) &
      error_msg = "rrtmpg_sw: only one of inc_flux, tsi_scaling may be supplied."

    if(present(aer_props)) then
      if(any([aer_props%get_ncol(), &
              aer_props%get_nlay()] /= [ncol, nlay])) &
        error_msg = "rrtmpg_sw: aerosol properties inconsistently sized"
      if(.not. any(aer_props%get_ngpt() /= [ngpt, nband])) &
        error_msg = "rrtmpg_sw: aerosol properties inconsistently sized"
    end if

    if(present(tsi_scaling)) then
      if(tsi_scaling <= 0._wp) &
        error_msg = "rrtmpg_sw: tsi_scaling is < 0"
    end if

    if(present(inc_flux)) then
      if(any([size(inc_flux, 1), &
              size(inc_flux, 2)] /= [ncol, ngpt])) &
        error_msg = "rrtmpg_sw: incident flux inconsistently sized"
    end if
    if(len_trim(error_msg) > 0) return

    ! ------------------------------------------------------------------------------------
    !
    ! Optical properties arrays
    !
    select type(cloud_props)
      class is (ty_optical_props_1scl) ! No scattering
        allocate(ty_optical_props_1scl::optical_props)
      class is (ty_optical_props_2str)
        allocate(ty_optical_props_2str::optical_props)
      class is (ty_optical_props_nstr)
        allocate(ty_optical_props_nstr::optical_props)
        nstr = cloud_props%get_nmom()
    end select

    error_msg = optical_props%init(k_dist%get_band_lims_wavenumber(), &
                                   k_dist%get_band_lims_gpoint())
    if(len_trim(error_msg) > 0) return
    select type (optical_props)
      class is (ty_optical_props_1scl) ! No scattering
        error_msg = optical_props%alloc_1scl(ncol, nlay)
      class is (ty_optical_props_2str)
        error_msg = optical_props%alloc_2str(ncol, nlay)
      class is (ty_optical_props_nstr)
        error_msg = optical_props%alloc_nstr(nstr, ncol, nlay)
    end select
    if (error_msg /= '') return

    allocate(toa_flux(ncol, ngpt))
    ! ------------------------------------------------------------------------------------
    ! Clear skies
    !
    ! Gas optical depth -- pressure need to be expressed as Pa
    !
    error_msg = k_dist%gas_optics(p_lay, p_lev, t_lay, gas_concs,  &
                                  optical_props, toa_flux,                          &
                                  col_dry)
    if (error_msg /= '') return
    !
    ! If users have supplied an incident flux, use that
    !
    if(present(inc_flux))    toa_flux(:,:) = inc_flux(:,:)
    if(present(tsi_scaling)) toa_flux(:,:) = toa_flux(:,:) * tsi_scaling
    ! ----------------------------------------------------
    ! Clear sky is gases + aerosols (if they're supplied)
    !
    if(present(aer_props)) error_msg = aer_props%increment(optical_props)
    if(error_msg /= '') return

    error_msg = base_rte_sw(optical_props, top_at_1, &
                               mu0, toa_flux,                   &
                               sfc_alb_dir, sfc_alb_dif,        &
                               clrsky_fluxes)

    if(error_msg /= '') return
    ! ------------------------------------------------------------------------------------
    ! All-sky fluxes = clear skies + clouds
    !
    error_msg = cloud_props%increment(optical_props)
    if(error_msg /= '') return

    error_msg = base_rte_sw(optical_props, top_at_1,  &
                               mu0, toa_flux,                   &
                               sfc_alb_dir, sfc_alb_dif,        &
                               allsky_fluxes)

  end function rte_sw

end module mo_rrtmgp_clr_all_sky


 PROGRAM Simpact
 !***********************************************************************
 !                        -  S I M P A C T  -
 !                   AN EXPLICIT FINITE ELEMENT PROGRAM
 !
 !          GROUP OF NUMERICAL METHODS IN STRUCTURAL MECHANICS
 !                        CORDOBA, 1994-2013
 !     INTERNATIONAL CENTER FOR NUMERICAL METHODS IN ENGINEERING
 !                        BARCELONA, 1992-2011
 !                           QUANTECH ATZ,
 !                        Barcelona, 1998-2011
 !---------------------------------------------------------------------------
 !     Dr. F.Flores - Main developer and Managment - GMNME- UNC - Argentina
 !---------------------------------------------------------------------------
 !***********************************************************************
!#if UNIX
!   USE ifport, ONLY : BEEPQQ  !call atention in interactive mode
!#else
!   USE DFLIB, ONLY : BEEPQQ  !call atention in interactive mode
!#endif
   ! Global data bases
   USE param_db,ONLY : milb, mich                       !Global parameters
   USE ctrl_db, ONLY : ttime ,dtime,endtm,numct,ptype,nstra,text,ndofn   !global control parameters
   USE lispa0,  ONLY : ludat,lures              !
   USE outp_db, ONLY : nreqd,nreqv,nreqa,nreqc,ncdis,toutd,iwrit,time,timed,cpui    !output asked, frequencies
   USE meshmo_db,ONLY: r_meshmo,ntrmstra   !mesh modifications database

   USE export_db, ONLY : export, neset              !export data
   USE gvar_db, ONLY : actchk,static
   USE name_db, ONLY : gen_data_file
   IMPLICIT NONE

   !Functions
   CHARACTER(len=mich):: inttoch   !Puts an integer into a string

   !Variables
   CHARACTER(len=milb):: actio='NEW', ptold=''
   INTEGER  (kind=4) :: ircon=0, &  ! counter of restart files
                        nrest,   &  ! restart dumping period
                        kstep
   INTEGER  (kind=4) :: istop=0, &  ! termination/error flag
                        ecdis=0, &  ! control DOF for output
                        dumi!,    &  ! auxiliar
                        !nprocc=1    ! number of processors

   LOGICAL ::           actmsh=.FALSE.   &  ! .TRUE. if mesh modification required in step
                       ,endmsh=.FALSE.   &  ! .TRUE. if mesh modification required at end step
                       ,actrst=.FALSE.      ! .TRUE. if restart file must be written

   INTEGER (kind=4) chnode          ! changes from node Label to internal node number

   INTERFACE
     INCLUDE 'byebye.h'
     INCLUDE 'closef.h'
     INCLUDE 'outdyn.h'
   END INTERFACE

   ! ==============================================================
   !     INITIALIZATION PHASE
   ! ==============================================================

   CALL beginp(actio,nrest,cpui,kstep)

   !  actio
   !     assigned in beginp:
   !     NEW     - new problem
   !     RESTAR  - restart an old problem (no changes or minor)
   !     NSTRA0  - restart an old problem with a new strategy
   !
   !     can be changed later to:
   !     NSTRA1  - a new strategy will involve change of boundary conditions without changing nodes
   !     NSTRA2  - a new strategy will involve change of both boundary conditions and nodes
   !     STOP    - stop the program
   !     MESHMO  - mesh modifications in step

   IF (TRIM(actio) == 'NEW')THEN
     CALL timing(19,1)    !initializes CPU time for the current model
     CALL newprb()        !set output file name root
   ELSE   !OLD problem
     CALL restar(ircon,actmsh,endmsh)     ! read the problem from a re-start file
     ! check if the restart file corresponds to the end of the strategy ==> modify ACTIO
     IF (TRIM(actio) == 'RESTAR' .AND. ttime + dtime/2d0 >= endtm ) actio='NSTRA0'
     IF (TRIM(actio) == 'RESTAR' ) THEN
       CALL wrtpos(1)                       ! write data for post-processing
     END IF
     IF (actmsh) THEN                     ! TRUE if remesh is active before restart
       actio = 'MESHMO'                   ! if restart from remesh in last step before
     END IF
   END IF

   IF (nrest > 0) CALL timerst(.TRUE.,nrest,actrst)   !Initialize time for writing restart file

   DO ! loop over strategies  =====================================

      !           Initialization of a new problem/strategy

      CALL timing(1,1)                    !initializes time for Initial computations
      !IF new strategy with model changes or mesh modifications
      IF (TRIM(actio) /= 'NEW' .AND. TRIM(actio) /= 'RESTAR' ) THEN
        ircon=0     !initializes RESTART counter
        CALL newstr(actio) !Check beginning of a new strategy ==> ACTIO & PTYPE
        CALL timing(18,1)                      !init time for Closing files
        IF(.NOT.actchk)CALL closef(nreqd,nreqv,nreqa,nreqc,numct) !close files for the previous strategy
        CALL timing(18,2)                      !end time for closing files
        IF (TRIM(actio) == 'STOP') EXIT        !EXIT if erroneous data
        IF (endmsh) THEN    ! Mesh modification at end of previous strategy for new one
          CALL timing(11,1)
          WRITE(*,"(/,19x,'*** INITIALIZING NEW STAGE ANALYSIS ***',/)")
          actio = 'NSTRA2'       !nodes are changed
          CALL timing(11,2)
        END IF

      END IF

      SELECT CASE (ptype)

      CASE ("EXPLCT") !EXPLiCiT time integration

        SELECT CASE ( TRIM(actio) )

        CASE ('NEW','NSTRA0','NSTRA2')

          CALL data_inp(actio)

        CASE ('MESHMO')

          ! Mesh modification: 'remeshing' or 'refinement'

          CALL timing(11,1)
          IF (ANY(r_meshmo)) THEN
            CALL remesh(inttoch(ntrmstra,0))
          END IF
          actio = 'NSTRA2'   !nodes are changed
          CALL timing(11,2)

        END SELECT

        !=======  Initial calculations  ===================================

        IF(TRIM(actio) /= 'RESTAR') CALL initial_comp(actio,istop)

        IF( actchk )THEN
          ttime = endtm
          actio = 'NSTRA0'
          CYCLE
        END IF

        !=======  Step-by-step solution  =================================

        CALL timing(1,2)

        IF( ncdis > 10 )THEN    !update control equation for output
          dumi = chnode(ncdis/10)
          ecdis = dumi*10 + MOD(ncdis,10)
        ELSE
          ecdis = ncdis
        END IF

        IF(TRIM(actio) /= 'RESTAR') CALL outdyn(.TRUE., actmsh , ecdis)  !initial values for HISTORY

        IF( static ) THEN !pseudo STATIC analysis

          CALL pstatic( ircon,nrest,istop,actio,ecdis )

        ELSE              !standard DYNAMIC analysis

          CALL dynamic(actio,ircon,nrest,kstep,istop,ecdis,actmsh,endmsh)

        END IF

        IF (actmsh) THEN
          IF (ANY(r_meshmo)) THEN
            WRITE( 6,"(5X,'***  START OF REMESH NUMBER ',A)") TRIM(inttoch(ntrmstra+1,0))
            WRITE(55,"(5X,'***  REMESH NUMBER ',A)",ERR=9999) TRIM(inttoch(ntrmstra+1,0))
          END IF
        ELSE
          WRITE( 6,"(5X,'***  END OF STAGE ',A,': ',A,/)") TRIM(inttoch(nstra,0)),text
          WRITE(55,"(5X,'***  END OF STAGE ',A,': ',A,/)",ERR=9999) TRIM(inttoch(nstra,0)),text

          IF( neset > 0 ) CALL export( ) !export selected element sets

          IF (endmsh) THEN ! mesh modification at end strategy
          END IF
        END IF

      CASE ("TRAROT")  !  *******  POSITIONING  *******
        CALL trarot(ecdis,ircon)

      END SELECT

      IF (istop /= 0)EXIT

      ptold = ptype
      IF (actmsh) THEN
         actio = 'MESHMO'
      ELSE
         actio = 'NSTRA0'
      END IF

   END DO  ! end loop over strategies

!=======================================================================
!  ******   ENDING EXECUTION
!=======================================================================
   IF(istop /= 0) THEN
      WRITE(* ,"(/,20x,'*** END PROGRAM - PROBLEMS DETECTED ***',/)")
      WRITE(55,"(/,20x,'*** END PROGRAM - PROBLEMS DETECTED ***',/)",ERR=9999)
      WRITE(55,"(/,22x,'*** ERRONEOUS RESULTS POSSIBLY ***',/)",ERR=9999)
   ELSE
      WRITE(* ,"(/,23x,'*** NORMAL END OF EXECUTION ***',/)")
      WRITE(55,"(/,23x,'*** NORMAL END OF EXECUTION ***',/)",ERR=9999)
   END IF
   CALL timing(19,2)
   CALL byebye(time)
   !CALL debtime(timed(1))
   IF( gen_data_file )THEN
     CLOSE(ludat,STATUS='delete')  !PROGRAM.dat file
   ELSE
     CLOSE(ludat,STATUS='keep')    !Users data file
   END IF
   CLOSE(lures,STATUS='KEEP') !
   CLOSE (55)                 !extended report file
   CLOSE (58)                 !debug file for developers

   CALL BEEPQQ(5000,50)  !call atention
   STOP
 ! -----------------------
 9999 CALL runen2('ERROR WHILE WRITING "REP" FILE.')

 END PROGRAM Simpact


	subroutine flip_events(numb,srate,outunit,outshort,ipres,name$,
     $				convert,psftopa)
c
c put array size parameters in include file - BMS Aug 4 2005

c name$ passed in as 80 characters - BMS Aug 23 2004
c
c Increase noinfl (again) - the possible size of the input file - July 16 2002

c  Mets code - remove plotting option - BMS May 18 2002
c
c takes the points defined by find events and does loudness calculation
c of each "event" (but doesn't flip anything - any more than FLIP does now).
c Also do "first half" and "second half" - whatever that means for multi-peak
c waves, but Jack still believes in asymmetry (possibly because he can spell it)
c
c		created from FLIP_SHORT.FOR
c                                                BMS Sept 8 1993
c
c We have room for 2**17 data points
c        parameter (exponent = 17)
c        parameter (power2 = 131072)
c        parameter (halfp2a1 = 65537)
c parameters now in include file
	include 'sigpair_size.inc'

c stuff to pass to the loudness routines
	integer outunit,outshort
	character*80 name$

c LFULL tells whether it's a fullwave or a half wave analysis
	logical lasym,lfull,lmv
	common /yessym/ lasym,lfull,lmv

c do we plot?
	logical lplot
	common /doplot/ lplot

c need to store the unprocessed array somewhere
        real a(power2),unp(power2),aplot(power2)
        common /nwavearray/ a,unp
c
c pity idelay_used is in this common block, but so it goes
        logical linv_used
        character*80 inv_name, orig_name
        character*1 cans
        character*8 ntime
        character*9 ndate
        common /footer/ linv_used, inv_name, orig_name, srate_inv_used,
     $             idelay_used, ntime, ndate
c
c pass in common the NINFL time and pressure pairs used to define this wave
        parameter (noinflp = 10000)
        real*4 press(noinflp), atime(noinflp)
        common /boomcom/ press,atime,ninfl,srate_boom
c
        common /flippts/ ifilter,indexmiddle,izerobetween,
     $       indexminmiddle,indexnomzero,indexpeak,indexotherpeak,
     $       indexstart,indexfirstknee,indexend,indexlastknee,
     $       tfirstknee,pfirstknee,tlastknee,plastknee,
     $	     tfirstpeaknom,pfirstpeaknom,tlastpeaknom,plastpeaknom,
     $	     tstartnom,tendnom
c
c
c new common block for the variables defined in FIND_EVENTS
        parameter (max_events = 50)
        common /def_events/ num_events,ievents(max_events),
     $         itype_events(max_events),
     $         istart_events(max_events),iend_events(max_events)
c
c first do "front" and "back" "halves" (expansion and contraction phases)
c but where is the cross-over?  depends on zero crossings between +ve
c and -ve peaks, and let's hope there's only one such! If there's more than one
c use the one after the last +ve peak.  So start at the back to find it?
c Find type 0 between -ve and +ve peaks (using reverse order)

c find a +ve peak starting at the back
	now_event=num_events
	do while (now_event .gt. 1 .and.
     $                    itype_events(now_event) .le. 0)
	   now_event = now_event-1
	enddo
c now go the other way to find a zero crossing
	do while (now_event .le. num_events .and.
     $                    itype_events(now_event) .ne. 0)
	   now_event = now_event+1
	enddo
c by now now_event should be the zero crossing point (if there was one)
	if (now_event .lt. num_events) then
	   ifilter = 0
	   izerobetween = ievents(now_event)
	   call flip(numb,srate,outunit,outshort,ipres,name$,
     $				convert,psftopa)
	else
	   print *,' Couldn''t find the ''zero crossing point'''
	endif

c now process the (unpredictable number of) events of the wave-form;
	lfull = .false.
	iamnow = 0
	do now_event=1,num_events

	   if (abs(itype_events(now_event)) .eq. 99) then
	      print
     $  *,'A peak crosses zero (type ',itype_events(now_event),' )'
	      print *,'I cannot handle that yet'
	   else if (itype_events(now_event) .ne. 0) then
c we have a peak
	      now_start=istart_events(now_event)
	      now_end=iend_events(now_event)
c
c replace everything in the A array before & after the peak with the value the
c pressure waveform has there but keep the number of points the same.
	      if (now_start .le. 0) then
	         print *,'No start point'
	      else if (now_end .le. 0) then
	         print *,'No end point'
	      else if (now_end .gt. numb) then
	         print *,'Insane end point',now_end
	      else
	         do i=1,now_start-1
	            a(i) = unp(now_start)
	         enddo
	         do i=now_start,now_end
	            a(i) = unp(i)
	         enddo
	         do i=now_end+1,numb
	            a(i) = unp(now_end)
	         enddo
	         iamnow = iamnow+1
	         write (outunit,*) iamnow,' event at #',ievents(now_event)
c operate on the whole signal
	         newnumb = numb
c plot a signal in the original units (pseudo-volts; actually almost PSF - I'm
c sorry know I didn't stick to them instead of Pascals)
	         if (lplot) then
	            jstart = 1
	            isamp = newnumb
	            do index = 1,newnumb
	               aplot(index) = a(index) / convert
	            enddo
c	            call plot_it_var(aplot,newnumb,jstart,srate,isamp)
	            print *,'HRK'
	            read (*,'(a)') cans
	         endif
	         sigmax = a(1)
	         sigmin = sigmax
	         do index = 2,newnumb
	            sigmax = amax1(sigmax,a(index))
	            sigmin = amin1(sigmin,a(index))
	         enddo

	         call subf7adw_main(outunit,
     $      newnumb,srate,dbpl,dbc,dba,dblin,dbz0,dbz1,dbpln,dba3)
c3     $           newnumb,srate,dbpl,dbc,dba,dblin,dbz0,dbz1,dbpln)
c write out the short form results
	         write (outshort,99) ipres,name$,dbpl,dbc,dba,dblin,
     $           dbz0,dbz1,dbpln,sigmax/psftopa,sigmin/psftopa,newnumb

	      endif
	   endif
	enddo

 99	format (i4,2x,a20,3f7.2,4f8.2,1x,2f7.2,i8)
c3 99	format (i4,2x,a20,3f7.2,4f8.2,1x,3f7.2,i8)

	return
	end


\ simple one-shot ADC
0x40021004 CONSTANT RCC_CFGR
0x40021000 0x18 + CONSTANT RCC-APB2ENR
0x40012400 CONSTANT ADC1
    ADC1 0x00 + CONSTANT ADC1-SR
    ADC1 0x04 + CONSTANT ADC1-CR1
    ADC1 0x08 + CONSTANT ADC1-CR2
    ADC1 0x0C + CONSTANT ADC1-SMPR1
    ADC1 0x10 + CONSTANT ADC1-SMPR2
    ADC1 0x2C + CONSTANT ADC1-SQR1
    ADC1 0x30 + CONSTANT ADC1-SQR2
    ADC1 0x34 + CONSTANT ADC1-SQR3
    ADC1 0x4C + CONSTANT ADC1-DR

: adc-calib ( -- )  \ perform an ADC calibration cycle
  2 bit ADC1-CR2 DUP @ ROT OR SWAP !  BEGIN 2 bit ADC1-CR2 @ AND 0= UNTIL ;

: adc-once ( -- u )  \ read ADC value once
  0 bit ADC1-CR2 DUP @ ROT OR SWAP !  \ set ADON to start ADC
  BEGIN 1 bit ADC1-SR @ AND UNTIL  \ wait UNTIL EOC set
  ADC1-DR @ ;

: adc-init ( -- )  \ initialise ADC
  15 bit RCC_CFGR DUP @ ROT OR SWAP !
  9 bit RCC-APB2ENR DUP @ ROT OR SWAP !  \ set ADC1EN
  23 bit  \ set TSVREFE for vRefInt use
   0 bit OR ADC1-CR2 DUP @ ROT OR SWAP !  \ set ADON to enable ADC
  \ 7.5 cycles sampling time is enough for 18 kΩ to ground, measures as zero
  \ even 239.5 cycles is not enough for 470 kΩ, it still leaves 70 mV residual
  0b111 21 LSHIFT ADC1-SMPR1 DUP @ ROT OR SWAP ! \ set SMP17 to 239.5 cycles for vRefInt
  0b110110110 ADC1-SMPR2 DUP @ ROT OR SWAP ! \ set SMP0/1/2 to 71.5 cycles, i.e. 83 µs/conv
  adc-once DROP ;

: adc# ( pin -- n )  \ convert pin number to adc index
\ nasty way to map the pins (a "c," table offset lookup might be simpler)
\   PA0..7 => 0..7, PB0..1 => 8..9, PC0..5 => 10..15
  DUP io# SWAP  io-port ?DUP IF 1 LSHIFT + 6 + THEN ;

: adc ( pin -- u )  \ read ADC value
\ IMODE-ADC over io-mode!
\ nasty way to map the pins (a "c," table offset lookup might be simpler)
\   PA0..7 => 0..7, PB0..1 => 8..9, PC0..5 => 10..15
  adc# ADC1-SQR3 !  adc-once ;

: adc-vcc ( -- mv )  \ return estimated Vcc, based on 1.2V internal bandgap
3300 1200 17 ADC1-SQR3 ! adc-once */ ;


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!X
!X wrapper for quasicontinuum code to use QUIP potentials
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

module QC_QUIP_Wrapper_module
use system_module, only : dp, system_initialise, INPUT, system_abort,verbosity_push, verbosity_pop, PRINT_SILENT, operator(//), inoutput, PRINT_ALWAYS
use extendable_str_module, only : extendable_str, string, read
use table_module, only : table, wipe, int_part
use atoms_types_module, only : atoms, assign_pointer, add_property
use atoms_module, only : initialise, calc_connect, set_lattice, assignment(=)
use potential_module, only : potential, initialise, finalise, calc
use mpi_context_module, only : mpi_context
implicit none
private

  type (Potential), save :: pot
  type (Atoms), save :: at
  type (MPI_context), save :: mpi_glob

  real(dp), private :: vacuum_dist = 5.0_dp

  public :: verbosity_push, verbosity_pop, PRINT_SILENT
  public :: QC_QUIP_initialise, QC_QUIP_calc,MakeLine
  type (Potential), save :: pot_ip
#if defined(HAVE_LOCAL_E_MIX) || defined(HAVE_ONIOM)
  type (Potential), save :: pot_qm
  public :: QC_QUIP_initialise_hybrid, QC_QUIP_calc_hybrid
#endif

contains

  subroutine MakeLine(str1,real1,str2,real2,strout)
    character(len=*), intent(in)  :: str1,str2
    real(dp),     intent(in) :: real1,real2
    character(len=*), intent(out) :: strout

    strout = trim(str1)//real1//trim(str2)//real2
  end subroutine MakeLine

  subroutine QC_QUIP_initialise(str, err)
    character(len=*), intent(in) :: str
    integer, intent(out), optional :: err

    type(inoutput) :: params
    type(extendable_str) :: params_str

    call system_initialise()
    call Initialise(params, "quip_params.xml", INPUT)
    call Initialise(params_str)
    call read(params_str, params%unit)

    call Initialise(pot, args_str=str, param_str=string(params_str))
    if (present(err)) err = 0
  end subroutine

  subroutine QC_QUIP_calc(Lz, pos, Z, w, local_e, f, err)
    real(dp), intent(in) :: Lz
    real(dp), intent(in) :: pos(:,:)
    integer, intent(in) :: Z(:)
    real(dp), intent(in) :: w(:)
    real(dp), intent(out) :: local_e(:), f(:,:)
    integer, intent(out) :: err

    integer N
    real(dp), pointer :: weight(:)

    if (.not. matching_array_sizes(Z, pos, w, local_e, f, N)) then
      call system_abort("Mismatched array sizes in QC_QUIP_calc")
    endif

    call qc_setup_atoms(at, N, Lz, pos, Z)

    if (.not. assign_pointer(at, "weight", weight)) then
      call add_property(at, "weight", 0.0_dp)
      if (.not. assign_pointer(at, "weight", weight)) call system_abort("QC_QUIP_calc Failed to add weight property to at")
      weight = w
    endif

    call add_property_from_pointer(at, "local_energy", local_e)
    call add_property_from_pointer(at, "force", f)
    call calc(pot, at, args_str="local_energy force", error=err)

  end subroutine

#if defined(HAVE_LOCAL_E_MIX) || defined(HAVE_ONIOM)
  subroutine QC_QUIP_initialise_hybrid(str_ip, str_qm, str_hybrid, lat, Z, pos, err)
    character(len=*), intent(in) :: str_ip, str_qm, str_hybrid
    real(dp), intent(in), optional :: lat(3,3)
    integer, intent(in), optional :: Z(:)
    real(dp), intent(in), optional :: pos(:,:)
    integer, intent(out), optional :: err

    type(inoutput) :: params
    type(extendable_str) :: params_str
    ! type(atoms) :: bulk
    integer :: n_present

    call system_initialise(enable_timing=.true.)

    call initialise(mpi_glob)

    call initialise(params, "quip_params.xml", INPUT)
    call initialise(params_str)
    call read(params_str, params%unit, convert_to_string=.true., mpi_comm = mpi_glob%communicator, mpi_id=mpi_glob%my_proc)

    ! call initialise(pot_ip, str_ip, string(params_str))
    ! call initialise(pot_qm, str_qm, string(params_str), mpi_obj = mpi_glob)

    call finalise(params_str)

    n_present = count ( (/present(lat), present(Z), present(pos)  /) )
    if (n_present == 3) then
      if (.not. matching_array_sizes(Z, pos = pos)) then
	call system_abort("Mismatched array sizes in QC_QUIP_initialise_hybrid")
      endif
call print("QC_QUIP_initialise_hybrid was passed in bulk structure, ignoring it", PRINT_ALWAYS)
!      call initialise(bulk, size(Z), lat)
!      bulk%Z = Z
!      bulk%pos = pos
!      call initialise(pot, str_hybrid, pot_qm, pot_ip, bulk)
!      call finalise(bulk)
call initialise(pot, str_hybrid//" init_args_pot2="//trim(str_ip)//" init_args_pot1="//trim(str_qm), mpi_obj=mpi_glob)
    else if (n_present == 0) then
      call initialise(pot, str_hybrid//" init_args_pot2="//trim(str_ip)//" init_args_pot1="//trim(str_qm), mpi_obj=mpi_glob)
    else
      call system_abort("QC_QUIP_initialise_hybrid called with some but not all of lat, Z, pos present")
    endif

    call print("QC_QUIP using hybrid potential:")
    call print(pot)

    if (present(err)) err = 0
  end subroutine QC_QUIP_initialise_hybrid

  subroutine QC_QUIP_calc_hybrid(Lz, pos, Z, w, qm_list, local_e, f, qm_region_width, buffer_region_width, err)
    real(dp), intent(in) :: Lz
    real(dp), intent(in) :: pos(:,:)
    integer, intent(in) :: Z(:)
    real(dp), intent(in) :: w(:)
    integer, intent(in) :: qm_list(:)
    real(dp), intent(out) :: local_e(:), f(:,:)
    integer, intent(in) :: qm_region_width, buffer_region_width
    integer, intent(out) :: err

    integer i, N
    real(dp), pointer :: weight(:)
    integer, pointer :: hybrid(:)
    type(table) :: qm_table

    if (.not. matching_array_sizes(Z, pos, w, local_e, f, N)) then
	call system_abort("Mismatched array sizes in QC_QUIP_calc_hybrid")
    endif

    if (buffer_region_width > 0 .and. pot%is_oniom) &
      call system_abort("Don't do buffer_region_width = " // buffer_region_width // &
			 " > 0 with ONIOM")

    call qc_setup_atoms(at, N, Lz, pos, Z)

    call add_property(at, "weight", 0.0_dp)
    call add_property(at, "hybrid", 0)

    if (.not. assign_pointer(at, "weight", weight)) &
      call system_abort("QC_QUIP_calc Failed to add weight property to at")
    if (.not. assign_pointer(at, "hybrid", hybrid)) &
      call system_abort("QC_QUIP_calc Failed to add hybrid property to at")

    call calc_connect(at)

    hybrid = 0
    call wipe(qm_table)
    do i=1, size(qm_list)
      if (qm_list(i) > at%N) call system_abort("QC_QUIP_calc_hybrid got qm_list("//i//")=" &
							      // qm_list(i) // " > at%N="//at%N)
      if (qm_list(i) > 0) call append(qm_table, (/ qm_list(i), 0, 0, 0 /) )
    end do

    hybrid(int_part(qm_table,1)) = 1

    weight = w

    call add_property_from_pointer(at, "local_energy", local_e)
    call add_property_from_pointer(at, "force", f)

    if (pot%is_oniom) then
      call calc(pot, at, args_str="local_energy force calc_weights" // &
	" core_hops="//qm_region_width// " transition_hops=0 buffer_hops="//buffer_region_width, error=err)
    else
      call calc(pot, at, args_str="local_energy force calc_weights" // &
	" core_hops="//qm_region_width// " transition_hops=0 buffer_hops="//buffer_region_width // &
	" solver=DIAG_GF SCF_GLOBAL_U GLOBAL_U=20.0", error=err)
    endif

  end subroutine QC_QUIP_calc_hybrid
#endif

  function matching_array_sizes(Z, pos, w, local_e, f, N)
    integer, intent(in) :: Z(:)
    real(dp), intent(in), optional :: pos(:,:)
    real(dp), intent(in), optional :: w(:)
    real(dp), intent(in), optional :: local_e(:), f(:,:)
    integer, intent(out), optional :: N
    logical :: matching_array_sizes

    integer my_N

    matching_array_sizes = .true.
    my_N = size(Z)
    if (present(N)) N = my_N
    if (present(pos)) then
      if (3 /= size(pos,1) .or. my_N /= size(pos,2)) then
	matching_array_sizes=.false.
	return
      endif
    endif
    if (present(w)) then
      if (my_N /= size(w)) then
	matching_array_sizes=.false.
	return
      endif
    endif
    if (present(local_e)) then
      if (my_N /= size(local_e)) then
	matching_array_sizes=.false.
	return
      endif
    endif
    if (present(f)) then
      if (3 /= size(f,1) .or. my_N /= size(f,2)) then
	matching_array_sizes=.false.
	return
      endif
    endif

  end function matching_array_sizes

  subroutine qc_setup_atoms(at, N, Lz, pos, Z)
    type(atoms), intent(inout) :: at
    integer, intent(in) :: N
    real(dp), intent(in) :: Lz
    real(dp), intent(in) :: pos(:,:)
    integer, intent(in) :: Z(:)

    real(dp) :: lattice(3,3)

    lattice = 0.0_dp
    lattice(1,1) = maxval(pos(1,:)) - minval(pos(1,:)) + vacuum_dist
    lattice(2,2) = maxval(pos(2,:)) - minval(pos(2,:)) + vacuum_dist
    lattice(3,3) = Lz

    if (at%N /= N) then
      call Initialise(at, N, lattice)
    end if
    call set_lattice(at, lattice, scale_positions=.false.)
    at%pos = pos
    at%Z = Z

    call calc_connect(at)
  end subroutine qc_setup_atoms

end module QC_QUIP_Wrapper_module