cc Copyright (C) 2018-2021: Leslie Greengard, Zydrunas Gimbutas,
cc  Manas Rachh, Travis Askham
cc Contact: greengard@cims.nyu.edu
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the GNU General Public License as published by
cc the Free Software Foundation; either version 2 of the License, or
cc (at your option) any later version.  This program is distributed in
cc the hope that it will be useful, but WITHOUT ANY WARRANTY; without
cc even the implied warranty of MERCHANTABILITY or FITNESS FOR A
cc PARTICULAR PURPOSE.  See the GNU General Public License for more
cc details. You should have received a copy of the GNU General Public
cc License along with this program;
cc if not, see <http://www.gnu.org/licenses/>.
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    $Date$
c    $Revision$
      subroutine mbhfmm2d(nd,eps,beta,ns,sources,ifcharge,charge,
     1     ifdipole,dipstr,dipvec,ifquadpole,quadstr,quadvec,ifoctpole,
     2     octstr,octvec,iper,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,
     3     pottarg,gradtarg,hesstarg,ier)
c----------------------------------------------
c     FMM for the modified biharmonic Green's
c     function
c
c         G(x,y) = (S_beta(r) - S_0(r))/beta^2
c
c     where S_beta(r) = K_0(beta r)/(2*pi) is the fundamental solution
c     of the Yukawa equation and S_0(r) = log(r)/(2*pi) is the
c     fundamental solution of the Laplace equation, with
c     r = sqrt( (x(1)-y(1))**2 + (x(2)-y(2))**2 )
c
c     The expansions represent the sum
c
c     u(x) = sum_j charge(j)*G(x,y(j))
c     + dipstr(j)*(G_{y1}(x,y(j))*dipvec(1,j) + G_{y2}*dipvec(2,j))
c     + quadstr(j)*(G_{y1y1}(x,y(j))*quadvec(1,j)
c             + G_{y1y2}*quadvec(2,j) + G_{y2y2}*quadvec(2,j))
c     + octstr(j)*(G_{y1y1y1}(x,y(j))*octvec(1,j)
c             + G_{y1y1y2}*octvec(2,j) + G_{y1y2y2}*octvec(2,j)
c             + G_{y1y2y2}*octvec(2,j))
c
c     INPUT PARAMETERS:
c
c   nd            : number of expansions
c   eps           : FMM precision requested
c   zk            : Helmholtz parameter
c   ns            : number of sources
c   sources(2,ns) : source locations
c   ifcharge      : flag for including charge interactions
c                   charge interactions included if ifcharge =1
c                   not included otherwise
c   charge(nd,ns)    : charge strengths
c   ifdipole      : flag for including dipole interactions
c                   dipole interactions included if ifdipole =1
c                   not included otherwise
c   dipstr(nd,ns)    : dipole strengths
c   dipvec(nd,2,ns)  : dipole orientation vectors
c   ifquadpole      : flag for including quadrupole interactions
c                   quadrupole interactions included if ifquadpole =1
c                   not included otherwise
c   quadstr(nd,ns)    : quadrupole strengths
c   quadvec(nd,3,ns)  : quadrupole orientation vectors
c   ifoctpole      : flag for including octopole interactions
c                   octopole interactions included if ifoctpole =1
c                   not included otherwise
c   octstr(nd,ns)    : octopole strengths
c   octvec(nd,4,ns)  : octopole orientation vectors
c   iper          : flag for periodic implmentations. Currently unused
c   ifpgh         : flag for computing pot/grad/hess
c                   ifpgh = 1, only potential is computed
c                   ifpgh = 2, potential and gradient are computed
c                   ifpgh = 3, potential, gradient, and hessian
c                   are computed
c   nt            : number of targets
c   targ(2,nt)    : target locations
c   ifpghtarg     : flag for computing pottarg/gradtarg/hesstarg
c                   ifpghtarg = 1, only potential is computed at targets
c                   ifpghtarg = 2, potential and gradient are
c                   computed at targets
c                   ifpghtarg = 3, potential, gradient, and hessian are
c                   computed at targets
c
c   OUTPUT PARAMETERS
c   pot(nd,*)       : potential at the source locations
c   grad(nd,2,*)    : gradients at the source locations
c   hess(nd,3,*)    : hessian at the source locations
c   pottarg(nd,*)   : potential at the target locations
c   gradtarg(nd,2,*): gradient at the target locations
c   hesstarg(nd,3,*): hessian at the target locations
c   ier             : error code
c

      implicit none
c
cc      calling sequence variables
c
      integer nd, ifcharge, ifdipole, ifquadpole, ifoctpole
      integer iper
      real *8 eps
      real *8 beta
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      real *8 dipvec(nd,2,*)
      real *8 charge(nd,*),dipstr(nd,*)
      real *8 quadvec(nd,3,*),quadstr(nd,*)
      real *8 octvec(nd,4,*),octstr(nd,*)

      real *8 pot(nd,*),grad(nd,2,*),hess(nd,3,*)
      real *8 pottarg(nd,*),gradtarg(nd,2,*),hesstarg(nd,3,*)

c
cc      Tree variables
c
      integer, allocatable :: itree(:)
      integer iptr(8)
      integer nlmin,nlmax,ifunif
      real *8, allocatable :: tcenters(:,:),boxsize(:)
      integer nexpc,ntj
      real *8 expc(2)
      real *8 scj
      integer idivflag,nlevels,nboxes,ndiv
      integer ltree

      real *8, allocatable :: radsrc(:)
      real *8 radexp

c
cc     sorted arrays
c
      integer, allocatable :: isrc(:),isrcse(:,:)
      integer, allocatable :: itarg(:),itargse(:,:)
      real *8, allocatable :: sourcesort(:,:)
      real *8, allocatable :: targsort(:,:)

      complex *16, allocatable :: mbhmps(:,:,:), ymps(:,:,:)
      complex *16, allocatable :: mbhmpssort(:,:,:), ympssort(:,:,:)

      real *8, allocatable :: potsort(:,:),gradsort(:,:,:),
     1     hesssort(:,:,:)
      real *8, allocatable :: pottargsort(:,:),gradtargsort(:,:,:),
     1     hesstargsort(:,:,:)

c
cc     additional fmm variables

      integer lmptot, ldc
      real *8, allocatable :: rscales(:)
      integer, allocatable :: nterms(:),iaddr(:,:)
      real *8, allocatable :: rmlexp(:),carray(:,:)

c
cc      temporary variables
c
      integer i,ilev,lmptmp,nmax,idim,j,l
      integer ifpgh,ifpghtarg,ifprint,iert
      integer ntermsmps,ndtmp,nterms1
      real *8 time1,time2,pi,done
      real *8 omp_get_wtime
      complex *16 zk, eye
      data eye /(0.0d0,1.0d0)/

      done = 1
      pi = atan(done)*4.0d0

      zk = beta*eye

      nexpc = 0

      nlevels = 0
      nboxes = 0
      idivflag =0
      ndiv = 20
      ltree = 0
      nlmin = 0
      nlmax = 51
      ifunif = 0
      iper = 0

      ifprint = 1

c
cc      call the tree memory management
c       code to determine number of boxes,
c       number of levels and length of tree
c

      call pts_tree_mem(sources,ns,targ,nt,idivflag,ndiv,nlmin,nlmax,
     1  ifunif,iper,nlevels,nboxes,ltree)

      allocate(itree(ltree))
      allocate(boxsize(0:nlevels))
      allocate(tcenters(2,nboxes))

c
c       call the tree code
c

      call pts_tree_build(sources,ns,targ,nt,idivflag,ndiv,nlmin,nlmax,
     1  ifunif,iper,nlevels,nboxes,ltree,itree,iptr,tcenters,boxsize)

      allocate(isrc(ns),isrcse(2,nboxes))
      allocate(itarg(nt),itargse(2,nboxes))

      call pts_tree_sort(ns,sources,itree,ltree,nboxes,nlevels,iptr,
     1   tcenters,isrc,isrcse)

      call pts_tree_sort(nt,targ,itree,ltree,nboxes,nlevels,iptr,
     1   tcenters,itarg,itargse)
      allocate(sourcesort(2,ns))
      allocate(targsort(2,nt))

      ntermsmps=0
      if (ifdipole .eq. 1) ntermsmps = 1
      if (ifquadpole .eq. 1) ntermsmps = 2
      if (ifoctpole .eq. 1) ntermsmps = 3

      call prinf('ntermsmp *',ntermsmps,1)

      allocate(mbhmps(nd,0:ntermsmps,ns),
     1     ymps(nd,0:ntermsmps,ns))

      allocate(mbhmpssort(nd,0:ntermsmps,ns),
     1     ympssort(nd,0:ntermsmps,ns))

      do i = 1,ns
         do j = 0,ntermsmps
            do l = 1,nd
               mbhmps(l,j,i)=0
               ymps(l,j,i)=0
            enddo
         enddo
      enddo

      call mbh2dconvtomp_vec(nd,beta,ns,ifcharge,charge,
     1     ifdipole,dipstr,dipvec,ifquadpole,quadstr,quadvec,
     2     ifoctpole,octstr,octvec,ntermsmps,mbhmps,ymps)

      if(ifpgh.eq.1) then
        allocate(potsort(nd,ns),gradsort(nd,2,1),hesssort(nd,3,1))
      else if(ifpgh.eq.2) then
        allocate(potsort(nd,ns),gradsort(nd,2,ns),hesssort(nd,3,1))
      else if(ifpgh.eq.3) then
        allocate(potsort(nd,ns),gradsort(nd,2,ns),hesssort(nd,3,ns))
      else
        allocate(potsort(nd,1),gradsort(nd,2,1),hesssort(nd,3,1))
      endif

      if(ifpghtarg.eq.1) then
        allocate(pottargsort(nd,nt),gradtargsort(nd,2,1),
     1     hesstargsort(nd,3,1))
      else if(ifpghtarg.eq.2) then
        allocate(pottargsort(nd,nt),gradtargsort(nd,2,nt),
     1      hesstargsort(nd,3,1))
      else if(ifpghtarg.eq.3) then
        allocate(pottargsort(nd,nt),gradtargsort(nd,2,nt),
     1     hesstargsort(nd,3,nt))
      else
        allocate(pottargsort(nd,1),gradtargsort(nd,2,1),
     1     hesstargsort(nd,3,1))
      endif

c
cc      initialize potentials,hessians,gradients
c

      if(ifpgh.eq.1) then
        do i=1,ns
          do idim=1,nd
            potsort(idim,i) = 0
          enddo
        enddo
      endif

      if(ifpgh.eq.2) then
        do i=1,ns
          do idim=1,nd
            potsort(idim,i) = 0
            gradsort(idim,1,i) = 0
            gradsort(idim,2,i) = 0
          enddo
        enddo
      endif

      if(ifpgh.eq.3) then
        do i=1,ns
          do idim=1,nd
            potsort(idim,i) = 0
            gradsort(idim,1,i) = 0
            gradsort(idim,2,i) = 0
            hesssort(idim,1,i) = 0
            hesssort(idim,2,i) = 0
            hesssort(idim,3,i) = 0
          enddo
        enddo
      endif

      if(ifpghtarg.eq.1) then
        do i=1,nt
          do idim=1,nd
            pottarg(idim,i) = 0
            pottargsort(idim,i) = 0
          enddo
        enddo
      endif

      if(ifpghtarg.eq.2) then
        do i=1,nt
          do idim=1,nd
            pottargsort(idim,i) = 0
            gradtargsort(idim,1,i) = 0
            gradtargsort(idim,2,i) = 0
          enddo
        enddo
      endif

      if(ifpghtarg.eq.3) then
        do i=1,nt
          do idim=1,nd
            pottargsort(idim,i) = 0
            gradtargsort(idim,1,i) = 0
            gradtargsort(idim,2,i) = 0
            hesstargsort(idim,1,i) = 0
            hesstargsort(idim,2,i) = 0
            hesstargsort(idim,3,i) = 0
          enddo
        enddo
      endif

c
cc      compute scaling factor for multipole/local expansions
c       and lengths of multipole and local expansions
c
      allocate(rscales(0:nlevels),nterms(0:nlevels))

      nmax = 0
      ier = 0
      do i=0,nlevels
        rscales(i) = min(abs(zk*boxsize(i)/(2.0d0*pi)),1.0d0)
        call l2dterms(eps,nterms1,ier)
        nterms(i) = nterms1
        if(nterms(i).gt.nmax) nmax = nterms(i)
      enddo

      if(ifprint.eq.1) call prinf('nmax=*',nmax,1)
      if(ifprint.eq.1) call prinf('nterms=*',nterms,nlevels+1)

      ldc = nmax+5
      allocate(carray(0:ldc,0:ldc))
      call mbh2d_init_carray(carray,ldc)

c
c     Multipole and local expansions will be held in workspace
c     in locations pointed to by array iaddr(4,nboxes).
c
c       ... allocate iaddr and temporary arrays
c

      allocate(iaddr(4,nboxes))

c     reorder sources
c
      call dreorderf(2,ns,sources,sourcesort,isrc)
      ndtmp = nd*2*(ntermsmps+1)
      call dreorderf(ndtmp,ns,mbhmps,mbhmpssort,isrc)
      call dreorderf(ndtmp,ns,ymps,ympssort,isrc)

c
cc     reorder targets
c
      call dreorderf(2,nt,targ,targsort,itarg)

c
c
c     allocate memory need by multipole, local expansions at all
c     levels
c     irmlexp is pointer for workspace need by various fmm routines,
c
      call mbh2dmpalloc(nd,itree(iptr(1)),iaddr,nlevels,lmptot,
     1    nterms)
      if(ifprint .eq. 1) call prinf(' lmptot is *',lmptot,1)

      ier = 0
      allocate(rmlexp(lmptot),stat=iert)
      if(iert.ne.0) then
         print *, "Cannot allocate mpole expansion workspace"
         print *, "lmptot=", lmptot
         ier = 4
         return
      endif

c
cc     call the main fmm routine
c

c     Memory allocation is complete.
c     Call main fmm routine
c
      call cpu_time(time1)
C$      time1=omp_get_wtime()
      call mbhfmm2dmain(nd,eps,
     $   beta,ns,sourcesort,
     $   ntermsmps,mbhmpssort,ympssort,
     $   nt,targsort,
     $   iaddr,rmlexp,carray,ldc,
     $   itree,ltree,iptr,ndiv,nlevels,
     $   nboxes,iper,boxsize,rscales,tcenters,itree(iptr(1)),
     $   isrcse,itargse,nterms,
     $   ifpgh,potsort,gradsort,hesssort,
     $   ifpghtarg,pottargsort,gradtargsort,
     $   hesstargsort,ier)
      call cpu_time(time2)
C$        time2=omp_get_wtime()
      if( ifprint .eq. 1 ) call prin2('time in fmm main=*',
     1   time2-time1,1)
      if(ier.ne.0) return

c
cc      resort the output arrays in input order
c

      if(ifpgh.eq.1) then
        call dreorderi(nd,ns,potsort,pot,isrc)
      endif

      if(ifpgh.eq.2) then
        call dreorderi(nd,ns,potsort,pot,isrc)
        call dreorderi(2*nd,ns,gradsort,grad,isrc)
      endif

      if(ifpgh.eq.3) then
        call dreorderi(nd,ns,potsort,pot,isrc)
        call dreorderi(2*nd,ns,gradsort,grad,isrc)
        call dreorderi(3*nd,ns,hesssort,hess,isrc)
      endif

cc      call prini(6,13)
cc      call prin2('eps = *', eps, 1)
c      call prin2('after mbhfmm2dmain, potsort = *', potsort,
c     1     2*nt)
cc      stop

      if(ifpghtarg.eq.1) then
        call dreorderi(nd,nt,pottargsort,pottarg,itarg)
      endif

      if(ifpghtarg.eq.2) then
        call dreorderi(nd,nt,pottargsort,pottarg,itarg)
        call dreorderi(2*nd,nt,gradtargsort,gradtarg,itarg)
      endif

      if(ifpghtarg.eq.3) then
        call dreorderi(nd,nt,pottargsort,pottarg,itarg)
        call dreorderi(2*nd,nt,gradtargsort,gradtarg,itarg)
        call dreorderi(3*nd,nt,hesstargsort,hesstarg,itarg)
      endif

      return
      end

      subroutine mbhfmm2dmain(nd,eps,
     $     beta,nsource,source,
     $     ntermsmps,mbhmps,ymps,
     $     ntarget,target,
     $     iaddr,rmlexp,carray,ldc,
     $     itree,ltree,iptr,ndiv,nlevels,
     $     nboxes,iper,boxsize,rscales,centers,laddr,
     $     isrcse,itargse,nterms,
     $     ifpgh,pot,grad,hess,
     $     ifpghtarg,pottarg,gradtarg,hesstarg,
     $     ier)
c     2D FMM for the modified biharmonic Green's
c     function
c
c         G(x,y) = (S_beta(r) - S_0(r))/beta^2
c
c     where S_beta(r) = K_0(beta r)/(2*pi) is the fundamental solution
c     of the Yukawa equation and S_0(r) = log(r)/(2*pi) is the
c     fundamental solution of the Laplace equation, with
c     r = sqrt( (x(1)-y(1))**2 + (x(2)-y(2))**2 )
c
c     This FMM takes charges to be multipolar expansions
c     of a given length.
c
c   All the source/target related quantities
c   are assumed to be tree-sorted
c
c-----------------------------------------------------------------------
c   INPUT PARAMETERS:
c
c   nd:   number of charge densities
c
c   eps:  FMM precision requested
c
c   beta: real *8, modified biharmonic parameter
c
c     nsource:     integer:  number of sources
c     source: real *8 (2,ns):  source locations
c     ntermsmps:   integer: order of multipolar sources
c     mbhmps:   complex *16(nd,0:ntermsmps,nsource): difference function
c                   type expansion at each source
c     ymps:     complex *16(nd,0:ntermsmps,nsource): Yukawa (modified
c     bessel K) type expansion at each source
c     ntarget: integer:  number of targets
c     target: real *8 (2,ntarget):  target locations
c     iaddr: (4,nboxes): pointer in rmlexp where multipole
c                      and local expansions for each
c                      box is stored
c                      iaddr(1,ibox) is the
c                      starting index in rmlexp for the
c                      difference typ multipole expansion of ibox
c                      iaddr(2,ibox) is the
c                      starting index in rmlexp for the
c                      Yukawa (Bessel K) multipole expansion of ibox
c                      iaddr(3,ibox) is the
c                      starting index in rmlexp for the
c                      difference type local expansion of ibox
c                      and iaddr(4,ibox) is the
c                      starting index in rmlexp
c                      for the Laplace (power series)
c                      local expansion of ibox
c
c   itree    in: integer (ltree)
c             This array contains all the information
c             about the tree
c             Refer to pts_tree2d.f
c
c   ltree    in: integer
c            length of tree
c
c    iptr in: integer(8)
c             iptr is a collection of pointers
c             which points to where different elements
c             of the tree are stored in the itree array
c
c     ndiv    in: integer
c             Max number of chunks per box
c
c     nlevels in: integer
c             number of levels in the tree
c
c
c     nboxes  in: integer
c             number of boxes in the tree
c
c     boxsize in: real*8 (0:nlevels)
c             boxsize(i) is the size of the box from end to end
c             at level i
c
c     iper    in: integer
c             flag for periodic implementation. Currently unused
c
c     centers in: real *8(2,nboxes)
c                 array containing the centers of all the boxes
c
c     isrcse in: integer(2,nboxes)
c               starting and ending location of sources in ibox
c                in sorted list of sources
c
c     itargse in: integer(2,nboxes)
c               starting and ending location of targets in ibox
c                in sorted list of sources
c
c     nterms: (0:nlevels) length of multipole and local expansions
c              at various levels
c     ntj     in: integer
c             order of the output expansions
c
c     ifpgh  in: integer
c             flag for evaluating potential/gradients/hessians
c             at sources.
c             ifpgh = 1, only potentials will be evaluated
c             ifpgh = 2, potentials/gradients will be evaluated
c             ifpgh = 3, potentials/gradients/hessians will be evaluated
c
c     ifpghtarg  in: integer
c             flag for evaluating potential/gradients/hessians
c             at targets.
c             ifpghtarg = 1, only potentials will be evaluated
c             ifpghtarg = 2, potentials/gradients will be evaluated
c             ifpghtarg = 3, potentials/gradients/hessians will be evaluated
c
c
c   OUTPUT
c
c   pot: potential at the source locations
c   grad: gradient at the source locations
c   hess: gradient at the source locations
c
c   pottarg: potential at the target locations
c   gradtarg: gradient at the target locations
c   hesstarg: gradient at the target locations
c------------------------------------------------------------------

      implicit none

      integer nd

      real *8 zi, beta

      integer nsource,ntarget,ier
      integer ndiv,nlevels,ntermsmps

      integer ifpgh,ifpghtarg
      real *8 eps
      integer iper

      real *8 source(2,nsource)

      complex *16 :: mbhmps(nd,0:ntermsmps,nsource)
      complex *16 :: ymps(nd,0:ntermsmps,nsource)

      real *8 target(2,ntarget)

      real *8 pot(nd,*)
      real *8 grad(nd,2,*)
      real *8 hess(nd,3,*)

      real *8 pottarg(nd,*)
      real *8 gradtarg(nd,2,*)
      real *8 hesstarg(nd,3,*)

      integer iaddr(4,nboxes),lmptmp
      real *8 rmlexp(*)

      real *8 timeinfo(10)
      real *8 timelev(0:200)
      real *8 centers(2,*)

      integer laddr(2,0:nlevels)
      integer nterms(0:nlevels)
      integer iptr(8),ltree
      integer isrcse(2,nboxes),itargse(2,nboxes)
      integer itree(*)
      integer nboxes, ldc
      real *8 rscales(0:nlevels),boxsize(0:nlevels)
      real *8 carray(0:ldc,0:ldc)

      real *8 zkiupbound,thresh

      integer nterms_eval(4,0:200)

c     temp variables
      integer i,j,k,l,idim
      integer ibox,jbox,ilev,npts
      integer nchild,nlist1,nlist2,nlist3,nlist4
      integer mnlist1,mnlist2,mnlist3,mnlist4
      integer, allocatable :: list1(:,:),list2(:,:),list3(:,:)
      integer, allocatable :: list4(:,:)
      integer, allocatable :: nlist1s(:),nlist2s(:),nlist3s(:)
      integer, allocatable :: nlist4s(:)

      integer istart,iend,istarts,iends
      integer isstart,isend,jsstart,jsend
      integer jstart,jend
      integer istarte,iende,istartt,iendt

      integer ifprint

      integer ifhesstarg,nn
      real *8 d,time1,time2,omp_get_wtime
      real *8 tt1,tt2
      real *8 pottmp,gradtmp(2),hesstmp(3)

      double precision dlam, pi, boxlam

c     ifprint is an internal information printing flag.
c     Suppressed if ifprint=0.
c     Prints timing breakdown and other things if ifprint=1.
c     Prints timing breakdown, list information, and other things if ifprint=2.
c
      ifprint=1

      pi = 4*atan(1.0d0)
c
c     c
c     upper limit for zk along imaginary axis
      zkiupbound = 40.0d0
      zi = beta

      do i=0,nlevels
         timelev(i) = 0
      enddo

c
c        compute list info
c
      call computemnlists(nlevels,nboxes,itree,ltree,iptr,centers,
     1     boxsize,iper,mnlist1,mnlist2,mnlist3,mnlist4)
      allocate(nlist1s(nboxes),list1(mnlist1,nboxes))
      allocate(nlist2s(nboxes),list2(mnlist2,nboxes))
      allocate(nlist3s(nboxes),list3(mnlist3,nboxes))
      allocate(nlist4s(nboxes),list4(mnlist4,nboxes))

      call computelists(nlevels,nboxes,itree,ltree,iptr,centers,
     1     boxsize,iper,mnlist1,nlist1s,list1,mnlist2,nlist2s,list2,
     2     mnlist3,nlist3s,list3,mnlist4,nlist4s,list4)

c
      do i=1,10
         timeinfo(i)=0
      enddo
c
c       ... set all multipole and local expansions to zero
c
      do ilev = 0,nlevels
C$OMP PARALLEL DO DEFAULT (SHARED)
C$OMP$PRIVATE(ibox)
         do ibox = laddr(1,ilev),laddr(2,ilev)
            call mbh2dmpzero(nd,rmlexp(iaddr(1,ibox)),nterms(ilev))
            call mbh2dmpzero(nd,rmlexp(iaddr(2,ibox)),nterms(ilev))
            call mbh2dmpzero(nd,rmlexp(iaddr(3,ibox)),nterms(ilev))
            call mbh2dmpzero(nd,rmlexp(iaddr(4,ibox)),nterms(ilev))
         enddo
C$OMP END PARALLEL DO
      enddo

c
      if(ifprint .ge. 1)
     $     call prinf('=== STEP 1 (form mp) ====*',i,0)
      call cpu_time(time1)
C$        time1=omp_get_wtime()
c
c       ... step 1, locate all charges, assign them to boxes, and
c       form multipole expansions

      do ilev = 2,nlevels
         if(zi*boxsize(ilev).lt.zkiupbound) then
C

C$OMP PARALLEL DO DEFAULT (SHARED)
C$OMP$PRIVATE(ibox,nchild,istart,iend,npts)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox=laddr(1,ilev),laddr(2,ilev)
               nchild = itree(iptr(4)+ibox-1)
               istart = isrcse(1,ibox)
               iend = isrcse(2,ibox)
               npts = iend-istart+1
c     Check if current box is a leaf box
               if(nchild.eq.0.and.npts.gt.0) then
                  call mbh2dformmpmp_vec(nd,beta,rscales(ilev),
     1                 source(1,istart),npts,mbhmps(1,0,istart),
     1                 ymps(1,0,istart),ntermsmps,centers(1,ibox),
     1                 nterms(ilev),rmlexp(iaddr(1,ibox)),
     1                 rmlexp(iaddr(2,ibox)))
               endif
            enddo
C$OMP END PARALLEL DO

         endif
      enddo

      call cpu_time(time2)
C$    time2=omp_get_wtime()
      timeinfo(1)=time2-time1

      if(ifprint.ge.1)
     $      call prinf('=== STEP 2 (form lo) ====*',i,0)
      call cpu_time(time1)
C$        time1=omp_get_wtime()
      do ilev = 2,nlevels
       if(zi*boxsize(ilev).lt.zkiupbound) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,jbox,nlist4,istart,iend,npts,i)
C$OMP$SCHEDULE(DYNAMIC)
          do ibox = laddr(1,ilev),laddr(2,ilev)
             npts = 0

             if(ifpghtarg.gt.0) then
                istart = itargse(1,ibox)
                iend = itargse(2,ibox)
                npts = npts + iend-istart+1
             endif

             if(ifpgh.gt.0) then
                istart = isrcse(1,ibox)
                iend = isrcse(2,ibox)
                npts = npts + iend-istart+1
             endif

             if(npts.gt.0) then

                do i=1,nlist4s(ibox)
                   jbox = list4(i,ibox)
                   istart = isrcse(1,jbox)
                   iend = isrcse(2,jbox)
                   npts = iend-istart+1

                   call mbh2dformtamp_vec(nd,beta,rscales(ilev),
     1                  source(1,istart),npts,mbhmps(1,0,istart),
     2                  ymps(1,0,istart),ntermsmps,centers(1,ibox),
     3                  nterms(ilev),rmlexp(iaddr(3,ibox)),
     4                  rmlexp(iaddr(4,ibox)))

                enddo
             endif
          enddo
C$OMP END PARALLEL DO

       endif
      enddo
      call cpu_time(time2)
C$    time2=omp_get_wtime()
      timeinfo(2)=time2-time1

      if(ifprint .ge. 1)
     $      call prinf('=== STEP 3 (merge mp) ====*',i,0)
      call cpu_time(time1)
C$    time1=omp_get_wtime()
c
      do ilev=nlevels-1,1,-1

         if(zi*boxsize(ilev).lt.zkiupbound) then

C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,jbox,i,nchild,istart,iend,npts)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox = laddr(1,ilev),laddr(2,ilev)
               nchild = itree(iptr(4)+ibox-1)
               do i=1,nchild
                  jbox = itree(iptr(5)+4*(ibox-1)+i-1)
                  istart = isrcse(1,jbox)
                  iend = isrcse(2,jbox)
                  npts = iend-istart+1
                  if(npts.gt.0) then
                     call mbh2dmpmp_vec(nd,beta,rscales(ilev+1),
     1                    centers(1,jbox),rmlexp(iaddr(1,jbox)),
     2                    rmlexp(iaddr(2,jbox)),nterms(ilev+1),
     3                    rscales(ilev),centers(1,ibox),
     4                    rmlexp(iaddr(1,ibox)),rmlexp(iaddr(2,ibox)),
     5                    nterms(ilev))
                  endif
               enddo
            enddo
C$OMP END PARALLEL DO
         endif
      enddo
      call cpu_time(time2)
C$    time2=omp_get_wtime()
      timeinfo(3)=time2-time1

      if(ifprint.ge.1)
     $    call prinf('=== Step 4 (mp to loc) ===*',i,0)
c      ... step 3, convert multipole expansions into local
c       expansions

      call cpu_time(time1)
C$    time1=omp_get_wtime()
      do ilev = 2,nlevels

       tt1 = second()

       if(zi*boxsize(ilev).lt.zkiupbound) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,jbox,istart,iend,npts,i,nlist2)
C$OMP$SCHEDULE(DYNAMIC)
         do ibox = laddr(1,ilev),laddr(2,ilev)

            npts = 0

            if(ifpghtarg.gt.0) then
              istart = itargse(1,ibox)
              iend = itargse(2,ibox)
              npts = npts + iend-istart+1
            endif

            if(ifpgh.gt.0) then
              istart = isrcse(1,ibox)
              iend = isrcse(2,ibox)
              npts = npts + iend-istart+1
            endif

            if(npts.gt.0) then
               do i=1,nlist2s(ibox)
                  jbox = list2(i,ibox)

                  call mbh2dmploc_vec(nd,beta,rscales(ilev),
     1                 centers(1,jbox),rmlexp(iaddr(1,jbox)),
     2                 rmlexp(iaddr(2,jbox)),nterms(ilev),
     3                 rscales(ilev),centers(1,ibox),
     4                 rmlexp(iaddr(3,ibox)),
     5                 rmlexp(iaddr(4,ibox)),nterms(ilev))

               enddo
            endif
         enddo
C$OMP END PARALLEL DO
       endif

       tt2 = second()
       timelev(ilev) = tt2-tt1

      enddo
      call cpu_time(time2)
C$    time2=omp_get_wtime()
      timeinfo(4) = time2-time1

      if(ifprint.ge.1)
     $    call prinf('=== Step 5 (split loc) ===*',i,0)

      call cpu_time(time1)
C$    time1=omp_get_wtime()
      do ilev = 1,nlevels-1
         if(zi*boxsize(ilev).lt.zkiupbound) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,jbox,i,nchild,istart,iend,npts)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox = laddr(1,ilev),laddr(2,ilev)
               nchild = itree(iptr(4)+ibox-1)

               npts = 0

               if(ifpghtarg.gt.0) then
                  istart = itargse(1,ibox)
                  iend = itargse(2,ibox)
                  npts = npts + iend-istart+1
               endif

               if(ifpgh.gt.0) then
                  istart = isrcse(1,ibox)
                  iend = isrcse(2,ibox)
                  npts = npts + iend-istart+1
               endif

               if(npts.gt.0) then
                  do i=1,nchild
                     jbox = itree(iptr(5)+4*(ibox-1)+i-1)

                     call mbh2dlocloc_vec(nd,beta,rscales(ilev),
     1                    centers(1,ibox),rmlexp(iaddr(3,ibox)),
     2                    rmlexp(iaddr(4,ibox)),nterms(ilev),
     3                    rscales(ilev+1),centers(1,jbox),
     4                    rmlexp(iaddr(3,jbox)),rmlexp(iaddr(4,jbox)),
     5                    nterms(ilev+1),carray,ldc)

                  enddo
               endif
            enddo
C$OMP END PARALLEL DO
         endif
      enddo
      call cpu_time(time2)
C$    time2=omp_get_wtime()
      timeinfo(5) = time2-time1

      call cpu_time(time1)
C$    time1=omp_get_wtime()
      if(ifprint.ge.1)
     $    call prinf('=== Step 6 (mp eval) ===*',i,0)

cc      call prinf('ifpgh=*',ifpgh,1)
cc      call prinf('ifpghtarg=*',ifpghtarg,1)
cc      call prinf('laddr=*',laddr,2*(nlevels+1))
      do ilev=1,nlevels-1
       if(zi*boxsize(ilev+1).lt.zkiupbound) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istart,iend,npts,j,i)
C$OMP$PRIVATE(jbox)
C$OMP$SCHEDULE(DYNAMIC)
         do ibox=laddr(1,ilev),laddr(2,ilev)

c              evalute multipole expansion at all targets
            istart = itargse(1,ibox)
            iend = itargse(2,ibox)
            npts = iend-istart+1

            if(ifpghtarg.eq.1) then
               do i=1,nlist3s(ibox)
                  jbox = list3(i,ibox)

                  call mbh2dmpevalp_vec(nd,beta,rscales(ilev+1),
     1                 centers(1,jbox),rmlexp(iaddr(1,jbox)),
     1                 rmlexp(iaddr(2,jbox)),
     2                 nterms(ilev+1),target(1,istart),npts,
     3                 pottarg(1,istart))
               enddo
            endif
            if(ifpghtarg.eq.2) then
               do i=1,nlist3s(ibox)
                  jbox = list3(i,ibox)
                  call mbh2dmpevalg_vec(nd,beta,rscales(ilev+1),
     1                 centers(1,jbox),rmlexp(iaddr(1,jbox)),
     1                 rmlexp(iaddr(2,jbox)),
     2                 nterms(ilev+1),target(1,istart),npts,
     3                 pottarg(1,istart),
     4                 gradtarg(1,1,istart))
               enddo
            endif
            if(ifpghtarg.eq.3) then
               do i=1,nlist3s(ibox)
                  jbox = list3(i,ibox)

                  call mbh2dmpevalh_vec(nd,beta,rscales(ilev+1),
     1                 centers(1,jbox),rmlexp(iaddr(1,jbox)),
     1                 rmlexp(iaddr(2,jbox)),
     2                 nterms(ilev+1),target(1,istart),npts,
     3                 pottarg(1,istart),
     3                 gradtarg(1,1,istart),hesstarg(1,1,istart))
               enddo
            endif

c              evalute multipole expansion at all sources
            istart = isrcse(1,ibox)
            iend = isrcse(2,ibox)
            npts = iend-istart+1

            if(ifpgh.eq.1) then
               do i=1,nlist3s(ibox)
                  jbox = list3(i,ibox)
                  call mbh2dmpevalp_vec(nd,beta,rscales(ilev+1),
     1                 centers(1,jbox),rmlexp(iaddr(1,jbox)),
     1                 rmlexp(iaddr(2,jbox)),
     2                nterms(ilev+1),source(1,istart),npts,
     3                pot(1,istart))
               enddo
            endif
            if(ifpgh.eq.2) then
               do i=1,nlist3s(ibox)
                  jbox = list3(i,ibox)
                  call mbh2dmpevalg_vec(nd,beta,rscales(ilev+1),
     1                 centers(1,jbox),rmlexp(iaddr(1,jbox)),
     1                 rmlexp(iaddr(2,jbox)),
     2                 nterms(ilev+1),source(1,istart),npts,
     3                 pot(1,istart),grad(1,1,istart))
               enddo
            endif
            if(ifpgh.eq.3) then
               do i=1,nlist3s(ibox)
                  jbox = list3(i,ibox)
                  call mbh2dmpevalh_vec(nd,beta,rscales(ilev+1),
     1                 centers(1,jbox),rmlexp(iaddr(1,jbox)),
     1                 rmlexp(iaddr(2,jbox)),
     2                 nterms(ilev+1),source(1,istart),npts,
     3                 pot(1,istart),grad(1,1,istart),hess(1,1,istart))
               enddo
            endif

         enddo
C$OMP END PARALLEL DO
       endif
      enddo

 1000 continue

      call cpu_time(time2)
C$    time2=omp_get_wtime()
      timeinfo(6) = time2-time1

      if(ifprint.ge.1)
     $    call prinf('=== step 7 (eval lo) ===*',i,0)

c     ... step 7, evaluate all local expansions
      call cpu_time(time1)
C$    time1=omp_get_wtime()
      do ilev = 0,nlevels
       if(zi*boxsize(ilev).lt.zkiupbound) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istart,iend,i,npts)
C$OMP$SCHEDULE(DYNAMIC)
         do ibox = laddr(1,ilev),laddr(2,ilev)
            nchild = itree(iptr(4)+ibox-1)
            if(nchild.eq.0) then
c     c               evaluate local expansion
c                at targets
               istart = itargse(1,ibox)
               iend = itargse(2,ibox)
               npts = iend-istart + 1
               if(ifpghtarg.eq.1) then
                  call mbh2dtaevalp_vec(nd,beta,rscales(ilev),
     1                 centers(1,ibox),rmlexp(iaddr(3,ibox)),
     1                 rmlexp(iaddr(4,ibox)),
     2                 nterms(ilev),target(1,istart),npts,
     3                 pottarg(1,istart))
               endif
               if(ifpghtarg.eq.2) then
                  call mbh2dtaevalg_vec(nd,beta,rscales(ilev),
     1                 centers(1,ibox),rmlexp(iaddr(3,ibox)),
     2                 rmlexp(iaddr(4,ibox)),
     2                nterms(ilev),target(1,istart),npts,
     3                pottarg(1,istart),gradtarg(1,1,istart))
               endif
               if(ifpghtarg.eq.3) then
                  call mbh2dtaevalh_vec(nd,beta,rscales(ilev),
     1                centers(1,ibox),rmlexp(iaddr(3,ibox)),
     2                 rmlexp(iaddr(4,ibox)),
     2                 nterms(ilev),target(1,istart),npts,
     3                pottarg(1,istart),gradtarg(1,1,istart),
     4                hesstarg(1,1,istart))
               endif

c
cc                evaluate local expansion at sources

               istart = isrcse(1,ibox)
               iend = isrcse(2,ibox)
               npts = iend-istart+1
               if(ifpgh.eq.1) then
                 call mbh2dtaevalp_vec(nd,beta,rscales(ilev),
     1                 centers(1,ibox),rmlexp(iaddr(3,ibox)),
     1                 rmlexp(iaddr(4,ibox)),
     2                 nterms(ilev),source(1,istart),npts,
     3                 pot(1,istart))
              endif
              if(ifpgh.eq.2) then
                 call mbh2dtaevalg_vec(nd,beta,rscales(ilev),
     1                centers(1,ibox),rmlexp(iaddr(3,ibox)),
     1                rmlexp(iaddr(4,ibox)),
     2                nterms(ilev),source(1,istart),npts,
     3                pot(1,istart),grad(1,1,istart))
              endif
              if(ifpgh.eq.3) then
                 call mbh2dtaevalh_vec(nd,beta,rscales(ilev),
     1                centers(1,ibox),rmlexp(iaddr(3,ibox)),
     1                rmlexp(iaddr(4,ibox)),
     2                nterms(ilev),source(1,istart),npts,
     3                pot(1,istart),grad(1,1,istart),hess(1,1,istart))
               endif
            endif
         enddo
C$OMP END PARALLEL DO
       endif
      enddo

      call cpu_time(time2)
C$    time2 = omp_get_wtime()
      timeinfo(7) = time2 - time1

      if(ifprint .ge. 1)
     $     call prinf('=== STEP 8 (direct) =====*',i,0)

c
cc     set threshold for ignoring interactions with
c      |r| < thresh
c
      thresh = boxsize(0)*1.0d-16
      call prin2('thresh=*',thresh,1)
c
cc
      call cpu_time(time1)
C$    time1=omp_get_wtime()
      do ilev = 0,nlevels
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,jbox,istartt,iendt,i,jstart,jend,istarte,iende)
C$OMP$PRIVATE(nlist1,istarts,iends)
C$OMP$SCHEDULE(DYNAMIC)
         do ibox = laddr(1,ilev),laddr(2,ilev)

            istartt = itargse(1,ibox)
            iendt = itargse(2,ibox)

            istarts = isrcse(1,ibox)
            iends = isrcse(2,ibox)

            do i =1,nlist1s(ibox)
               jbox = list1(i,ibox)

               jstart = isrcse(1,jbox)
               jend = isrcse(2,jbox)

               call mbhfmm2dmps_direct_vec(nd,jstart,jend,istartt,
     1              iendt,beta,source,mbhmps,ymps,ntermsmps,
     2              target,ifpghtarg,pottarg,
     3              gradtarg,hesstarg,thresh)

               call mbhfmm2dmps_direct_vec(nd,jstart,jend,istarts,
     1              iends,beta,source,mbhmps,ymps,ntermsmps,
     2              source,ifpgh,pot,
     3              grad,hess,thresh)

            enddo
         enddo
C$OMP END PARALLEL DO
      enddo

      call cpu_time(time2)
C$    time2=omp_get_wtime()
      timeinfo(8) = time2-time1
      if(ifprint.ge.1) call prin2('timeinfo=*',timeinfo,8)
      d = 0
      do i = 1,8
         d = d + timeinfo(i)
      enddo

      if(ifprint.ge.1) call prin2('sum(timeinfo)=*',d,1)
      if(ifprint.ge.1) call prin2('timlev=*',timelev,nlevels+1)

      return
      end
c
c------------------------------------------------------------------
      subroutine mbhfmm2dmps_direct_vec(nd,istart,iend,jstart,jend,
     $     beta,source,mbhmps,ymps,ntermsmps,
     $     targ,ifpgh,pot,grad,hess,thresh)
c--------------------------------------------------------------------
c     This subroutine adds the contribuition due to multipolar sources
c     istart to iend in the source array at the expansion centers
c     jstart to jend in the target array to the computed velocities
c     and gradients. Note that contributions for sources
c     within thresh of the targets are not added to the potential
c
c
c     INPUT arguments
c-------------------------------------------------------------------
c     nd           in: integer
c                  number of charge densities
c
c     istart       in:Integer
c                  Starting index in source array whose expansions
c                  we wish to add
c
c     iend         in:Integer
c                  Last index in source array whose expansions
c                  we wish to add
c
c     jstart       in: Integer
c                  First index in target array at which we
c                  wish to update the potential and gradients
c
c     jend         in:Integer
c                  Last index in target array at which we wish
c                  to update the potential and gradients
c
c     beta         in: real *8
c                  modified biharmonic parameter
c
c     source       in: real *8(2,ns)
c                  Source locations
c
c     mbhmps       in: complex *16 (nd,0:ntermsmps,ns)
c                  difference kernel type expansion at each source
c
c     ymps         in: complex *16 (nd,0:ntermsmps,ns)
c                  Yukawa (Bessel K) type expansion at each source
c
c     ntermsmps    in: integer, order of the multipolar charges at
c                  each source
c
c     targ        in: real *8(2,nt)
c                 target locations
c
c     ifpgh        in: Integer
c                  Flag for computing the potential/gradient/hessian.
c                  ifpgh = 1, only potential is computed
c                  ifpgh = 2, potential/gradient are computed
c                  ifpgh = 3, potential/gradient/hessian are computed
c
c     thresh       in: real *8
c                  threshold for computing interactions
c                  if |r| < threshold, then interactions are
c                  not included
c
c
c------------------------------------------------------------
c     OUTPUT
c
c   Updated velocity and gradients at the targets
c   pot : potential at the targets
c   grad: gradient at the targets
c   hess: Hessian at the targets
c-------------------------------------------------------
        implicit none
c
        integer istart,iend,jstart,jend,ns,j,i
        integer ifcharge,ifdipole

        integer nd,ntermsmps

        real *8 beta

        real *8 source(2,*)
        complex *16 mbhmps(nd,0:ntermsmps,*),ymps(nd,0:ntermsmps,*)

        integer ifpgh
        real *8 targ(2,*),thresh

c
        real *8  pot(nd,*)
        real *8  grad(nd,2,*)
        real *8  hess(nd,3,*)

        integer nt

c
        ns = iend - istart + 1
        nt = jend - jstart + 1

        if(ifpgh.eq.1) then
           call mbh2d_directmpsp_vec(nd,beta,source(1,istart),ns,
     1          mbhmps(1,0,istart),ymps(1,0,istart),ntermsmps,
     1          targ(1,jstart),nt,pot(1,jstart),thresh)
        endif

        if(ifpgh.eq.2) then
           call mbh2d_directmpsg_vec(nd,beta,source(1,istart),ns,
     1          mbhmps(1,0,istart),ymps(1,0,istart),ntermsmps,
     1          targ(1,jstart),nt, pot(1,jstart),grad(1,1,jstart),
     1          thresh)
        endif
        if(ifpgh.eq.3) then
           call mbh2d_directmpsh_vec(nd,beta,source(1,istart),ns,
     1          mbhmps(1,0,istart),ymps(1,0,istart),ntermsmps,
     1          targ(1,jstart),nt,pot(1,jstart),grad(1,1,jstart),
     1          hess(1,1,jstart),thresh)
        endif

c
        return
        end
c------------------------------------------------------------------
      subroutine mbh2dmpalloc(nd,laddr,iaddr,nlevels,lmptot,
     1     nterms)
c     This subroutine determines the size of the array
c     to be allocated for the multipole expansions
c     iaddr(1,i) points to the starting location of the multipole
c     expansion of box i and iaddr(2,i) points to the local
c     expansion of box i
c
c     Input arguments
c     nd          in: integer
c                 number of expansions
c
c     laddr       in: Integer(2,0:nlevels)
c                 indexing array providing access to boxes at each
c                 level
c
c     nlevels     in: Integer
c                 Total numner of levels
c
c     nterms      in: Integer(0:nlevels)
c                 Number of terms requried in expansions at each
c                 level
c
c------------------------------------------------------------------
c     Output arguments
c     iaddr       out: Integer(4,nboxes)
c     Points to the multipole and local expansions in box i
c     iaddr(1,ibox) - difference type multipole exp
c     iaddr(2,ibox) - Yukawa (Bessel K) type multipole exp
c     iaddr(3,ibox) - difference type local exp
c     iaddr(4,ibox) - Laplace (power series) type multipole exp
c
c     lmptot      out: Integer
c                 Total length of expansions array required
c------------------------------------------------------------------

      implicit none
      integer nlevels,nterms(0:nlevels),nd,nsig,nt1,nt2,next235
      integer iaddr(4,*), lmptot, laddr(2,0:nlevels)
      integer ibox,i,iptr,istart,nn,itmp
      real *8 ddn
c
      istart = 1
      do i = 0,nlevels

         nn = (nterms(i)+1)*2*nd
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,itmp)
         do ibox = laddr(1,i),laddr(2,i)
c     Allocate memory for the multipole expansion
c
           itmp = ibox - laddr(1,i)
           iaddr(1,ibox) = istart + itmp*nn*2
           iaddr(2,ibox) = istart + itmp*nn*2 + nn
         enddo
C$OMP END PARALLEL DO
         istart = istart + (laddr(2,i)-laddr(1,i)+1)*nn*2
       enddo
c
c            Allocate memory for the local expansion
c
       do i=0,nlevels
         nn = (nterms(i)+1)*2*nd
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,itmp)
         do ibox = laddr(1,i),laddr(2,i)
             itmp = ibox - laddr(1,i)
             iaddr(3,ibox) = istart + itmp*nn*2
             iaddr(4,ibox) = istart + itmp*nn*2 + nn
         enddo
C$OMP END PARALLEL DO
         istart = istart + (laddr(2,i)-laddr(1,i)+1)*nn*2
      enddo
      lmptot = istart

      return
      end
c----------------------------------------------------------------
c
C***********************************************************************
      subroutine mbh2dmpzero(nd,mpole,nterms)
      implicit none
C***********************************************************************
c
c     This subroutine sets a multipole expansion of the given
c     order to zero.
c-----------------------------------------------------------------------
c     INPUT:
c
c     nd     :   number of expansions
c     nterms :   order of multipole expansions
C---------------------------------------------------------------------
c     OUTPUT:
c
c     mpole  :   coeffs for the expansion set to zero.
C---------------------------------------------------------------------
      integer n,nterms,nd,idim
      complex *16 mpole(nd,nterms+1)
c
      do n=1,(nterms+1)
        do idim=1,nd
          mpole(idim,n)=0.0d0
        enddo
      enddo
      return
      end
c
c


module type_rbf_interpolation_matrix
#include <messenger.h>
    use mod_kinds,                  only: ik, rk
    use mod_inv,                    only: inv
    implicit none

    type, public :: rbf_interpolation_matrix_t

        ! We assume the form
        ! |A 0||cb| = |sb|
        ! |B C||ce|   |se|
        !
        ! where A and B are base and C is lower triangular.
        !
        ! We then can solve the system via
        !
        ! 1. Solve the dense system, A*cb = sb to obtain
        !       cb = Ainv*sb
        ! 2. Solve the lower triangular system, C*ce = se-B*cb, via forward substitution to obtain
        !       ce = Cinv*(se-B*cb)
        !

        real(rk), allocatable                   :: A(:,:)
        real(rk), allocatable                   :: Ainv(:,:)
        real(rk), allocatable                   :: B(:,:)
        real(rk), allocatable                   :: C(:,:)

        logical                                 :: is_initialized = .false.
        logical                                 :: is_filled = .false.

    contains

        procedure           :: init
        procedure           :: solve

    end type rbf_interpolation_matrix_t

contains

    subroutine init(self, nnodes_base, nnodes_explicit)
        class(rbf_interpolation_matrix_t),      intent(inout)           :: self
        integer(ik),                            intent(in)              :: nnodes_base
        integer(ik),                            intent(in), optional    :: nnodes_explicit

        allocate(self%A(nnodes_base, nnodes_base))
        if (present(nnodes_explicit)) then
            if (nnodes_explicit>0) then
                allocate(self%B(nnodes_explicit, nnodes_base))
                allocate(self%C(nnodes_explicit, nnodes_explicit))
            end if
        end if

    end subroutine

    function solve(self, source_val) result(rbf_coeff)
        class(rbf_interpolation_matrix_t),      intent(inout)           :: self
        real(rk),                               intent(in)              :: source_val(:)

        real(rk), allocatable :: rbf_coeff(:)
        real(rk), allocatable :: rbf_coeff_base(:), rbf_coeff_explicit(:), temp(:), rhs(:)
        real(rk), allocatable :: source_val_base(:)
        real(rk), allocatable :: source_val_explicit(:)

        integer(ik) :: inode_sol, inode_term, nnodes_base, nnodes_explicit

        if (.not. self%is_filled) call chidg_signal(FATAL, 'rbf_interpolation_matrix%solve : matrix is not filled')

        nnodes_base = size(self%A,1)
        ! Invert the base block
        if (.not. allocated(self%Ainv)) then

            self%Ainv = inv(self%A)

        end if

        ! Solve for the basely coupled RBF coefficients
        allocate(rbf_coeff_base(nnodes_base), source_val_base(nnodes_base))
        source_val_base = source_val(1:nnodes_base)
        rbf_coeff_base = matmul(self%Ainv, source_val_base)
        !rbf_coeff_base = solve_dense(self%A, source_val_base)

        ! Now, check if we have explicit RBF nodes, and solve if so
        if ((allocated(self%C))) then
            nnodes_explicit = size(self%C,1)
            allocate(rbf_coeff_explicit(nnodes_explicit), source_val_explicit(nnodes_explicit))

            temp = matmul(self%B, rbf_coeff_base)

            source_val_explicit = source_val(nnodes_base+1:nnodes_base+nnodes_explicit)
            rhs = source_val_explicit-temp

            rbf_coeff_explicit(1) = rhs(1)/self%C(1,1)
            do inode_sol = 2, size(source_val_explicit,1)

                rbf_coeff_explicit(inode_sol) = rhs(inode_sol)
                do inode_term = 1, (inode_sol-1)
                    rbf_coeff_explicit(inode_sol) = rbf_coeff_explicit(inode_sol) -&
                    self%C(inode_sol,inode_term)*rbf_coeff_explicit(inode_term)

                end do

                rbf_coeff_explicit(inode_sol) = rbf_coeff_explicit(inode_sol)/self%C(inode_sol, inode_sol)

            end do

            allocate(rbf_coeff(nnodes_base+nnodes_explicit))
            rbf_coeff(1:nnodes_base) = rbf_coeff_base
            rbf_coeff(nnodes_base+1:(nnodes_base+nnodes_explicit)) = rbf_coeff_explicit
        else
            rbf_coeff = rbf_coeff_base

        end if

    end function solve

end module type_rbf_interpolation_matrix


      SUBROUTINE MB03QG( DICO, STDOM, JOBU, JOBV, N, NLOW, NSUP, ALPHA,
     $                   A, LDA, E, LDE, U, LDU, V, LDV, NDIM, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reorder the diagonal blocks of a principal subpencil of an
C     upper quasi-triangular matrix pencil A-lambda*E together with
C     their generalized eigenvalues, by constructing orthogonal
C     similarity transformations UT and VT.
C     After reordering, the leading block of the selected subpencil of
C     A-lambda*E has generalized eigenvalues in a suitably defined
C     domain of interest, usually related to stability/instability in a
C     continuous- or discrete-time sense.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the spectrum separation to be
C             performed, as follows:
C             = 'C':  continuous-time sense;
C             = 'D':  discrete-time sense.
C
C     STDOM   CHARACTER*1
C             Specifies whether the domain of interest is of stability
C             type (left part of complex plane or inside of a circle)
C             or of instability type (right part of complex plane or
C             outside of a circle), as follows:
C             = 'S':  stability type domain;
C             = 'U':  instability type domain.
C
C     JOBU    CHARACTER*1
C             Indicates how the performed orthogonal transformations UT
C             are accumulated, as follows:
C             = 'I':  U is initialized to the unit matrix and the matrix
C                     UT is returned in U;
C             = 'U':  the given matrix U is updated and the matrix U*UT
C                     is returned in U.
C
C     JOBV    CHARACTER*1
C             Indicates how the performed orthogonal transformations VT
C             are accumulated, as follows:
C             = 'I':  V is initialized to the unit matrix and the matrix
C                     VT is returned in V;
C             = 'U':  the given matrix V is updated and the matrix V*VT
C                     is returned in V.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, E, U, and V.  N >= 0.
C
C     NLOW,   (input) INTEGER
C     NSUP    (input) INTEGER
C             NLOW and NSUP specify the boundary indices for the rows
C             and columns of the principal subpencil  of A - lambda*E
C             whose diagonal blocks are to be reordered.
C             0 <= NLOW <= NSUP <= N.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The boundary of the domain of interest for the eigenvalues
C             of A. If DICO = 'C', ALPHA is the boundary value for the
C             real parts of the generalized eigenvalues, while for
C             DICO = 'D', ALPHA >= 0 represents the boundary value for
C             the moduli of the generalized eigenvalues.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain a matrix in a real Schur form whose 1-by-1 and
C             2-by-2 diagonal blocks between positions NLOW and NSUP
C             are to be reordered.
C             On exit, the leading N-by-N part of this array contains
C             a real Schur matrix UT' * A * VT, with the elements below
C             the first subdiagonal set to zero.
C             The leading NDIM-by-NDIM part of the principal subpencil
C             B - lambda*C, defined with B := A(NLOW:NSUP,NLOW:NSUP),
C             C := E(NLOW:NSUP,NLOW:NSUP), has generalized eigenvalues
C             in the domain of interest and the trailing part of this
C             subpencil has generalized eigenvalues outside the domain
C             of interest.
C             The domain of interest for eig(B,C), the generalized
C             eigenvalues of the pair (B,C), is defined by the
C             parameters ALPHA, DICO and STDOM as follows:
C               For DICO = 'C':
C                  Real(eig(B,C)) < ALPHA if STDOM = 'S';
C                  Real(eig(B,C)) > ALPHA if STDOM = 'U'.
C               For DICO = 'D':
C                  Abs(eig(B,C)) < ALPHA if STDOM = 'S';
C                  Abs(eig(B,C)) > ALPHA if STDOM = 'U'.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain a matrix in an upper triangular form.
C             On exit, the leading N-by-N part of this array contains an
C             upper triangular matrix UT' * E * VT, with the elements
C             below the diagonal set to zero.
C             The leading NDIM-by-NDIM part of the principal subpencil
C             B - lambda*C, defined with B := A(NLOW:NSUP,NLOW:NSUP)
C             C := E(NLOW:NSUP,NLOW:NSUP) has generalized eigenvalues
C             in the domain of interest and the trailing part of this
C             subpencil has generalized eigenvalues outside the domain
C             of interest (see description of A).
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,N)
C             On entry with JOBU = 'U', the leading N-by-N part of this
C             array must contain a transformation matrix (e.g., from a
C             previous call to this routine).
C             On exit, if JOBU = 'U', the leading N-by-N part of this
C             array contains the product of the input matrix U and the
C             orthogonal matrix UT used to reorder the diagonal blocks
C             of A - lambda*E.
C             On exit, if JOBU = 'I', the leading N-by-N part of this
C             array contains the matrix UT of the performed orthogonal
C             transformations.
C             Array U need not be set on entry if JOBU = 'I'.
C
C     LDU     INTEGER
C             The leading dimension of the array U.  LDU >= MAX(1,N).
C
C     V       (input/output) DOUBLE PRECISION array, dimension (LDV,N)
C             On entry with JOBV = 'U', the leading N-by-N part of this
C             array must contain a transformation matrix (e.g., from a
C             previous call to this routine).
C             On exit, if JOBV = 'U', the leading N-by-N part of this
C             array contains the product of the input matrix V and the
C             orthogonal matrix VT used to reorder the diagonal blocks
C             of A - lambda*E.
C             On exit, if JOBV = 'I', the leading N-by-N part of this
C             array contains the matrix VT of the performed orthogonal
C             transformations.
C             Array V need not be set on entry if JOBV = 'I'.
C
C     LDV     INTEGER
C             The leading dimension of the array V.  LDV >= MAX(1,N).
C
C     NDIM    (output) INTEGER
C             The number of generalized eigenvalues of the selected
C             principal subpencil lying inside the domain of interest.
C             If NLOW = 1, NDIM is also the dimension of the deflating
C             subspace corresponding to the generalized eigenvalues of
C             the leading NDIM-by-NDIM subpencil. In this case, if U and
C             V are the orthogonal transformation matrices used to
C             compute and reorder the generalized real Schur form of the
C             pair (A,E), then the first NDIM columns of V form an
C             orthonormal basis for the above deflating subspace.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= 1, and if N > 1,
C             LDWORK >= 4*N + 16.
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  A(NLOW,NLOW-1) is nonzero, i.e., A(NLOW,NLOW) is not
C                   the leading element of a 1-by-1 or 2-by-2 diagonal
C                   block of A, or A(NSUP+1,NSUP) is nonzero, i.e.,
C                   A(NSUP,NSUP) is not the bottom element of a 1-by-1
C                   or 2-by-2 diagonal block of A;
C             = 2:  two adjacent blocks are too close to swap (the
C                   problem is very ill-conditioned).
C
C     METHOD
C
C     Given an upper quasi-triangular matrix pencil A - lambda*E with
C     1-by-1 or 2-by-2 diagonal blocks, the routine reorders its
C     diagonal blocks along with its eigenvalues by performing an
C     orthogonal equivalence transformation UT'*(A - lambda*E)* VT.
C     The column transformations UT and VT are also performed on the
C     given (initial) transformations U and V (resulted from a
C     possible previous step or initialized as identity matrices).
C     After reordering, the generalized eigenvalues inside the region
C     specified by the parameters ALPHA, DICO and STDOM appear at the
C     top of the selected diagonal subpencil between positions NLOW and
C     NSUP. In other words, lambda(A(Select,Select),E(Select,Select))
C     are ordered such that lambda(A(Inside,Inside),E(Inside,Inside))
C     are inside, and lambda(A(Outside,Outside),E(Outside,Outside)) are
C     outside the domain of interest, where Select = NLOW:NSUP,
C     Inside = NLOW:NLOW+NDIM-1, and Outside = NLOW+NDIM:NSUP.
C     If NLOW = 1, the first NDIM columns of V*VT span the corresponding
C     right deflating subspace of (A,E).
C
C     REFERENCES
C
C     [1] Stewart, G.W.
C         HQR3 and EXCHQZ: FORTRAN subroutines for calculating and
C         ordering the eigenvalues of a real upper Hessenberg matrix.
C         ACM TOMS, 2, pp. 275-280, 1976.
C
C     NUMERICAL ASPECTS
C                                         3
C     The algorithm requires less than 4*N  operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     October 2002. Based on the RASP/BIMASC routine GSEOR1.
C
C     REVISIONS
C
C     V. Sima, Dec. 2016.
C
C     KEYWORDS
C
C     Eigenvalues, invariant subspace, orthogonal transformation, real
C     Schur form, equivalence transformation.
C
C    ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ONE, ZERO
      PARAMETER        ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        DICO, JOBU, JOBV, STDOM
      INTEGER          INFO, LDA, LDE, LDU, LDV, LDWORK, N, NDIM, NLOW,
     $                 NSUP
      DOUBLE PRECISION ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), DWORK(*), E(LDE,*), U(LDU,*), V(LDV,*)
C     .. Local Scalars ..
      LOGICAL          DISCR, LQUERY, LSTDOM
      INTEGER          IB, L, LM1, MINWRK, NUP
      DOUBLE PRECISION ALPHAI(2), ALPHAR(2), BETA(2)
      DOUBLE PRECISION TLAMBD, TOLE, X
C     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLAMCH, DLANTR, DLAPY2
      EXTERNAL         DLAMCH, DLANTR, DLAPY2, LSAME
C     .. External Subroutines ..
      EXTERNAL         DLASET, DTGEXC, MB03QW, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        ABS, MAX
C     .. Executable Statements ..
C
      INFO   = 0
      DISCR  = LSAME( DICO,  'D' )
      LSTDOM = LSAME( STDOM, 'S' )
C
C     Check input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LSTDOM .OR. LSAME( STDOM, 'U' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( LSAME( JOBU, 'I' ) .OR.
     $                 LSAME( JOBU, 'U' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT. ( LSAME( JOBV, 'I' ) .OR.
     $                 LSAME( JOBV, 'U' ) ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( NLOW.LT.0 ) THEN
         INFO = -6
      ELSE IF( NSUP.LT.NLOW .OR. N.LT.NSUP ) THEN
         INFO = -7
      ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN
         INFO = -8
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( LDU.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
         INFO = -16
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF( N.LE.1 ) THEN
            MINWRK = 1
         ELSE
            MINWRK = 4*N + 16
         END IF
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -19
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB03QG', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = MINWRK
         RETURN
      END IF
C
C     Quick return if possible.
C
      NDIM = 0
      IF( NSUP.EQ.0 )
     $   RETURN
C
      IF( NLOW.GT.1 ) THEN
         IF( A(NLOW,NLOW-1).NE.ZERO )
     $      INFO = 1
      END IF
      IF( NSUP.LT.N ) THEN
         IF( A(NSUP+1,NSUP).NE.ZERO )
     $      INFO = 1
      END IF
      IF( INFO.NE.0 )
     $   RETURN
C
C     Initialize U with an identity matrix if necessary.
C
      IF( LSAME( JOBU, 'I' ) )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU )
C
C     Initialize V with an identity matrix if necessary.
C
      IF( LSAME( JOBV, 'I' ) )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, V, LDV )
C
C     Compute zero tolerance for the diagonal elements of matrix E.
C
      TOLE = DLAMCH( 'Epsilon' ) *
     $       DLANTR( '1', 'Upper', 'Non-unit', N, N, E, LDE, DWORK )
C
      L   = NSUP
      NUP = NSUP
C
C     NUP is the minimal value such that the subpencil
C     A(i,j)-lambda*E(i,j),  with NUP+1 <= i,j <= NSUP contains no
C     generalized eigenvalues inside the domain of interest.
C     L is such that all generalized eigenvalues of the subpencil
C     A(i,j)-lambda*E(i,j) with L <= i,j <= NUP lie inside the
C     domain of interest.
C
C     WHILE( L >= NLOW ) DO
C
   10 CONTINUE
      IF( L.GE.NLOW ) THEN
         IB = 1
         IF( L.GT.NLOW ) THEN
            LM1 = L - 1
            IF( A(L,LM1).NE.ZERO ) THEN
               CALL MB03QW( N, LM1, A, LDA, E, LDE, U, LDU, V, LDV,
     $                      ALPHAR, ALPHAI, BETA, INFO )
               IF( A(L,LM1).NE.ZERO )
     $            IB = 2
            END IF
         END IF
         IF( DISCR ) THEN
            IF( IB.EQ.1 ) THEN
               TLAMBD = ABS( A(L,L) )
               X = ABS( E(L,L) )
            ELSE
               TLAMBD = DLAPY2( ALPHAR(1), ALPHAI(1) )
               X = ABS( BETA(1) )
            END IF
         ELSE
            IF( IB.EQ.1 ) THEN
               X = E(L,L)
               IF( X.LT.ZERO ) THEN
                  TLAMBD = -A(L,L)
                  X = -X
               ELSE
                  TLAMBD = A(L,L)
               END IF
            ELSE
               TLAMBD = ALPHAR(1)
               X = BETA(1)
               IF( X.LT.ZERO ) THEN
                  TLAMBD = -TLAMBD
                  X = -X
               END IF
            END IF
         END IF
         IF((      LSTDOM .AND. TLAMBD.LT.ALPHA*X .AND. X.GT.TOLE ) .OR.
     $      ( .NOT.LSTDOM .AND. TLAMBD.GT.ALPHA*X ) )
     $      THEN
            NDIM = NDIM + IB
            L = L - IB
         ELSE
            IF( NDIM.NE.0 ) THEN
               CALL DTGEXC( .TRUE., .TRUE., N, A, LDA, E, LDE, U, LDU,
     $                      V, LDV, L, NUP, DWORK, LDWORK, INFO )
               IF( INFO.NE.0 ) THEN
                  INFO = 2
                  RETURN
               END IF
               NUP = NUP - 1
               L   = L - 1
            ELSE
               NUP = NUP - IB
               L   = L - IB
            END IF
         END IF
         GO TO 10
      END IF
C
C     END WHILE 10
C
      DWORK(1) = MINWRK
      RETURN
C *** Last line of MB03QG ***
      END


module geomagnetic

!> transformations and data relevant to converting geographic to geomagnetic coordinates

use phys_consts, only: wp,Re,pi
implicit none (type, external)

! magnetic pole location in geographic coordinates
real(wp), parameter :: thetan=11*pi/180
real(wp), parameter :: phin=289*pi/180

private
public :: geomag2geog, geog2geomag, r2alt, alt2r

contains

!> convert geomagnetic coordinates to geographic
elemental subroutine geog2geomag(glon,glat,phi,theta)
  real(wp), intent(in) :: glon,glat
  real(wp), intent(out) :: phi,theta
  real(wp) :: glonwrap
  real(wp) :: thetag
  real(wp) :: phig
  real(wp) :: argtmp,alpha

  glonwrap=mod(glon,360._wp)
  thetag = pi/2 - glat*pi/180
  phig = glonwrap*pi/180

  theta = acos(cos(thetag)*cos(thetan)+sin(thetag)*sin(thetan)*cos(phig-phin))
  argtmp = (cos(thetag)-cos(theta)*cos(thetan))/(sin(theta)*sin(thetan))
  alpha = acos( max(min(argtmp,1._wp),-1._wp) )

  if (phin>phig .and. phin-phig>pi .or. phin<phig .and. phig-phin<pi) then
    phi=pi-alpha
  else
    phi=alpha+pi
  end if
end subroutine geog2geomag

!> convert geographic coordinates to geomagnetic; do not use at the magnetic pole!!!

elemental subroutine geomag2geog(phi,theta,glon,glat)
  real(wp), intent(in) :: phi,theta
  real(wp), intent(out) :: glon,glat
  real(wp) :: thetag2p,thetag2
  real(wp) :: beta
  real(wp) :: phig2,phiwrap
  real(wp) :: argtmp

  phiwrap=mod(phi,2*pi)
  thetag2p=acos(cos(theta)*cos(thetan)-sin(theta)*sin(thetan)*cos(phiwrap))
  argtmp=(cos(theta)-cos(thetag2p)*cos(thetan))/(sin(thetag2p)*sin(thetan))
  beta=acos( max(min(argtmp,1._wp),-1._wp) )

  if (phiwrap>pi) then
    phig2=phin-beta
  else
    phig2=phin+beta
  end if
  phig2=mod(phig2,2*pi)
  thetag2=pi/2-thetag2p

  glon=phig2*180._wp/pi
  glat=thetag2*180._wp/pi
end subroutine geomag2geog

!> convert geocentric distance into altitude (assume spherical Earth but could use other model)
elemental function r2alt(r) result(alt)
  real(wp), intent(in) :: r
  real(wp) :: alt

  alt=r-Re
end function r2alt

!> convert altitude to geocentric distance
elemental function alt2r(alt) result(r)
  real(wp), intent(in) :: alt
  real(wp) :: r

  r=alt+Re
end function alt2r

end module geomagnetic


module kernel_operators_mod

use constants_mod

contains

subroutine kernel_operators_lagrangeProlongationMatrixDGFV(N, dgnodes, fvnodes, matM, matP)

    use lagrange_mod, only: lagrange_polynomial

    integer, intent(in)     :: N
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(in)    :: fvnodes(N)
    real(dp), intent(out)   :: matM(N,N,N)
    real(dp), intent(out)   :: matP(N,N,N)

    integer :: i,j,k

    do k = 1,N
    do j = 1,N
    do i = 1,N
        matM(i,j,k) = lagrange_polynomial(N, dgnodes, i, -1.0_dp)*lagrange_polynomial(N, dgnodes, j, fvnodes(k))
        matP(i,j,k) = lagrange_polynomial(N, dgnodes, i,  1.0_dp)*lagrange_polynomial(N, dgnodes, j, fvnodes(k))
    end do
    end do
    end do

end subroutine

subroutine kernel_operators_DiffMatrix(N, dgnodes, mat)

    use utils_mod, only: krondelta
    use interpol_mod, only: DiffMatrix

    integer, intent(in)     :: N
    real(dp), intent(in)    :: dgnodes(N_NODES)
    real(dp), intent(out)   :: mat(N_NODES,N_NODES)

    real(dp) :: DiffMat(N_NODES,N_NODES)

    real(dp) :: p,q
    integer :: i,j

    DiffMat = 0.0
    call DiffMatrix(N-1, dgnodes(1:N), DiffMat(1:N,1:N))

    p = real(N,dp)
    q = real(N,dp)

    mat = 0.0
    do j = 1,N_NODES; do i = 1,N_NODES
        mat(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * DiffMat(i-floor((i-1)/p)*N, j-floor((j-1)/q)*N)
    end do; end do

    !! correct element length
    mat = real(N_NODES,dp)/real(N,dp)*mat

end subroutine

# if 0
subroutine kernel_operators_StrongDGDiffMatrix(N, dgnodes, dgweights, mat)

    use utils_mod, only: krondelta
    use interpol_mod, only: DiffMatrix

    integer, intent(in) :: N
    real(dp), intent(in)    :: dgnodes(N_NODES)
    real(dp), intent(in)    :: dgweights(N_NODES)
    real(dp), intent(out)   :: mat(N_NODES,N_NODES)

    real(dp) :: MassMat(N_NODES,N_NODES)
    real(dp) :: DiffMat(N_NODES,N_NODES)

    real(dp) :: p,q
    integer :: i,j

    DiffMat = 0.0
    call DiffMatrix(N-1, dgnodes(1:N), DiffMat(1:N,1:N))

    p = real(N,dp)
    q = real(N,dp)

    mat = 0.0
    do j = 1,N_NODES; do i = 1,N_NODES
        mat(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * DiffMat(i-floor((i-1)/p)*N, j-floor((j-1)/q)*N)
    end do; end do

    !! correct element length
    mat = real(N_NODES,dp)/real(N,dp)*mat

end subroutine
# endif

subroutine kernel_operators_WeakDGDiffMatrix(N, dgnodes, dgweights, mat)

    use utils_mod, only: krondelta
    use interpol_mod, only: DiffMatrix

    integer, intent(in) :: N
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(in)    :: dgweights(N)
    real(dp), intent(out)   :: mat(N_NODES,N_NODES)

    real(dp) :: temp(N,N)
    real(dp) :: DiffMat(N,N)

    real(dp) :: p,q
    integer :: i,j

    DiffMat = 0.0
    call DiffMatrix(N-1, dgnodes, DiffMat)

    temp = 0.0
    forall (j = 1:N, i = 1:N) temp(i,j) = -2 * dgweights(j)/dgweights(i) * DiffMat(j,i)

    p = real(N,dp)
    q = real(N,dp)

    mat = 0.0
    do j = 1,N_NODES; do i = 1,N_NODES
        mat(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * temp(i-floor((i-1)/p)*N, j-floor((j-1)/q)*N)
    end do; end do

    !! correct element length
    !mat = real(N_NODES,dp)/real(N,dp)*mat
    mat = -mat/real(N,dp)

# if 0
    write (*,*) 'nodes', qq, dgnodes
    write (*,*) 'weights', qq, dgweights

    write (*,*) qq, 'Riffdmat'
    do i = 1,N_NODES
        write (*,1001) diffrmat(i,:)
    end do
    write (*,*)

    write (*,*) qq, 'xDiffrMat'
    do i = 1,N_NODES
        write (*,1001) xDiffrMat(i,:,qq)
    end do
    write (*,*)

1001 format(PP_N_NODES(f12.3))
# endif

end subroutine

subroutine kernel_operators_WeakDGDiffMatrixV(N, dgnodes, dgweights, mat)

    use utils_mod, only: krondelta
    use interpol_mod, only: DiffMatrix

    integer, intent(in) :: N
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(in)    :: dgweights(N)
    real(dp), intent(out)   :: mat(N,N)

    real(dp) :: temp(N,N)
    real(dp) :: DiffMat(N,N)

    real(dp) :: p,q
    integer :: i,j

    DiffMat = 0.0
    call DiffMatrix(N-1, dgnodes, DiffMat)

    temp = 0.0
    forall (j = 1:N, i = 1:N) temp(i,j) = -2 * dgweights(j)/dgweights(i) * DiffMat(j,i)

    mat = temp

end subroutine

subroutine kernel_operators_AverageMatrix(N, mat)

    use utils_mod, only: krondelta

    integer, intent(in) :: N
    real(dp), intent(out)   :: mat(N_NODES,N_NODES)

    real(dp) :: p,q
    integer :: i,j

    p = real(N,dp)
    q = real(N,dp)

    mat = 0.0
    do j = 1,N_NODES; do i = 1,N_NODES
        mat(i,j) = 1/real(N,dp) * krondelta(ceiling(i/p),ceiling(j/q))
    end do; end do

# if 0
    write (*,*) 'AvgMat', qq
    do i = 1,N_NODES
        write (*,1001) AvgMat(i,:,qq)
    end do
    write (*,*)

1001 format(12(f7.2))
1002 format(24(f12.3))
# endif

end subroutine

!! --------------------------------------------------------------------- !!
!! Modal space operators

subroutine kernel_operators_ModalTrafoMatrix(N, dgnodes, toModal, toNodal)

    use utils_mod, only: krondelta
    use interpol_mod, only: mkVanderMondeMatrix

    integer, intent(in) :: N
    real(dp), intent(in)    :: dgnodes(N)

    real(dp), intent(out)   :: toModal(N_NODES,N_NODES)
    real(dp), intent(out)   :: toNodal(N_NODES,N_NODES)

    real(dp) :: toNodal_(N,N)
    real(dp) :: toModal_(N,N)

    real(dp) :: p,q
    integer :: i,j

    p = real(N,dp)
    q = real(N,dp)

    toNodal_ = 0.0
    toModal_ = 0.0
    call mkVanderMondeMatrix(n, dgnodes, toNodal_, toModal_)

    toNodal = 0
    toModal = 0
    do j = 1,N_NODES; do i = 1,N_NODES
        toNodal(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * toNodal_(i-floor((i-1)/p)*N, j-floor((j-1)/q)*N)
        toModal(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * toModal_(i-floor((i-1)/p)*N, j-floor((j-1)/q)*N)
    end do; end do
end subroutine

subroutine kernel_operators_ModalTrafoMatrix2(N, dgnodes, toModal, toNodal)

    use interpol_mod, only: mkVanderMondeMatrix

    integer, intent(in)     :: N
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(out)   :: toModal(N,N)
    real(dp), intent(out)   :: toNodal(N,N)

    toNodal = 0.0
    toModal = 0.0
    call mkVanderMondeMatrix(n, dgnodes, toNodal, toModal)

end subroutine

!! --------------------------------------------------------------------- !!
!! trafo operators: DG <-> FV

subroutine kernel_operators_dg2fvMatrix(N, M, dgnodes, dgweights, mat)

    use utils_mod, only: krondelta
    use subcellfv_mod, only: subcellfv_vanderMondeMatrix

    integer, intent(in)     :: N,M
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(in)    :: dgweights(N)
    real(dp), intent(out)   :: mat(M,M)

    real(dp) :: temp(N,N)

    real(dp) :: p,q
    integer :: i,j

    temp = 0.0
    call subcellfv_vanderMondeMatrix(N, N, dgnodes, dgweights, temp)

    p = real(N,dp)
    q = real(N,dp)

    mat = 0.0
    do j = 1,M; do i = 1,M
        mat(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * temp(i-floor((i-1)/p)*N, j-floor((j-1)/q)*N)
    end do; end do

end subroutine

subroutine kernel_operators_dg2fvMatrixV(N, M, dgnodes, dgweights, mat)

    use utils_mod, only: krondelta
    use subcellfv_mod, only: subcellfv_vanderMondeMatrix

    integer, intent(in)     :: N,M
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(in)    :: dgweights(N)
    real(dp), intent(out)   :: mat(M,N)

    real(dp) :: p,q
    integer :: i,j

    mat = 0.0
    call subcellfv_vanderMondeMatrix(N, M, dgnodes, dgweights, mat)

end subroutine

subroutine kernel_operators_refineMatrix(N, dgnodes, dgweights, mat)

    use utils_mod, only: krondelta
    use subcellfv_mod, only: subcellfv_vanderMondeMatrix

    integer, intent(in) :: N
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(in)    :: dgweights(N)
    real(dp), intent(out)   :: mat(2*N_NODES,N_NODES)

    real(dp) :: temp(2*N,N)

    real(dp) :: p,q
    integer :: i,j

    temp = 0.0
    call subcellfv_vanderMondeMatrix(N, 2*N, dgnodes, dgweights, temp)

    p = real(2*N,dp)
    q = real(N,dp)

    mat = 0.0
    do j = 1,N_NODES; do i = 1,2*N_NODES
        mat(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * temp(i-floor((i-1)/p)*2*N, j-floor((j-1)/q)*N)
    end do; end do

end subroutine

subroutine kernel_operators_coarsenMatrix(N, dgnodes, dgweights, mat)

    use utils_mod, only: krondelta
    use subcellfv_mod, only: subcellfv_vanderMondeMatrix

    integer, intent(in) :: N
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(in)    :: dgweights(N)
    real(dp), intent(out)   :: mat(N_NODES/2,N_NODES)

    real(dp) :: temp(N/2,N)

    real(dp) :: p,q
    integer :: i,j

    temp = 0.0
    call subcellfv_vanderMondeMatrix(N, N/2, dgnodes, dgweights, temp)

    p = real(N/2,dp)
    q = real(N,dp)

    mat = 0.0
    do j = 1,N_NODES; do i = 1,N_NODES/2
        mat(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * temp(i-floor((i-1)/p)*N/2, j-floor((j-1)/q)*N)
    end do; end do

end subroutine

subroutine kernel_operators_overMatrix(N, M, nodesA, nodesB, mat)

    use lagrange_mod, only: lagrange_VanderMondeMatrix

    integer, intent(in)     :: N, M
    real(dp), intent(in)    :: nodesA(N)
    real(dp), intent(in)    :: nodesB(M)
    real(dp), intent(out)   :: mat(M,N)

    call lagrange_VanderMondeMatrix(N, M, nodesA, nodesB, mat)

end subroutine

subroutine kernel_operators_revoMatrix(N, M, dgnodes, dgweights, mat)

    use utils_mod, only: krondelta
    use subcellfv_mod, only: subcellfv_vanderMondeMatrix

    integer, intent(in)     :: N, M
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(in)    :: dgweights(N)
    real(dp), intent(out)   :: mat(M,N)

    real(dp) :: temp(M,N)

    real(dp) :: p,q
    integer :: i,j

    call subcellfv_vanderMondeMatrix(N, M, dgnodes, dgweights, mat)

    !p = real(dp)(M)
    !q = real(dp)(N)

    !mat = 0.0
    !do j = 1,N; do i = 1,M
    !    mat(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * temp(i-floor((i-1)/p)*M, j-floor((j-1)/q)*N)
    !end do; end do

end subroutine

subroutine kernel_operators_interpolateBoundaryFVMatrix(N, dgnodes, fvnodes, mat)

    use utils_mod, only: krondelta
    use lagrange_mod, only: lagrange_polynomial

    integer, intent(in) :: N
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(in)    :: fvnodes(N)
    real(dp), intent(out)   :: mat(N_NODES,N_NODES)

    real(dp) :: temp(N,N)

    real(dp) :: p,q
    integer :: i,j

    temp = 0.0
    do j = 1,N; do i = 1,N
        temp(i,j) = lagrange_polynomial(n, dgnodes, i, fvnodes(j))
    end do; end do

    p = real(N,dp)
    q = real(N,dp)

    mat = 0.0
    do j = 1,N_NODES; do i = 1,N_NODES
        mat(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * temp(i-floor((i-1)/p)*n, j-floor((j-1)/q)*n)
    end do; end do

# if 0
        write (*,*) qq, 'dg2fvMat'
        do i = 1,N_NODES
            write (*,1001) dg2fvMat(i,:,qq)
        end do
        write (*,*)

        write (*,*) qq, 'fv2dgMat'
        do i = 1,N_NODES
            write (*,1001) fv2dgMat(i,:,qq)
        end do
        write (*,*)
1001 format(PP_N_NODES(f12.3))
1002 format(24(f12.3))
# endif

end subroutine

subroutine kernel_operators_interpolateBoundaryFVMatrix3(N, dgnodes, mat)

    use utils_mod, only: krondelta
    use utils_mod, only: eyeproduct
    use lagrange_mod, only: lagrange_polynomial
    use interpol_mod, only: EquidistAndInterfaceNodes_3times

    integer, intent(in)     :: N
    real(dp), intent(in)    :: dgnodes(N)
    real(dp), intent(out)   :: mat(3*N_NODES,N_NODES)

    real(dp) :: temp(3*N,N)
    real(dp) :: itfnodes(3*N)
    real(dp) :: itfweights(3*N)

    integer :: i,j

    call EquidistAndInterfaceNodes_3times(3*N, itfnodes, itfweights)

    do i = 1,3*N; do j = 1,N
        temp(i,j) = lagrange_polynomial(n, dgnodes, j, itfnodes(i))
    end do; end do

    mat = eyeproduct(N_NODES/N,temp)

# if 0
    write (*,*) 'lagriptlMat3',N
    do i = 1,3*N_NODES
        write (*,'(8(ES12.4))') mat(i,:)
    end do
    write (*,*)
# endif

end subroutine

subroutine kernel_operators_interpolateBoundaryDGMatrix(N, nodes, MatM, MatP)

    use utils_mod, only: krondelta
    use lagrange_mod, only: lagrange_polynomial
    use interpol_mod, only: InterfaceNodes

    integer, intent(in)     :: N
    real(dp), intent(in)    :: nodes(N)
    real(dp), intent(out)   :: matM(N_NODES-1,N_NODES)
    real(dp), intent(out)   :: matP(N_NODES-1,N_NODES)

    real(dp) :: tempM(N,N)
    real(dp) :: tempP(N,N)

    real(dp) :: p,q
    integer :: i,j

    real(dp), dimension(N) :: xL,xC,xR

    call InterfaceNodes(N,xL,xC,xR)

    tempM = 0.0
    tempP = 0.0
    !do i = 1,N; do j = 1,N
    do j = 1,N
        tempM(1,j) = lagrange_polynomial(N, nodes, j, -1.0_dp)
        tempP(N,j) = lagrange_polynomial(N, nodes, j,  1.0_dp)

        !tempM(i,j) = lagrange_polynomial(N, nodes, j, xL(i))
        !tempP(i,j) = lagrange_polynomial(N, nodes, j, xR(i))
    end do

    p = real(N,dp)
    q = real(N,dp)

    matM = 0.0
    matP = 0.0

    do i = 2,N_NODES; do j = 1,N_NODES
        matM(i-1,j) = krondelta(ceiling(i/p),ceiling(j/q)) * tempM(i-floor((i-1)/p)*n, j-floor((j-1)/q)*n)
    end do; end do

    do i = 1,N_NODES-1; do j = 1,N_NODES
        matP(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * tempP(i-floor((i-1)/p)*n, j-floor((j-1)/q)*n)
    end do; end do

# if 1
    write (*,*) 'lagritplMatM', N
    do i = 1,N_NODES-1
        write (*,'(8(ES12.4))') matM(i,:)
    end do
    write (*,*)

    write (*,*) 'lagritplMatP', N
    do i = 1,N_NODES-1
        write (*,'(8(ES12.4))') matP(i,:)
    end do
    write (*,*)
# endif

end subroutine

subroutine kernel_operators_interpolateBoundaryDGMatrixV(N, nodes, MatM, MatP)

    use utils_mod, only: krondelta
    use lagrange_mod, only: lagrange_polynomial

    integer, intent(in)     :: N
    real(dp), intent(in)    :: nodes(N)
    real(dp), intent(out)   :: matM(N_NODES-1,N_NODES)
    real(dp), intent(out)   :: matP(N_NODES-1,N_NODES)

    real(dp) :: tempM(N,N)
    real(dp) :: tempP(N,N)

    real(dp) :: p,q
    integer :: i,j

    tempM = 0.0
    tempP = 0.0
    do j = 1,N
        tempM(1,j) = lagrange_polynomial(N, nodes, j, -1.0_dp)
        tempP(N,j) = lagrange_polynomial(N, nodes, j,  1.0_dp)
    end do

    p = real(N,dp)
    q = real(N,dp)

    matM = 0.0
    matP = 0.0

    do i = 2,N_NODES-1; do j = 1,N_NODES
        matM(i-1,j) = krondelta(ceiling(i/p),ceiling(j/q)) * tempM(i-floor((i-1)/p)*n, j-floor((j-1)/q)*n)
    end do; end do

    do i = 1,N_NODES-1; do j = 1,N_NODES
        matP(i,j) = krondelta(ceiling(i/p),ceiling(j/q)) * tempP(i-floor((i-1)/p)*n, j-floor((j-1)/q)*n)
    end do; end do

# if 1
    write (*,*) 'lagritplMatM', N
    do i = 1,N_NODES-1
        write (*,'(8(ES12.4))') matM(i,:)
    end do
    write (*,*)

    write (*,*) 'lagritplMatP', N
    do i = 1,N_NODES-1
        write (*,'(8(ES12.4))') matP(i,:)
    end do
    write (*,*)
# endif

end subroutine

subroutine kernel_operators_interpolateBackMatrix(N, nodes, weights, MatM, MatP)

    use lagrange_mod, only: lagrange_polynomial

    integer, intent(in) :: N
    real(dp), intent(in)    :: nodes(N)
    real(dp), intent(in)    :: weights(N)
    real(dp), intent(out)   :: matM(N_NODES,N_NODES)
    real(dp), intent(out)   :: matP(N_NODES,N_NODES)

    real(dp) :: lagrVecM(N)
    real(dp) :: lagrVecP(N)

    real(dp) :: tempM(N,N)
    real(dp) :: tempP(N,N)

    real(dp) :: p,q
    integer :: i,j

    do i = 1,N
        LagrVecM(i) = lagrange_polynomial(n, nodes, i, -1.0_dp)
        lagrVecP(i) = lagrange_polynomial(n, nodes, i,  1.0_dp)
    end do

    tempM = spread(2./weights*lagrVecM,2,N)
    tempP = spread(2./weights*lagrVecP,2,N)

    p = real(N,dp)
    q = real(N,dp)

    matM = 0.0_dp
    matP = 0.0_dp
    do j = 1,N_NODES; do i = 1,N_NODES
        matM(i,j) = tempM(i-floor((i-1)/p)*N, j-floor((j-1)/q)*N)
        matP(i,j) = tempP(i-floor((i-1)/p)*N, j-floor((j-1)/q)*N)
    end do; end do

    matM = real(N_NODES,dp)/real(N,dp)*matM
    matP = real(N_NODES,dp)/real(N,dp)*matP

# if 0
    write (*,*) 'xmLagrM'
    do i = 1,N_NODES
        write (*,1001) xmLagrM(i,:,qq)
    end do
    write (*,*)

    write (*,*) 'xmLagrP'
    do i = 1,N_NODES
        write (*,1001) xmLagrP(i,:,qq)
    end do
    write (*,*)

1001 format(PP_N_NODES(f12.3))
1002 format(24(f12.3))
# endif
end subroutine

subroutine kernel_operators_surfaceMatrix(N, nodes, weights, surfMat)

    use lagrange_mod, only: lagrange_polynomial

    integer, intent(in)     :: N
    real(dp), intent(in)    :: nodes(N)
    real(dp), intent(in)    :: weights(N)

    real(dp), intent(out)   :: surfMat(N_NODES,N_NODES)

    real(dp) :: matM(N_NODES,N_NODES)
    real(dp) :: matP(N_NODES,N_NODES)

    real(dp) :: lagrM(N_NODES)
    real(dp) :: lagrP(N_NODES)

    integer :: i,j

    do i = 1,N_NODES
        lagrM(i) = 2.0_dp/REAL(N,dp)/weights(i)*lagrange_polynomial(N, nodes, i, -1.0_dp)
        lagrP(i) = 2.0_dp/REAL(N,dp)/weights(i)*lagrange_polynomial(N, nodes, i,  1.0_dp)
    end do

    matM = 0.0_dp
    matP = 0.0_dp

    matM(:,1      ) = lagrM
    matP(:,N_NODES) = lagrP

    surfMat = matM - matP

end subroutine

subroutine kernel_operators_surfaceMatrix_ext(N,M, nodes, weights, surfMat)

    use utils_mod, only: krondelta
    use share_mod, only: rt => runtime
    use lagrange_mod, only: lagrange_polynomial

    integer, intent(in)     :: N,M
    real(dp), intent(in)    :: nodes(N)
    real(dp), intent(in)    :: weights(N)

    real(dp), intent(out)   :: surfMat(M,M+1)

    real(dp) :: matM(M,M+1)
    real(dp) :: matP(M,M+1)

    real(dp) :: lagrM(M)
    real(dp) :: lagrP(M)

    integer :: i,j

    do i = 1,M
        !lagrM(i) = REAL(N_NODES,dp)/REAL(N,dp)*2./weights(mod(i-1,N)+1)*lagrange_polynomial(N, nodes, mod(i-1,N)+1, -1.0_dp)
        !lagrP(i) = REAL(N_NODES,dp)/REAL(N,dp)*2./weights(mod(i-1,N)+1)*lagrange_polynomial(N, nodes, mod(i-1,N)+1,  1.0_dp)
        !lagrM(i) = 2.0_dp/REAL(N,dp)/weights(mod(i-1,N)+1)*lagrange_polynomial(N, nodes, mod(i-1,N)+1, -1.0_dp)
        !lagrP(i) = 2.0_dp/REAL(N,dp)/weights(mod(i-1,N)+1)*lagrange_polynomial(N, nodes, mod(i-1,N)+1,  1.0_dp)

        lagrM(i) = 2.0_dp/weights(mod(i-1,N)+1)*lagrange_polynomial(N, nodes, mod(i-1,N)+1, -1.0_dp)
        lagrP(i) = 2.0_dp/weights(mod(i-1,N)+1)*lagrange_polynomial(N, nodes, mod(i-1,N)+1,  1.0_dp)
    end do

    matM = 0.0_dp
    matP = 0.0_dp

    do j = 1,M+1; do i = 1,M
        matM(i,j) = lagrM(i) * krondelta(0 + 1 + N * ((i-1)/N), j)
        matP(i,j) = lagrP(i) * krondelta(N + 1 + N * ((i-1)/N), j)
    end do; end do

    surfMat = matM - matP

# if 0
    if (rt%mpi%isroot) then
        !write (*,*) 'matM', N
        !do i = 1,N_NODES
        !    write (*,'(9(ES12.4))') matM(i,:)
        !end do
        !write (*,*)
        !write (*,*) 'matP', N
        !do i = 1,N_NODES
        !    write (*,'(9(ES12.4))') matP(i,:)
        !end do
        !write (*,*)

        write (*,*) 'surfMat', N
        do i = 1,N_NODES
            write (*,'(9(ES12.4))') surfMat(i,:)
        end do
        write (*,*)
    end if
# endif

end subroutine

subroutine kernel_operators_surfaceMatrix_split(N, nodes, weights, surfMatM, surfMatP)

    use utils_mod, only: krondelta
    use share_mod, only: rt => runtime
    use lagrange_mod, only: lagrange_polynomial

    integer, intent(in)     :: N
    real(dp), intent(in)    :: nodes(N)
    real(dp), intent(in)    :: weights(N)

    real(dp), intent(out)   :: surfMatM(N_NODES,N_NODES+1)
    real(dp), intent(out)   :: surfMatP(N_NODES,N_NODES+1)

    real(dp) :: matM(N_NODES,N_NODES+1)
    real(dp) :: matP(N_NODES,N_NODES+1)

    real(dp) :: lagrM(N_NODES)
    real(dp) :: lagrP(N_NODES)

    integer :: i,j

    do i = 1,N_NODES
        !lagrM(i) = REAL(N_NODES,dp)/REAL(N,dp)*2./weights(mod(i-1,N)+1)*lagrange_polynomial(N, nodes, mod(i-1,N)+1, -1.0_dp)
        !lagrP(i) = REAL(N_NODES,dp)/REAL(N,dp)*2./weights(mod(i-1,N)+1)*lagrange_polynomial(N, nodes, mod(i-1,N)+1,  1.0_dp)
        lagrM(i) = 2.0_dp/REAL(N,dp)/weights(mod(i-1,N)+1)*lagrange_polynomial(N, nodes, mod(i-1,N)+1, -1.0_dp)
        lagrP(i) = 2.0_dp/REAL(N,dp)/weights(mod(i-1,N)+1)*lagrange_polynomial(N, nodes, mod(i-1,N)+1,  1.0_dp)
    end do

    matM = 0.0_dp
    matP = 0.0_dp

    do j = 1,N_NODES+1; do i = 1,N_NODES
        matM(i,j) = lagrM(i) * krondelta(0 + 1 + N * ((i-1)/N), j)
        matP(i,j) = lagrP(i) * krondelta(N + 1 + N * ((i-1)/N), j)
    end do; end do

    surfMatM =  matM
    surfMatP = -matP

end subroutine

!! FV difference operator
subroutine kernel_operators_FVDifferenceMatrix(mat)

    use utils_mod, only: krondelta

    real(dp), intent(out) :: mat(1:N_NODES,0:N_NODES)

    integer :: i,j

    mat = 0.0
    do j = 0,N_NODES; do i = 1,N_NODES
        mat(i,j) = krondelta(i-1,j) - krondelta(i,j)
    end do; end do

    mat = N_NODES * mat

end subroutine

!! FV surface operator
subroutine kernel_operators_FVProlongBackMatrix(mat)

    use utils_mod, only: krondelta

    real(dp), intent(out)   :: mat(N_NODES,2*N_NODES,2)

    integer :: i,j

    mat = 0.0

    do j = 1,2*N_NODES; do i = 1,N_NODES
        mat(i,j,1) = krondelta(i,j)
        mat(i,j,2) = 0.5*(krondelta(i*2-1,j) + krondelta(i*2,j))
    end do; end do

# if 0
    write (*,*) 'prolongBack'
    do i = 1,N_NODES
        write (*,1002) prolongBack(i,:,0,2)
    end do
    write (*,*)

1001 format(PP_N_NODES(f8.3))
1002 format(16(f6.2))
# endif

end subroutine

!! FV surface operator
subroutine kernel_operators_FVProlongBackMatrixN(N,mat)

    use utils_mod, only: krondelta

    integer, intent(in)     :: N
    real(dp), intent(out)   :: mat(N,2*N)

    integer :: i,j

    mat = 0.0
    do j = 1,2*N; do i = 1,N
        mat(i,j) = 0.5*(krondelta(i*2-1,j) + krondelta(i*2,j))
    end do; end do

end subroutine

!! FV simpson rule operator
subroutine kernel_operators_SimpsonRuleMatrixN(N,mat)

    integer, intent(in)     :: N
    real(dp), intent(out)   :: mat(N,3*N)

    integer :: i,j

    real(dp), parameter :: coeffs(3) = (/1.0_dp,4.0_dp,1.0_dp/) / 6.0_dp
    !real(dp), parameter :: coeffs(3) = (/0.0_dp,1.0_dp,0.0_dp/)

    mat = 0.0
    do i = 1,N; do j = (i-1)*3 + 2,i*3,3
        mat(i,j-1) = coeffs(1)
        mat(i,j+0) = coeffs(2)
        mat(i,j+1) = coeffs(3)
    end do; end do

end subroutine

pure subroutine kernel_operators_InterfaceNodes(N,xs,xL,xC,xR,x3)

    implicit none

    integer,intent(in)      :: N
    real(dp), intent(in)    :: xs(3)
    real(dp),intent(out)    :: xL(N),xC(N),xR(N),x3(3*N)

    integer :: i

    do i = 1,N
        xL(i) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp) + xs(1)/real(N,dp)
        xC(i) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp) + xs(2)/real(N,dp)
        xR(i) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp) + xs(3)/real(N,dp)
    end do

    do i = 1,N
        x3(3*(i-1)+1) = xL(i)
        x3(3*(i-1)+2) = xC(i)
        x3(3*(i-1)+3) = xR(i)
    end do

end subroutine

subroutine kernel_operators_faceMatrix(N,L, M,P, xnodes, ynodes, mat)

    !! asuming nodes are within [-0.5,0.5]

    use utils_mod, only: krondelta
    use lagrange_mod, only: lagrange_polynomial

    integer, intent(in)     :: N,L, M,P
    real(dp), intent(in)    :: xnodes(L)
    real(dp), intent(in)    :: ynodes(P)
    real(dp), intent(out)   :: mat(M,N)

    real(dp) :: xbd(-1:1,N/L) !! left,center,right
    real(dp) :: ybd(-1:1,M/P) !! left,center,right

    real(dp) :: xxnodes(N)
    real(dp) :: yynodes(M)

    real(dp) :: dx, dxx, dy, prefac, ofsL, ofsR
    integer :: i,j, ii,jj,iii

    integer :: Nx,Ny

    real(dp), parameter :: tol = 1e-9

    Nx = N/L
    Ny = M/P

    dx = 1.0_dp/real(Nx,dp)
    dy = 1.0_dp/real(Ny,dp)

    !! compute boundaries of input sub-elements
    do i = 1,Nx
        xbd(-1,i) = -0.5_dp + (i-1.0_dp)*dx
        xbd( 0,i) = -0.5_dp + (i-0.5_dp)*dx
        xbd( 1,i) = -0.5_dp + (i       )*dx
    end do

    !! compute boundaries of output sub-elements
    do i = 1,Ny
        ybd(-1,i) = -0.5_dp + (i-1.0_dp)*dy
        ybd( 0,i) = -0.5_dp + (i-0.5_dp)*dy
        ybd( 1,i) = -0.5_dp + (i       )*dy
    end do

    !! compute destination nodes
    do i = 1,Ny
        do ii = 1,P
            yynodes((i-1)*P+ii) = ybd(0,i) + dy*ynodes(ii)
        end do
    end do

    !! compute interpolation matrix
    mat = 0.0_dp
    do iii = 1,Ny
        do ii= 1,P
            i = (iii-1)*P+ii

            if (ii == 1) then
                ofsL = tol
                ofsR = 0.0_dp

            else if (ii == P) then
                ofsL = 0.0_dp
                ofsR = -tol
            end if

            do j = 1,Nx

                if (abs(ybd( 1,iii) - yynodes(i)) > tol .and. abs(xbd(1,j) - yynodes(i)) <= tol) then
                    do jj = 1,L
                        mat(i,(j-1)*L + jj) = 0.5*lagrange_polynomial(L, xnodes, jj, 0.5_dp)
                    end do

                    cycle
                endif

                if (abs(ybd(-1,iii) - yynodes(i)) > tol .and. abs(xbd(-1,j) - yynodes(i)) <= tol) then
                    do jj = 1,L
                        mat(i,(j-1)*L + jj) = 0.5*lagrange_polynomial(L, xnodes, jj, -0.5_dp)
                    end do

                    cycle
                endif

                if (xbd(-1,j) < yynodes(i) + ofsL .and. yynodes(i) + ofsR < xbd(1,j)) then

                    dxx = abs(xbd(-1,j) - yynodes(i))/dx
                    do jj = 1,L
                        mat(i,(j-1)*L + jj) = lagrange_polynomial(L, xnodes, jj, -0.5_dp + dxx)
                    end do

                    exit
                end if

            end do
        end do
    end do

# if 0
    write (*,*) N,L,M,P,'faceMat'
    do i = 1,M
        write (*,'(99(ES12.4))') Mat(i,:)
    end do
    write (*,*)
# endif

end subroutine

subroutine kernel_operators_interpolationMatrix(N,M,Q, xs,ws, ys,vs, mat)

    use lagrange_mod, only: lagrange_polynomial

    integer, intent(in)     :: N,M,Q        !! # of xs-nodes, ys-nodes, sub-elements
    real(dp), intent(in)    :: xs(N),ws(N)  !! nodes, weights of source element
    real(dp), intent(in)    :: ys(M),vs(M)  !! nodes, weights of target sub-elements
    real(dp), intent(out)   :: mat(M,N,Q)

    real(dp) :: xL,xR   !! left,right boundaries
    real(dp) :: mu(Q)   !! center nodes of sub-elements
    real(dp) :: xi(N,Q) !! scaled quadrature nodes of 'xs' around center nodes 'mu'

    integer :: i,j,k

    !! works for reference elements of arbitrary size
    xL = -0.5*sum(vs)
    xR = -xL

    !! make body-centered linear space
    forall (k = 1:Q)
        mu(k) = xL + (k-0.5)*abs(xR-xL)/Q
    end forall

    !! interpolation nodes within each sub-element of master element
    forall (k = 1:Q, i = 1:M)
        xi(i,k) = mu(k) + ys(i)/Q
    end forall

    !! interpolation matrices
    forall (k = 1:Q, j = 1:N, i = 1:M)
        mat(i,j,k) = lagrange_polynomial(N,xs,j,xi(i,k))
    end forall

# if 0
    do k = 1,Q
        write (*,*) 'interpolationMat',N,M,Q,k
        do i = 1,M
            write (*,'(99(ES12.4))') mat(i,:,k)
        end do
        write (*,*)
    end do
# endif

end subroutine

subroutine kernel_operators_projectionMatrix(N,M,Q, xs,ws, ys,vs, mat)

    use lagrange_mod, only: lagrange_polynomial

    integer, intent(in)     :: N,M,Q        !! # of xs-nodes, ys-nodes, sub-elements
    real(dp), intent(in)    :: xs(N),ws(N)  !! nodes, weights of sub-elements
    real(dp), intent(in)    :: ys(M),vs(M)  !! nodes, weights of target element
    real(dp), intent(out)   :: mat(M,N,Q)

    real(dp) :: xL,xR   !! left,right boundaries
    real(dp) :: mu(Q)   !! center nodes of sub-elements
    real(dp) :: xi(N,Q) !! scaled quadrature nodes of 'xs' around center nodes 'mu'

    integer :: i,j,k

    !! works for reference elements of arbitrary size
    xL = -0.5*sum(vs)
    xR = -xL

    !! make body-centered linear space
    forall (k = 1:Q)
        mu(k) = xL + (k-0.5)*abs(xR-xL)/Q
    end forall

    !! interpolation nodes within each sub-element of master element
    forall (k = 1:Q, j = 1:N)
        xi(j,k) = mu(k) + xs(j)/Q
    end forall

    !! projection matrices
    forall (k = 1:Q, j = 1:N, i = 1:M)
        mat(i,j,k) = lagrange_polynomial(M,ys,i,xi(j,k))*ws(j)/vs(i)/Q
    end forall

# if 0
    do k = 1,Q
        write (*,*) 'projectionMat',N,M,Q,k
        do i = 1,M
            write (*,'(99(ES12.4))') mat(i,:,k)
        end do
        write (*,*)
    end do
# endif

end subroutine

end module