!=============================================================================!
        subroutine wallbc(vl, rhow, pnorm)
!=============================================================================!
        use stuff
        use material
        use diff
        implicit none

        real :: vl(ny,nx,ndof), rhow(nx), Pnorm(nx)
        integer :: iz
        logical :: carp

!.... local wall variables

        integer :: i, j, ij, idof, jdof

        real :: g1v(nx,ndof), g2v(nx,ndof)
        real :: g11v(nx,ndof), g12v(nx,ndof), g22v(nx,ndof)
        real :: g1vl, g2vl, g11vl, g12vl, g22vl

        real :: g1divu(nx), g2divu(nx)
        real :: S1jj(nx), S2jj(nx)
        real :: divu(nx)
        real :: S(nx,2,2)
        real :: mu(nx),     lm(nx),     con(nx)
        real :: dmu(nx),    d2mu(nx)
        real :: dlm(nx),    d2lm(nx)
        real :: dcon(nx),   d2con(nx)
        real :: g1mu(nx),   g2mu(nx)
        real :: g1lm(nx),   g2lm(nx)
        real :: g1con(nx),  g2con(nx)
        real :: g1dmu(nx),  g2dmu(nx)
        real :: g1dlm(nx),  g2dlm(nx)
        real :: g1dcon(nx), g2dcon(nx)

!.... stuff for the wall normal pressure gradient

        real :: bn1(nx), bn2(nx)
!=============================================================================!

        carp = .false.
        if (impl.eq.0) carp = .true.

!.... Compute first derivatives of field in the mapped space

        call wgrad(ndof, nx, ny, vl, g1v, g2v, dxi, deta, optx, opty, &
                   xper, yper, lsym, rsym, bsym, tsym, carp)

!.... Compute second derivatives of field

        call wgrad2(ndof, nx, ny, vl, g2v, g11v, g12v, g22v, dxi, deta, &
                    optx, opty, xper, yper, lsym, rsym, bsym, tsym, carp)

!.... enforce adiabatic wall BC on the field

        if (wallt.eq.1 .or. wallt.eq.2) g2v(:,ndof) = zero

!.... transform the gradients to physical space

        j = 1
        do idof = 1, ndof
          do i = 1, nx
            ij = j + (i-1)*ny
            g1vl  = g1v(i,idof)*m1(ij) + g2v(i,idof)*n1(ij)
            g2vl  = g1v(i,idof)*m2(ij) + g2v(i,idof)*n2(ij)

            g11vl = g11v(i,idof)       * m1m1(ij)       + &
                    two * g12v(i,idof) * m1n1(ij)       + &
                    g22v(i,idof)       * n1n1(ij)       + &
                    g1v(i,idof)        * m11(ij)        + &
                    g2v(i,idof)        * n11(ij)

            g12vl = g11v(i,idof)       * m1m2(ij)       + &
                    g12v(i,idof)       * m1n2(ij)       + &
                    g12v(i,idof)       * m2n1(ij)       + &
                    g22v(i,idof)       * n1n2(ij)       + &
                    g1v(i,idof)        * m12(ij)        + &
                    g2v(i,idof)        * n12(ij)

            g22vl = g11v(i,idof)       * m2m2(ij)       + &
                    two * g12v(i,idof) * m2n2(ij)       + &
                    g22v(i,idof)       * n2n2(ij)       + &
                    g1v(i,idof)        * m22(ij)        + &
                    g2v(i,idof)        * n22(ij)

            g1v(i,idof)  = g1vl
            g2v(i,idof)  = g2vl
            g11v(i,idof) = g11vl
            g12v(i,idof) = g12vl
            g22v(i,idof) = g22vl
          end do
        end do

!=============================================================================!
!.... setup local variables
!=============================================================================!

!.... compute the gradient of the divergence of um

        g1divu = g11v(:,2) + g12v(:,3)
        g2divu = g12v(:,2) + g22v(:,3)

!.... compute strain rate tensor for the viscous terms

        S1jj = pt5 * ( g11v(:,2) + g11v(:,2) + g22v(:,2) + &
                       g12v(:,3) )

        S2jj = pt5 * ( g11v(:,3) + g12v(:,2) + g22v(:,3) + &
                       g22v(:,3) )

!.... compute divergence

        divu = g1v(:,2) + g2v(:,3)

!.... compute strain rate tensor for the viscous terms

        S(:,1,1) = g1v(:,2)
        S(:,1,2) = pt5 * ( g2v(:,2) + g1v(:,3) )
        S(:,2,1) = pt5 * ( g1v(:,3) + g2v(:,2) )
        S(:,2,2) = g2v(:,3)

!.... compute the material properties

        call getmat(vl(1,:,ndof),                       &
                    mu(:),   lm(:),    con(:),          &
                    dmu(:),  d2mu(:),  dlm(:),          &
                    d2lm(:), dcon(:),  d2con(:)         )

!.... compute gradients of viscosity using chain-rule

        g1mu = dmu * g1v(:,5)
        g2mu = dmu * g2v(:,5)

        g1dmu = d2mu * g1v(:,5)
        g2dmu = d2mu * g2v(:,5)

!.... compute gradients of conductivity using chain-rule

        g1con = dcon * g1v(:,5)
        g2con = dcon * g2v(:,5)

        g1dcon = d2con * g1v(:,5)
        g2dcon = d2con * g2v(:,5)

!.... compute gradients of bulk viscosity using chain-rule

        g1lm = dlm * g1v(:,5)
        g2lm = dlm * g2v(:,5)

        g1dlm = d2lm * g1v(:,5)
        g2dlm = d2lm * g2v(:,5)

!=============================================================================!

!.... compute the boundary normal unit-vector

        j = 1
        do i = 1, nx
          ij = j + (i-1) * ny
          bn1(i)  = n1(ij) / sqrt( n1(ij)**2 + n2(ij)**2 )
          bn2(i)  = n2(ij) / sqrt( n1(ij)**2 + n2(ij)**2 )
        end do

!.... wall normal pressure gradient from the normal momentum equation
!.... Note that Pnorm is normalized by 1/sqrt(n1^2 + n2^2)

        do i = 1, nx
          ij = j + (i-1) * ny

          Pnorm(i) = one / Re * (                                           &
            divu(i) * ( g1lm(i) * bn1(i) + g2lm(i) * bn2(i) )             + &
            lm(i)   * ( g1divu(i) * bn1(i) + g2divu(i) * bn2(i) )         + &
            two * mu(i) * ( S1jj(i) * bn1(i) + S2jj(i) * bn2(i) )         + &
            two * ( g1mu(i) * S(i,1,1) + g2mu(i) * S(i,1,2) ) * bn1(i)    + &
            two * ( g1mu(i) * S(i,2,1) + g2mu(i) * S(i,2,2) ) * bn2(i) ) /  &
            sqrt( n1(ij)**2 + n2(ij)**2 )

!         Pnorm(i) = one / Re * (                                             &
!           damp(ij) * g1lm(i) * divu(i) * bn1(i)                           + &
!           g2lm(i) * ( damp(ij) * g1v(i,2) + g2v(i,3) ) * bn2(i)           + &
!           lm(i)   * ( damp(ij) * g1divu(i) *  bn1(i)                      + &
!                        g2divu(i) * bn2(i) )                               + &
!           mu(i) * ( ( damp(ij) * two * g11v(i,2) + g22v(i,2)              + &
!                       damp(ij) * g12v(i,3) ) * bn1(i)                     + &
!                     ( damp(ij) * g11v(i,3) + damp(ij) * g12v(i,2)         + &
!                       two * g22v(i,3) ) * bn2(i) )                        + &
!           ( g1mu(i) * damp(ij) * two * g1v(i,2)                           + &
!             g2mu(i) * ( g2v(i,2) + damp(ij) * g1v(i,3) ) ) * bn1(i)       + &
!           ( g1mu(i) * ( damp(ij) * g1v(i,3) + g2v(i,2) )                  + &
!             g2mu(i) * two * g2v(i,3) ) * bn2(i) )                         / &
!            sqrt( n1(ij)**2 + n2(ij)**2 )
        end do

!.... now compute the wall density using the normal momentum equation

!.... WARNING: This assumes that T,n = 0

        j = 1
        do i = 1, nx
          ij = j + (i-1) * ny
          if (carp) then
            rhow(i) = ( deta * gamma * Ma**2 * Pnorm(i) / vl(1,i,5) -   &
                        gg2 * vl(2,i,1) -                               &
                        gg3 * vl(3,i,1) -                               &
                        gg4 * vl(4,i,1) -                               &
                        gg5 * vl(5,i,1) -                               &
                        gg6 * vl(6,i,1) ) / gg1
          else
            rhow(i) = ( deta * gamma * Ma**2 * Pnorm(i) / vl(1,i,5) -   &
                        gc2 * vl(2,i,1) -                               &
                        gc3 * vl(3,i,1) -                               &
                        gc4 * vl(4,i,1) -                               &
                        gc5 * vl(5,i,1) ) / gc1
          end if
        end do

        return
        end

!=============================================================================!
        subroutine wgrad( ndof, nx, ny, v, g1v, g2v, dx, dy, optx, opty, &
                          xper, yper, lsym, rsym, bsym, tsym, carp)
!
!  Take the gradient of a 2-D field at the wall.
!
!=============================================================================!
        use diff
        implicit none

        integer :: ndof, nx, ny, optx, opty
        logical :: xper, yper
        logical :: lsym, rsym, bsym, tsym, carp
        real    :: v(ny,nx,ndof), g1v(nx,ndof), g2v(nx,ndof)
        real    :: dx, dy

        real,parameter :: one = 1.0
        real dxinv, dyinv
        real a, b, c, w
        real gx1, gx2, gx3, gx4, gx5, gx6
        real gy1, gy2, gy3, gy4, gy5, gy6

        integer :: idof
        real :: isign
!=============================================================================!

        dxinv  = one / dx
        dyinv  = one / dy

!.... seven point stencil in x

        if (optx.eq.0) then
          c = 1.0 / 60.0
        else if (optx.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gx1 =  -c * dxinv
        gx2 =  -b * dxinv
        gx3 =  -a * dxinv
        gx4 =   a * dxinv
        gx5 =   b * dxinv
        gx6 =   c * dxinv

!.... seven point stencil in y

        if (opty.eq.0) then
          c = 1.0 / 60.0
        else if (opty.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gy1 =  -c * dyinv
        gy2 =  -b * dyinv
        gy3 =  -a * dyinv
        gy4 =   a * dyinv
        gy5 =   b * dyinv
        gy6 =   c * dyinv

!=============================================================================!
!.... compute the gradient in x
!=============================================================================!

        if (xper) then

          g1v(1,:)          = ( gx1 * v(1,nx-3,:)       + &
                                gx2 * v(1,nx-2,:)       + &
                                gx3 * v(1,nx-1,:)       + &
                                gx4 * v(1,2,:)          + &
                                gx5 * v(1,3,:)          + &
                                gx6 * v(1,4,:)  )

          g1v(2,:)          = ( gx1 * v(1,nx-2,:)       + &
                                gx2 * v(1,nx-1,:)       + &
                                gx3 * v(1,1,:)          + &
                                gx4 * v(1,3,:)          + &
                                gx5 * v(1,4,:)          + &
                                gx6 * v(1,5,:)  )

          g1v(3,:)          = ( gx1 * v(1,nx-1,:)       + &
                                gx2 * v(1,1,:)          + &
                                gx3 * v(1,2,:)          + &
                                gx4 * v(1,4,:)          + &
                                gx5 * v(1,5,:)          + &
                                gx6 * v(1,6,:)  )

          g1v(nx-2,:)       = ( gx1 * v(1,nx-5,:)       + &
                                gx2 * v(1,nx-4,:)       + &
                                gx3 * v(1,nx-3,:)       + &
                                gx4 * v(1,nx-1,:)       + &
                                gx5 * v(1,1,:)          + &
                                gx6 * v(1,2,:)  )

          g1v(nx-1,:)       = ( gx1 * v(1,nx-4,:)       + &
                                gx2 * v(1,nx-3,:)       + &
                                gx3 * v(1,nx-2,:)       + &
                                gx4 * v(1,1,:)          + &
                                gx5 * v(1,2,:)          + &
                                gx6 * v(1,3,:)  )

          g1v(nx,:)     = g1v(1,:)

        else

          g1v(1,:)      = ( gc1 * v(1,1,:)  + &
                            gc2 * v(1,2,:)  + &
                            gc3 * v(1,3,:)  + &
                            gc4 * v(1,4,:)  + &
                            gc5 * v(1,5,:)  ) * dxinv

          g1v(2,:)      = ( gb1 * v(1,1,:)  + &
                            gb2 * v(1,2,:)  + &
                            gb3 * v(1,3,:)  + &
                            gb4 * v(1,4,:)  + &
                            gb5 * v(1,5,:)  ) * dxinv

          g1v(3,:)      = ( ga1 * v(1,1,:)  + &
                            ga2 * v(1,2,:)  + &
                            ga3 * v(1,4,:)  + &
                            ga4 * v(1,5,:)  ) * dxinv

          g1v(nx-2,:)   = ( ga1 * v(1,nx-4,:)  + &
                            ga2 * v(1,nx-3,:)  + &
                            ga3 * v(1,nx-1,:)  + &
                            ga4 * v(1,nx  ,:)  ) * dxinv

          g1v(nx-1,:)  = -( gb1 * v(1,nx  ,:)  + &
                            gb2 * v(1,nx-1,:)  + &
                            gb3 * v(1,nx-2,:)  + &
                            gb4 * v(1,nx-3,:)  + &
                            gb5 * v(1,nx-4,:)  ) * dxinv

          g1v(nx,:)    = -( gc1 * v(1,nx  ,:)  + &
                            gc2 * v(1,nx-1,:)  + &
                            gc3 * v(1,nx-2,:)  + &
                            gc4 * v(1,nx-3,:)  + &
                            gc5 * v(1,nx-4,:)  ) * dxinv

        end if

!.... implement the symmetric conditions

        if (lsym) then
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if

            g1v(1,:)        = ( isign * gx1 * v(1,4,:)  + &
                                isign * gx2 * v(1,3,:)  + &
                                isign * gx3 * v(1,2,:)  + &
                                gx4 * v(1,2,:)          + &
                                gx5 * v(1,3,:)          + &
                                gx6 * v(1,4,:)          )

            g1v(2,:)        = ( isign * gx1 * v(1,3,:)  + &
                                isign * gx2 * v(1,2,:)  + &
                                gx3 * v(1,1,:)          + &
                                gx4 * v(1,3,:)          + &
                                gx5 * v(1,4,:)          + &
                                gx6 * v(1,5,:)          )

            g1v(3,:)        = ( isign * gx1 * v(1,2,:)  + &
                                gx2 * v(1,1,:)          + &
                                gx3 * v(1,2,:)          + &
                                gx4 * v(1,4,:)          + &
                                gx5 * v(1,5,:)          + &
                                gx6 * v(1,6,:)          )
          end do
        end if

!.... interior

        g1v(4:nx-3,:)  = ( gx1 * v(1,1:nx-6,:)  + &
                           gx2 * v(1,2:nx-5,:)  + &
                           gx3 * v(1,3:nx-4,:)  + &
                           gx4 * v(1,5:nx-2,:)  + &
                           gx5 * v(1,6:nx-1,:)  + &
                           gx6 * v(1,7:nx  ,:)  )

!=============================================================================!
!.... compute the gradient in y
!=============================================================================!

          g2v(:,:)     = ( gc1 * v(1,:,:)       + &
                           gc2 * v(2,:,:)       + &
                           gc3 * v(3,:,:)       + &
                           gc4 * v(4,:,:)       + &
                           gc5 * v(5,:,:)  ) * dyinv

          if (carp) then

          g2v(:,:)     = ( gg1 * v(1,:,:)       + &
                           gg2 * v(2,:,:)       + &
                           gg3 * v(3,:,:)       + &
                           gg4 * v(4,:,:)       + &
                           gg5 * v(5,:,:)       + &
                           gg6 * v(6,:,:)  ) * dyinv
          end if

        return
        end

!=============================================================================!
        subroutine wgrad2 (ndof, nx, ny, v, g2v, g11v, g12v, g22v, dx, dy, &
                           optx, opty, xper, yper, lsym, rsym, bsym, tsym, &
                           carp)
!
!  Take the second derivative of a 2-D field at the wall.
!  Updated to sixth order accurate differencing on the interior with
!  the option for optimized fourth order differencing.
!
!  Added g2v as input to improve efficiency
!
!=============================================================================!
        use diff
        implicit none

        integer :: ndof, nx, ny, optx, opty
        logical :: xper, yper
        logical :: lsym, rsym, bsym, tsym, carp
        real    :: v(ny,nx,ndof), g2v(nx,ndof)
        real    :: g11v(nx,ndof), g12v(nx,ndof), g22v(nx,ndof)
        real    :: dx, dy

        real, parameter :: one = 1.0
        real :: dxinv, dyinv, dxsinv, dysinv
        real :: a, b, c, w
        real :: gx1, gx2, gx3, gx4, gx5, gx6
        real :: gy1, gy2, gy3, gy4, gy5, gy6
        real :: dx1, dx2, dx3, dx4, dx5, dx6, dx7
        real :: dy1, dy2, dy3, dy4, dy5, dy6, dy7

        integer :: idof, isign
!=============================================================================!

        dxinv  = one / dx
        dyinv  = one / dy
        dxsinv = one / dx**2
        dysinv = one / dy**2

!.... seven point stencil in x

        if (optx.eq.0) then
          c = 1.0 / 60.0
        else if (optx.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gx1 =  -c * dxinv
        gx2 =  -b * dxinv
        gx3 =  -a * dxinv
        gx4 =   a * dxinv
        gx5 =   b * dxinv
        gx6 =   c * dxinv

        if (optx.eq.0) then
          c = 1.0 / 90.0
        else if (optx.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = -(3.0*w**2 - 16.0*Sin(w/2.0)**2 + Sin(w)**2) / &
               (12.0*(-15.0*Sin(w/2.0)**2 + 6.0*Sin(w)**2 -  &
               Sin(3.0*w/2.0)**2))
        end if

        a = (4.0 + 45.0 * c) / 3.0
        b = -(1.0 + 72.0 * c) / 12.0

        dx1 =  c * dxsinv
        dx2 =  b * dxsinv
        dx3 =  a * dxsinv
        dx4 = -2.0 * ( a + b + c ) * dxsinv
        dx5 =  a * dxsinv
        dx6 =  b * dxsinv
        dx7 =  c * dxsinv

!.... seven point stencil in y

        if (opty.eq.0) then
          c = 1.0 / 60.0
        else if (opty.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = (w/2.0 - 2.0*Sin(w)/3.0 + Sin(2.0*w)/12.0) / &
              (5.0*Sin(w) - 4.0*Sin(2.0*w) + Sin(3.0*w))
        end if

        a = (2.0 + 15.0 * c) / 3.0
        b = -(1.0 + 48.0 * c) / 12.0

        gy1 =  -c * dyinv
        gy2 =  -b * dyinv
        gy3 =  -a * dyinv
        gy4 =   a * dyinv
        gy5 =   b * dyinv
        gy6 =   c * dyinv

        if (opty.eq.0) then
          c = 1.0 / 90.0
        else if (opty.eq.-1) then
          c = 0.0
        else
          w = 2.0 * 3.1415926535897932385e+0 / 12.0
          c = -(3.0*w**2 - 16.0*Sin(w/2.0)**2 + Sin(w)**2) / &
               (12.0*(-15.0*Sin(w/2.0)**2 + 6.0*Sin(w)**2 -  &
               Sin(3.0*w/2.0)**2))
        end if

        a = (4.0 + 45.0 * c) / 3.0
        b = -(1.0 + 72.0 * c) / 12.0

        dy1 =  c * dysinv
        dy2 =  b * dysinv
        dy3 =  a * dysinv
        dy4 = -2.0 * ( a + b + c ) * dysinv
        dy5 =  a * dysinv
        dy6 =  b * dysinv
        dy7 =  c * dysinv

!=============================================================================!
!.... compute the second derivative in x
!=============================================================================!

        if (xper) then

          g11v(1,:)         = ( dx1 * v(1,nx-3,:)   + &
                                dx2 * v(1,nx-2,:)   + &
                                dx3 * v(1,nx-1,:)   + &
                                dx4 * v(1,1,:)      + &
                                dx5 * v(1,2,:)   + &
                                dx6 * v(1,3,:)   + &
                                dx7 * v(1,4,:)      )

          g11v(2,:)         = ( dx1 * v(1,nx-2,:)   + &
                                dx2 * v(1,nx-1,:)   + &
                                dx3 * v(1,1,:)      + &
                                dx4 * v(1,2,:)      + &
                                dx5 * v(1,3,:)      + &
                                dx6 * v(1,4,:)      + &
                                dx7 * v(1,5,:)      )

          g11v(3,:)         = ( dx1 * v(1,nx-1,:)   + &
                                dx2 * v(1,1,:)      + &
                                dx3 * v(1,2,:)      + &
                                dx4 * v(1,3,:)      + &
                                dx5 * v(1,4,:)      + &
                                dx6 * v(1,5,:)      + &
                                dx7 * v(1,6,:)      )

          g11v(nx-2,:)      = ( dx1 * v(1,nx-5,:)   + &
                                dx2 * v(1,nx-4,:)   + &
                                dx3 * v(1,nx-3,:)   + &
                                dx4 * v(1,nx-2,:)   + &
                                dx5 * v(1,nx-1,:)   + &
                                dx6 * v(1,1,:)      + &
                                dx7 * v(1,2,:)      )

          g11v(nx-1,:)      = ( dx1 * v(1,nx-4,:)   + &
                                dx2 * v(1,nx-3,:)   + &
                                dx3 * v(1,nx-2,:)   + &
                                dx4 * v(1,nx-1,:)   + &
                                dx5 * v(1,1,:)      + &
                                dx6 * v(1,2,:)      + &
                                dx7 * v(1,3,:)   )

          g11v(nx,:)        = g11v(1,:)

        else

          g11v(1,:)         = ( dd1 * v(1,1,:) + &
                                dd2 * v(1,2,:) + &
                                dd3 * v(1,3,:) + &
                                dd4 * v(1,4,:) + &
                                dd5 * v(1,5,:) ) * dxsinv

          g11v(2,:)         = ( db1 * v(1,1,:) + &
                                db2 * v(1,2,:) + &
                                db3 * v(1,3,:) + &
                                db4 * v(1,4,:) + &
                                db5 * v(1,5,:) ) * dxsinv

          g11v(3,:)         = ( da1 * v(1,1,:) + &
                                da2 * v(1,2,:) + &
                                da3 * v(1,3,:) + &
                                da4 * v(1,4,:) + &
                                da5 * v(1,5,:) ) * dxsinv

          g11v(nx-2,:)      = ( da1 * v(1,nx-4,:) + &
                                da2 * v(1,nx-3,:) + &
                                da3 * v(1,nx-2,:) + &
                                da4 * v(1,nx-1,:) + &
                                da5 * v(1,nx,:)   ) * dxsinv

          g11v(nx-1,:)      = ( db1 * v(1,nx,:)   + &
                                db2 * v(1,nx-1,:) + &
                                db3 * v(1,nx-2,:) + &
                                db4 * v(1,nx-3,:) + &
                                db5 * v(1,nx-4,:) ) * dxsinv

          g11v(nx,:)        = ( dd1 * v(1,nx,:)   + &
                                dd2 * v(1,nx-1,:) + &
                                dd3 * v(1,nx-2,:) + &
                                dd4 * v(1,nx-3,:) + &
                                dd5 * v(1,nx-4,:) ) * dxsinv

        end if

!.... implement symmetry conditions

        if (lsym) then
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if

            g11v(1,idof)    = ( isign * dx1 * v(1,4,idof)       + &
                                isign * dx2 * v(1,3,idof)       + &
                                isign * dx3 * v(1,2,idof)       + &
                                dx4 * v(1,1,idof)               + &
                                dx5 * v(1,2,idof)               + &
                                dx6 * v(1,3,idof)               + &
                                dx7 * v(1,4,idof)               )

            g11v(2,idof)    = ( isign * dx1 * v(1,3,idof)       + &
                                isign * dx2 * v(1,2,idof)       + &
                                dx3 * v(1,1,idof)               + &
                                dx4 * v(1,2,idof)               + &
                                dx5 * v(1,3,idof)               + &
                                dx6 * v(1,4,idof)               + &
                                dx7 * v(1,5,idof)               )

            g11v(3,idof)    = ( isign * dx1 * v(1,2,idof)       + &
                                dx2 * v(1,1,idof)               + &
                                dx3 * v(1,2,idof)               + &
                                dx4 * v(1,3,idof)               + &
                                dx5 * v(1,4,idof)               + &
                                dx6 * v(1,5,idof)               + &
                                dx7 * v(1,6,idof)               )
          end do
        end if

!.... interior

        g11v(4:nx-3,:)   = ( dx1 * v(1,1:nx-6,:)   + &
                             dx2 * v(1,2:nx-5,:)   + &
                             dx3 * v(1,3:nx-4,:)   + &
                             dx4 * v(1,4:nx-3,:)   + &
                             dx5 * v(1,5:nx-2,:)   + &
                             dx6 * v(1,6:nx-1,:)   + &
                             dx7 * v(1,7:nx  ,:)   )

!=============================================================================!
!.... compute the second derivative in y
!=============================================================================!

          g22v(:,:)        =  ( dd1 * v(1,:,:) + &
                                dd2 * v(2,:,:) + &
                                dd3 * v(3,:,:) + &
                                dd4 * v(4,:,:) + &
                                dd5 * v(5,:,:) ) * dysinv

!=============================================================================!
!.... compute the cross derivative
!=============================================================================!

        if (xper) then

          g12v(1,:)         = ( gx1 * g2v(nx-3,:)       + &
                                gx2 * g2v(nx-2,:)       + &
                                gx3 * g2v(nx-1,:)       + &
                                gx4 * g2v(2,:)          + &
                                gx5 * g2v(3,:)          + &
                                gx6 * g2v(4,:)  )

          g12v(2,:)         = ( gx1 * g2v(nx-2,:)       + &
                                gx2 * g2v(nx-1,:)       + &
                                gx3 * g2v(1,:)          + &
                                gx4 * g2v(3,:)          + &
                                gx5 * g2v(4,:)          + &
                                gx6 * g2v(5,:)  )

          g12v(3,:)         = ( gx1 * g2v(nx-1,:)       + &
                                gx2 * g2v(1,:)          + &
                                gx3 * g2v(2,:)          + &
                                gx4 * g2v(4,:)          + &
                                gx5 * g2v(5,:)          + &
                                gx6 * g2v(6,:)  )

          g12v(nx-2,:)      = ( gx1 * g2v(nx-5,:)       + &
                                gx2 * g2v(nx-4,:)       + &
                                gx3 * g2v(nx-3,:)       + &
                                gx4 * g2v(nx-1,:)       + &
                                gx5 * g2v(1,:)          + &
                                gx6 * g2v(2,:)  )

          g12v(nx-1,:)      = ( gx1 * g2v(nx-4,:)       + &
                                gx2 * g2v(nx-3,:)       + &
                                gx3 * g2v(nx-2,:)       + &
                                gx4 * g2v(1,:)          + &
                                gx5 * g2v(2,:)          + &
                                gx6 * g2v(3,:)  )

          g12v(nx,:)     = g12v(1,:)

        else

          g12v(1,:)     = ( gc1 * g2v(1,:)  + &
                            gc2 * g2v(2,:)  + &
                            gc3 * g2v(3,:)  + &
                            gc4 * g2v(4,:)  + &
                            gc5 * g2v(5,:)  ) * dxinv

          g12v(2,:)     = ( gb1 * g2v(1,:)  + &
                            gb2 * g2v(2,:)  + &
                            gb3 * g2v(3,:)  + &
                            gb4 * g2v(4,:)  + &
                            gb5 * g2v(5,:)  ) * dxinv

          g12v(3,:)     = ( ga1 * g2v(1,:)  + &
                            ga2 * g2v(2,:)  + &
                            ga3 * g2v(4,:)  + &
                            ga4 * g2v(5,:)  ) * dxinv

          g12v(nx-2,:)  = ( ga1 * g2v(nx-4,:)  + &
                            ga2 * g2v(nx-3,:)  + &
                            ga3 * g2v(nx-1,:)  + &
                            ga4 * g2v(nx  ,:)  ) * dxinv

          g12v(nx-1,:) = -( gb1 * g2v(nx  ,:)  + &
                            gb2 * g2v(nx-1,:)  + &
                            gb3 * g2v(nx-2,:)  + &
                            gb4 * g2v(nx-3,:)  + &
                            gb5 * g2v(nx-4,:)  ) * dxinv

          g12v(nx,:)   = -( gc1 * g2v(nx  ,:)  + &
                            gc2 * g2v(nx-1,:)  + &
                            gc3 * g2v(nx-2,:)  + &
                            gc4 * g2v(nx-3,:)  + &
                            gc5 * g2v(nx-4,:)  ) * dxinv

        end if

!.... implement the symmetric conditions

        if (lsym) then
          do idof = 1, ndof
            if (idof .eq. 3) then
              isign = -one
            else
              isign = one
            end if

            g12v(1,:)       = ( isign * gx1 * g2v(4,:)  + &
                                isign * gx2 * g2v(3,:)  + &
                                isign * gx3 * g2v(2,:)  + &
                                gx4 * g2v(2,:)          + &
                                gx5 * g2v(3,:)          + &
                                gx6 * g2v(4,:)          )

            g12v(2,:)       = ( isign * gx1 * g2v(3,:)  + &
                                isign * gx2 * g2v(2,:)  + &
                                gx3 * g2v(1,:)          + &
                                gx4 * g2v(3,:)          + &
                                gx5 * g2v(4,:)          + &
                                gx6 * g2v(5,:)          )

            g12v(3,:)       = ( isign * gx1 * g2v(2,:)  + &
                                gx2 * g2v(1,:)          + &
                                gx3 * g2v(2,:)          + &
                                gx4 * g2v(4,:)          + &
                                gx5 * g2v(5,:)          + &
                                gx6 * g2v(6,:)          )
          end do
        end if

!.... interior

        g12v(4:nx-3,:) = ( gx1 * g2v(1:nx-6,:)  + &
                           gx2 * g2v(2:nx-5,:)  + &
                           gx3 * g2v(3:nx-4,:)  + &
                           gx4 * g2v(5:nx-2,:)  + &
                           gx5 * g2v(6:nx-1,:)  + &
                           gx6 * g2v(7:nx  ,:)  )

        return
        end


      subroutine ca_axphase(phase,phase_l1,phase_l2,phase_l3,phase_h1,phase_h2,phase_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)

      ! use fdm_params_module, only : mindens, meandens

      implicit none

      integer          lo(3), hi(3)
      integer          phase_l1,phase_l2,phase_l3,phase_h1,phase_h2,phase_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision phase(phase_l1:phase_h1,phase_l2:phase_h2,phase_l3:phase_h3,nk)
      double precision    dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      integer i, j, k !, n

!       n = 0

!       do k = lo(3), hi(3)
!          do j = lo(2), hi(2)
!             do i = lo(1), hi(1)
!                if (dat(i,j,k,1) .gt. (0.75d0*meandens) ) then
!                   n = n+8  !Since the boson star is equally located inside 8 patches
!                endif
!             enddo
!          enddo
!       enddo

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
!                if (dat(i,j,k,1) .gt. (0.75d0*meandens) ) then
               phase(i,j,k,1)= datan2(dat(i,j,k,3),dat(i,j,k,2)) !/(n*delta(1)*delta(2)*delta(3))
!                else
!                   phase(i,j,k,1)=0.0
!                endif
            enddo
         enddo
      enddo
end subroutine ca_axphase

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

      subroutine ca_axepot(epot,epot_l1,epot_l2,epot_l3,epot_h1,epot_h2,epot_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)

      implicit none

      integer          lo(3), hi(3)
      integer          epot_l1,epot_l2,epot_l3,epot_h1,epot_h2,epot_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision epot(epot_l1:epot_h1,epot_l2:epot_h2,epot_l3:epot_h3,nk)
      double precision    dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      integer i, j, k

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
                  epot(i,j,k,1)= -dat(i,j,k,1)*dat(i,j,k,2)/2
            enddo
         enddo
      enddo

      end subroutine ca_axepot

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

      subroutine ca_axekin(ekin,ekin_l1,ekin_l2,ekin_l3,ekin_h1,ekin_h2,ekin_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)

      use fdm_params_module, only : m_tt,meandens,hbaroverm

      implicit none

      integer          lo(3), hi(3)
      integer          ekin_l1,ekin_l2,ekin_l3,ekin_h1,ekin_h2,ekin_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision ekin(ekin_l1:ekin_h1,ekin_l2:ekin_h2,ekin_l3:ekin_h3,nk)
      double precision dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      integer i, j, k

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               ekin(i,j,k,1)= hbaroverm**2 / 2 * &
                              (((-dat(i+2,j,k,2)+8.0d0*dat(i+1,j,k,2)-8.0d0*dat(i-1,j,k,2)+dat(i-2,j,k,2))/(12.0d0*delta(1)))**2 &
                              +((-dat(i+2,j,k,3)+8.0d0*dat(i+1,j,k,3)-8.0d0*dat(i-1,j,k,3)+dat(i-2,j,k,3))/(12.0d0*delta(1)))**2 &
                              +((-dat(i,j+2,k,2)+8.0d0*dat(i,j+1,k,2)-8.0d0*dat(i,j-1,k,2)+dat(i,j-2,k,2))/(12.0d0*delta(2)))**2 &
                              +((-dat(i,j+2,k,3)+8.0d0*dat(i,j+1,k,3)-8.0d0*dat(i,j-1,k,3)+dat(i,j-2,k,3))/(12.0d0*delta(2)))**2 &
                              +((-dat(i,j,k+2,2)+8.0d0*dat(i,j,k+1,2)-8.0d0*dat(i,j,k-1,2)+dat(i,j,k-2,2))/(12.0d0*delta(3)))**2 &
                              +((-dat(i,j,k+2,3)+8.0d0*dat(i,j,k+1,3)-8.0d0*dat(i,j,k-1,3)+dat(i,j,k-2,3))/(12.0d0*delta(3)))**2 )

!                               +((dat(i,j+1,k,2)-dat(i,j-1,k,2))/(2.0d0*delta(2)))**2+((dat(i,j+1,k,3)-dat(i,j-1,k,3))/(2.0d0*delta(2)))**2 &
!                               +((dat(i,j,k+1,2)-dat(i,j,k-1,2))/(2.0d0*delta(3)))**2+((dat(i,j,k+1,3)-dat(i,j,k-1,3))/(2.0d0*delta(3)))**2 )

!                               (((dat(i+1,j,k,2)-dat(i-1,j,k,2))/(2.0d0*delta(1)))**2+((dat(i+1,j,k,3)-dat(i-1,j,k,3))/(2.0d0*delta(1)))**2 &
!                               +((dat(i,j+1,k,2)-dat(i,j-1,k,2))/(2.0d0*delta(2)))**2+((dat(i,j+1,k,3)-dat(i,j-1,k,3))/(2.0d0*delta(2)))**2 &
!                               +((dat(i,j,k+1,2)-dat(i,j,k-1,2))/(2.0d0*delta(3)))**2+((dat(i,j,k+1,3)-dat(i,j,k-1,3))/(2.0d0*delta(3)))**2 )

!                                  (( (-dsqrt(dat(i+2,j,k,1))+8.0d0*dsqrt(dat(i+1,j,k,1))-8.0d0*dsqrt(dat(i-1,j,k,1))+dsqrt(dat(i-2,j,k,1))) / (12.0d0*delta(1)) )**2 &
!                                  +( (-dsqrt(dat(i,j+2,k,1))+8.0d0*dsqrt(dat(i,j+1,k,1))-8.0d0*dsqrt(dat(i,j-1,k,1))+dsqrt(dat(i,j-2,k,1))) / (12.0d0*delta(2)) )**2 &
!                                  +( (-dsqrt(dat(i,j,k+2,1))+8.0d0*dsqrt(dat(i,j,k+1,1))-8.0d0*dsqrt(dat(i,j,k-1,1))+dsqrt(dat(i,j,k-2,1))) / (12.0d0*delta(3)) )**2 )

            enddo
         enddo
      enddo

      end subroutine ca_axekin

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

      subroutine ca_axekinrho(ekinrho,ekinrho_l1,ekinrho_l2,ekinrho_l3,ekinrho_h1,ekinrho_h2,ekinrho_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)

      use fdm_params_module, only : m_tt,hbaroverm,a

      implicit none

      integer          lo(3), hi(3)
      integer          ekinrho_l1,ekinrho_l2,ekinrho_l3,ekinrho_h1,ekinrho_h2,ekinrho_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision ekinrho(ekinrho_l1:ekinrho_h1,ekinrho_l2:ekinrho_h2,ekinrho_l3:ekinrho_h3,nk)
      double precision dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      integer i, j, k

      !Unfortunately, the interpolation argorithm sometimes yields a small negative density
      !if the density is close to zero in a specific area. We can't allow that and set it to zero.

      do k = lo(3)-2, hi(3)+2
         do j = lo(2)-2, hi(2)+2
            do i = lo(1)-2, hi(1)+2
               if (dat(i,j,k,1) .lt. 0.0d0) then
                  dat(i,j,k,1) = 0.0d0
               endif
            enddo
         enddo
      enddo

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               ekinrho(i,j,k,1)= hbaroverm**2 / 2 * &
                                 (( (-dsqrt(dat(i+2,j,k,1))+8.0d0*dsqrt(dat(i+1,j,k,1))-8.0d0*dsqrt(dat(i-1,j,k,1))+dsqrt(dat(i-2,j,k,1))) / (12.0d0*delta(1)*a) )**2 &
                                 +( (-dsqrt(dat(i,j+2,k,1))+8.0d0*dsqrt(dat(i,j+1,k,1))-8.0d0*dsqrt(dat(i,j-1,k,1))+dsqrt(dat(i,j-2,k,1))) / (12.0d0*delta(2)*a) )**2 &
                                 +( (-dsqrt(dat(i,j,k+2,1))+8.0d0*dsqrt(dat(i,j,k+1,1))-8.0d0*dsqrt(dat(i,j,k-1,1))+dsqrt(dat(i,j,k-2,1))) / (12.0d0*delta(3)*a) )**2 )
            enddo
         enddo
      enddo

      end subroutine ca_axekinrho

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

      subroutine ca_axekinv(ekinv,ekinv_l1,ekinv_l2,ekinv_l3,ekinv_h1,ekinv_h2,ekinv_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)

      use fdm_params_module, only : m_tt, hbaroverm,a!, mindens
      use fundamental_constants_module

      implicit none

      integer          lo(3), hi(3)
      integer          ekinv_l1,ekinv_l2,ekinv_l3,ekinv_h1,ekinv_h2,ekinv_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt, diff(3)
      double precision ekinv(ekinv_l1:ekinv_h1,ekinv_l2:ekinv_h2,ekinv_l3:ekinv_h3,nk)
      double precision dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      !double precision phase(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3)
      double precision phase(lo(1)-1:hi(1)+1,lo(2)-1:hi(2)+1,lo(3)-1:hi(3)+1)
      integer    level, grid_no

      integer i, j, k

      ! if (nc .eq. 3) then !We solve AxDens,AxIm,AxRe
      if (.true.) then !We solve AxDens,AxIm,AxRe

      do k = lo(3)-1, hi(3)+1
         do j = lo(2)-1, hi(2)+1
            do i = lo(1)-1, hi(1)+1
               if (dat(i,j,k,1) .ne. 0.0d0) then
                  phase(i,j,k) = datan2(dat(i,j,k,3),dat(i,j,k,2))
               else
                  phase(i,j,k)=0.0
               endif
            enddo
         enddo
      enddo

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)

               !Have to consider the cases where the phase jumps from close to -pi to pi and vice versa
               diff(1) = min( dabs(phase(i+1,j,k)-phase(i-1,j,k)) , dabs(phase(i+1,j,k)-phase(i-1,j,k)-2.0*PI) , dabs(phase(i+1,j,k)-phase(i-1,j,k)+2.0*PI) )
               diff(2) = min( dabs(phase(i,j+1,k)-phase(i,j-1,k)) , dabs(phase(i,j+1,k)-phase(i,j-1,k)-2.0*PI) , dabs(phase(i,j+1,k)-phase(i,j-1,k)+2.0*PI) )
               diff(3) = min( dabs(phase(i,j,k+1)-phase(i,j,k-1)) , dabs(phase(i,j,k+1)-phase(i,j,k-1)-2.0*PI) , dabs(phase(i,j,k+1)-phase(i,j,k-1)+2.0*PI) )

               ekinv(i,j,k,1)= hbaroverm**2 / 2 * dat(i,j,k,1) * &
                               (( diff(1) / (2*delta(1)*a) )**2 &
                               +( diff(2) / (2*delta(2)*a) )**2 &
                               +( diff(3) / (2*delta(3)*a) )**2)

               ! !Have to consider the cases where the phase jumps from close to -pi to pi and vice versa
               ! diff(1) = min( dabs(phase(i+1,j,k)-phase(i,j,k)) , dabs(phase(i+1,j,k)-phase(i,j,k)-2.0*PI) , dabs(phase(i+1,j,k)-phase(i,j,k)+2.0*PI) )
               ! diff(2) = min( dabs(phase(i,j+1,k)-phase(i,j,k)) , dabs(phase(i,j+1,k)-phase(i,j,k)-2.0*PI) , dabs(phase(i,j+1,k)-phase(i,j,k)+2.0*PI) )
               ! diff(3) = min( dabs(phase(i,j,k+1)-phase(i,j,k)) , dabs(phase(i,j,k+1)-phase(i,j,k)-2.0*PI) , dabs(phase(i,j,k+1)-phase(i,j,k)+2.0*PI) )

               ! ekinv(i,j,k,1)= hbaroverm**2 / 2 * ( dat(i,j,k,1)+dat(i+1,j,k,1)+dat(i,j+1,k,1)+dat(i,j,k+1,1)+dat(i+1,j+1,k,1)+dat(i,j+1,k+1,1)+dat(i+1,j,k+1,1)+dat(i+1,j+1,k+1,1) )/8 * &
               !                 (( diff(1) / delta(1) )**2 &
               !                 +( diff(2) / delta(2) )**2 &
               !                 +( diff(3) / delta(3) )**2)
            enddo
         enddo
      enddo

      else !We solve UAXDENS, UAXMOMX, UAXMOMY, UAXMOMZ

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)

               if (dat(i,j,k,1) .eq. 0.d0 ) then
                  ekinv(i,j,k,1) = 0.d0
               else
                  ekinv(i,j,k,1)= ( dat(i,j,k,2)**2 + dat(i,j,k,3)**2 + dat(i,j,k,4)**2 )/dat(i,j,k,1)/2.d0
               endif

            enddo
         enddo
      enddo

      endif

      end subroutine ca_axekinv

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

      subroutine ca_axvel(ekinv,ekinv_l1,ekinv_l2,ekinv_l3,ekinv_h1,ekinv_h2,ekinv_h3,nk, &
                          dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                          lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)

      use fdm_params_module, only : m_tt, hbaroverm!, mindens
      use fundamental_constants_module

      implicit none

      integer          lo(3), hi(3)
      integer          ekinv_l1,ekinv_l2,ekinv_l3,ekinv_h1,ekinv_h2,ekinv_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt, diff(3)
      double precision ekinv(ekinv_l1:ekinv_h1,ekinv_l2:ekinv_h2,ekinv_l3:ekinv_h3,nk)
      double precision dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      double precision phase(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3)
      integer    level, grid_no

      integer i, j, k

      do k = lo(3)-1, hi(3)+1
         do j = lo(2)-1, hi(2)+1
            do i = lo(1)-1, hi(1)+1
               if (dat(i,j,k,1) .ne. 0.0d0) then
                  phase(i,j,k) = datan2(dat(i,j,k,3),dat(i,j,k,2))
               else
                  phase(i,j,k)=0.0
               endif
            enddo
         enddo
      enddo

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)

               !Have to consider the cases where the phase jumps from close to -pi to pi and vice versa
               diff(1) = min( dabs(phase(i+1,j,k)-phase(i-1,j,k)) , dabs(phase(i+1,j,k)-phase(i-1,j,k)-2.0*PI) , dabs(phase(i+1,j,k)-phase(i-1,j,k)+2.0*PI) )
               diff(2) = min( dabs(phase(i,j+1,k)-phase(i,j-1,k)) , dabs(phase(i,j+1,k)-phase(i,j-1,k)-2.0*PI) , dabs(phase(i,j+1,k)-phase(i,j-1,k)+2.0*PI) )
               diff(3) = min( dabs(phase(i,j,k+1)-phase(i,j,k-1)) , dabs(phase(i,j,k+1)-phase(i,j,k-1)-2.0*PI) , dabs(phase(i,j,k+1)-phase(i,j,k-1)+2.0*PI) )

               ekinv(i,j,k,1)= hbaroverm * sqrt(&
                                ( diff(1) / (2*delta(1)) )**2 &
                               +( diff(2) / (2*delta(2)) )**2 &
                               +( diff(3) / (2*delta(3)) )**2)

            enddo
         enddo
      enddo

      end subroutine ca_axvel

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

      subroutine ca_axangmom_x(angmom_x,angmom_x_l1,angmom_x_l2,angmom_x_l3,angmom_x_h1,angmom_x_h2,angmom_x_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)

      use fdm_params_module, only : m_tt,meandens,hbaroverm
      use fundamental_constants_module

      implicit none

      integer          lo(3), hi(3)
      integer          angmom_x_l1,angmom_x_l2,angmom_x_l3,angmom_x_h1,angmom_x_h2,angmom_x_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision angmom_x(angmom_x_l1:angmom_x_h1,angmom_x_l2:angmom_x_h2,angmom_x_l3:angmom_x_h3,nk)
      double precision dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      ! double precision phase(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3)
      integer    level, grid_no

      integer i, j, k

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)

               angmom_x(i,j,k,1) = hbaroverm*meandens*( -dat(i,j,k,2)*(dat(i,j,k+1,3)-dat(i,j,k-1,3))/(2.0d0*delta(3))*(j*delta(2)+xlo(2)) &
                                                        +dat(i,j,k,3)*(dat(i,j,k+1,2)-dat(i,j,k-1,2))/(2.0d0*delta(3))*(j*delta(2)+xlo(2)) &
                                                        +dat(i,j,k,2)*(dat(i,j+1,k,3)-dat(i,j-1,k,3))/(2.0d0*delta(2))*(k*delta(3)+xlo(3)) &
                                                        -dat(i,j,k,3)*(dat(i,j+1,k,2)-dat(i,j-1,k,2))/(2.0d0*delta(2))*(k*delta(3)+xlo(3)) )

            enddo
         enddo
      enddo

      end subroutine ca_axangmom_x

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

      subroutine ca_axangmom_y(angmom_y,angmom_y_l1,angmom_y_l2,angmom_y_l3,angmom_y_h1,angmom_y_h2,angmom_y_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)

      use fdm_params_module, only : m_tt,meandens,hbaroverm
      use fundamental_constants_module

      implicit none

      integer          lo(3), hi(3)
      integer          angmom_y_l1,angmom_y_l2,angmom_y_l3,angmom_y_h1,angmom_y_h2,angmom_y_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision angmom_y(angmom_y_l1:angmom_y_h1,angmom_y_l2:angmom_y_h2,angmom_y_l3:angmom_y_h3,nk)
      double precision dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      ! double precision phase(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3)
      integer    level, grid_no

      integer i, j, k

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)

               angmom_y(i,j,k,1) = hbaroverm*meandens*( -dat(i,j,k,2)*(dat(i+1,j,k,3)-dat(i-1,j,k,3))/(2.0d0*delta(1))*(k*delta(3)+xlo(3)) &
                                                        +dat(i,j,k,3)*(dat(i+1,j,k,2)-dat(i-1,j,k,2))/(2.0d0*delta(1))*(k*delta(3)+xlo(3)) &
                                                        +dat(i,j,k,2)*(dat(i,j,k+1,3)-dat(i,j,k-1,3))/(2.0d0*delta(3))*(i*delta(1)+xlo(1)) &
                                                        -dat(i,j,k,3)*(dat(i,j,k+1,2)-dat(i,j,k-1,2))/(2.0d0*delta(3))*(i*delta(1)+xlo(1)) )

            enddo
         enddo
      enddo

      end subroutine ca_axangmom_y

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

      subroutine ca_axangmom_z(angmom_z,angmom_z_l1,angmom_z_l2,angmom_z_l3,angmom_z_h1,angmom_z_h2,angmom_z_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)

      use fdm_params_module, only : m_tt,meandens,hbaroverm
      use fundamental_constants_module

      implicit none

      integer          lo(3), hi(3)
      integer          angmom_z_l1,angmom_z_l2,angmom_z_l3,angmom_z_h1,angmom_z_h2,angmom_z_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision angmom_z(angmom_z_l1:angmom_z_h1,angmom_z_l2:angmom_z_h2,angmom_z_l3:angmom_z_h3,nk)
      double precision dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      ! double precision phase(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3)
      integer    level, grid_no

      integer i, j, k

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)

               angmom_z(i,j,k,1) = hbaroverm*meandens*( -dat(i,j,k,2)*(dat(i,j+1,k,3)-dat(i,j-1,k,3))/(2.0d0*delta(2))*(i*delta(1)+xlo(1)) &
                                                        +dat(i,j,k,3)*(dat(i,j+1,k,2)-dat(i,j-1,k,2))/(2.0d0*delta(2))*(i*delta(1)+xlo(1)) &
                                                        +dat(i,j,k,2)*(dat(i+1,j,k,3)-dat(i-1,j,k,3))/(2.0d0*delta(1))*(j*delta(2)+xlo(2)) &
                                                        -dat(i,j,k,3)*(dat(i+1,j,k,2)-dat(i-1,j,k,2))/(2.0d0*delta(1))*(j*delta(2)+xlo(2)) )

            enddo
         enddo
      enddo

      end subroutine ca_axangmom_z

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

      subroutine ca_lohnererror(err,err_l1,err_l2,err_l3,err_h1,err_h2,err_h3,nk, &
                                dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                                lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)
      !
      ! This routine calculates the error estimator for the fdm velocity (AxRe,AxIm)
      ! according to R. Loehner (1987) eq.4
      !

      use fdm_params_module, only : epsilon_L, mindens

      implicit none

      integer          lo(3), hi(3)
      integer          err_l1,err_l2,err_l3,err_h1,err_h2,err_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision err(err_l1:err_h1,err_l2:err_h2,err_l3:err_h3,nk)
      double precision    dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      double precision top, bottom, eps
      integer i, j, k

      eps = 0.2

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)

               err(i,j,k,1) = 0.0

               ! print *, "dat",dat(i,j,k,1),dat(i,j,k,2)

               if ( (dat(i,j,k,1).ge.mindens) .and. (dat(i,j,k,2).ne.0.0) ) then

               top =       (dat(i+1,j  ,k  ,2)-dat(i  ,j  ,k  ,2)-dat(i  ,j  ,k  ,2)+dat(i-1,j  ,k  ,2))**2 + &
                           (dat(i  ,j+1,k  ,2)-dat(i  ,j  ,k  ,2)-dat(i  ,j  ,k  ,2)+dat(i  ,j-1,k  ,2))**2 + &
                           (dat(i  ,j  ,k+1,2)-dat(i  ,j  ,k  ,2)-dat(i  ,j  ,k  ,2)+dat(i  ,j  ,k-1,2))**2 + &
                     0.125*(dat(i+1,j+1,k  ,2)-dat(i+1,j-1,k  ,2)-dat(i-1,j+1,k  ,2)+dat(i-1,j-1,k  ,2))**2 + &
                     0.125*(dat(i+1,j  ,k+1,2)-dat(i+1,j  ,k-1,2)-dat(i-1,j  ,k+1,2)+dat(i-1,j  ,k-1,2))**2 + &
                     0.125*(dat(i  ,j+1,k+1,2)-dat(i  ,j+1,k-1,2)-dat(i  ,j-1,k+1,2)+dat(i  ,j-1,k-1,2))**2

               bottom =      (abs(dat(i+1,j  ,k  ,2) -    dat(i  ,j  ,k  ,2))+abs(dat(i  ,j  ,k  ,2) -    dat(i-1,j  ,k  ,2))      + &
                         eps*(abs(dat(i+1,j  ,k  ,2))+abs(dat(i  ,j  ,k  ,2))+abs(dat(i  ,j  ,k  ,2))+abs(dat(i-1,j  ,k  ,2))))**2 + &
                             (abs(dat(i  ,j+1,k  ,2) -    dat(i  ,j  ,k  ,2))+abs(dat(i  ,j  ,k  ,2) -    dat(i  ,j-1,k  ,2))      + &
                         eps*(abs(dat(i  ,j+1,k  ,2))+abs(dat(i  ,j  ,k  ,2))+abs(dat(i  ,j  ,k  ,2))+abs(dat(i  ,j-1,k  ,2))))**2 + &
                             (abs(dat(i  ,j  ,k+1,2) -    dat(i  ,j  ,k  ,2))+abs(dat(i  ,j  ,k  ,2) -    dat(i  ,j  ,k-1,2))      + &
                         eps*(abs(dat(i  ,j  ,k+1,2))+abs(dat(i  ,j  ,k  ,2))+abs(dat(i  ,j  ,k  ,2))+abs(dat(i  ,j  ,k-1,2))))**2 + &
                        (0.5*(abs(dat(i+1,j+1,k  ,2) -    dat(i-1,j+1,k  ,2))+abs(dat(i+1,j-1,k  ,2) -    dat(i-1,j-1,k  ,2)))     + &
                         eps*(abs(dat(i+1,j+1,k  ,2))+abs(dat(i-1,j+1,k  ,2))+abs(dat(i+1,j-1,k  ,2))+abs(dat(i-1,j-1,k  ,2))))**2 + &
                        (0.5*(abs(dat(i+1,j+1,k  ,2) -    dat(i+1,j-1,k  ,2))+abs(dat(i-1,j+1,k  ,2) -    dat(i-1,j-1,k  ,2)))     + &
                         eps*(abs(dat(i+1,j+1,k  ,2))+abs(dat(i+1,j-1,k  ,2))+abs(dat(i-1,j+1,k  ,2))+abs(dat(i-1,j-1,k  ,2))))**2 + &
                        (0.5*(abs(dat(i+1,j  ,k+1,2) -    dat(i-1,j  ,k+1,2))+abs(dat(i+1,j  ,k-1,2) -    dat(i-1,j  ,k-1,2)))     + &
                         eps*(abs(dat(i+1,j  ,k+1,2))+abs(dat(i-1,j  ,k+1,2))+abs(dat(i+1,j  ,k-1,2))+abs(dat(i-1,j  ,k-1,2))))**2 + &
                        (0.5*(abs(dat(i+1,j  ,k+1,2) -    dat(i+1,j  ,k-1,2))+abs(dat(i-1,j  ,k+1,2) -    dat(i-1,j  ,k-1,2)))     + &
                         eps*(abs(dat(i+1,j  ,k+1,2))+abs(dat(i+1,j  ,k-1,2))+abs(dat(i-1,j  ,k+1,2))+abs(dat(i-1,j  ,k-1,2))))**2 + &
                        (0.5*(abs(dat(i  ,j+1,k+1,2) -    dat(i  ,j-1,k+1,2))+abs(dat(i  ,j+1,k-1,2) -    dat(i  ,j-1,k-1,2)))     + &
                         eps*(abs(dat(i  ,j+1,k+1,2))+abs(dat(i  ,j-1,k+1,2))+abs(dat(i  ,j+1,k-1,2))+abs(dat(i  ,j-1,k-1,2))))**2 + &
                        (0.5*(abs(dat(i  ,j+1,k+1,2) -    dat(i  ,j+1,k-1,2))+abs(dat(i  ,j-1,k+1,2) -    dat(i  ,j-1,k-1,2)))     + &
                         eps*(abs(dat(i  ,j+1,k+1,2))+abs(dat(i  ,j+1,k-1,2))+abs(dat(i  ,j-1,k+1,2))+abs(dat(i  ,j-1,k-1,2))))**2

               err(i,j,k,1) = sqrt(top/bottom)
               endif

               if ( (dat(i,j,k,1).ge.mindens) .and. (dat(i,j,k,3).ne.0.0) ) then

               top =       (dat(i+1,j  ,k  ,3)-dat(i  ,j  ,k  ,3)-dat(i  ,j  ,k  ,3)+dat(i-1,j  ,k  ,3))**2 + &
                           (dat(i  ,j+1,k  ,3)-dat(i  ,j  ,k  ,3)-dat(i  ,j  ,k  ,3)+dat(i  ,j-1,k  ,3))**2 + &
                           (dat(i  ,j  ,k+1,3)-dat(i  ,j  ,k  ,3)-dat(i  ,j  ,k  ,3)+dat(i  ,j  ,k-1,3))**2 + &
                     0.125*(dat(i+1,j+1,k  ,3)-dat(i+1,j-1,k  ,3)-dat(i-1,j+1,k  ,3)+dat(i-1,j-1,k  ,3))**2 + &
                     0.125*(dat(i+1,j  ,k+1,3)-dat(i+1,j  ,k-1,3)-dat(i-1,j  ,k+1,3)+dat(i-1,j  ,k-1,3))**2 + &
                     0.125*(dat(i  ,j+1,k+1,3)-dat(i  ,j+1,k-1,3)-dat(i  ,j-1,k+1,3)+dat(i  ,j-1,k-1,3))**2

               bottom =      (abs(dat(i+1,j  ,k  ,3) -    dat(i  ,j  ,k  ,3))+abs(dat(i  ,j  ,k  ,3) -    dat(i-1,j  ,k  ,3))      + &
                         eps*(abs(dat(i+1,j  ,k  ,3))+abs(dat(i  ,j  ,k  ,3))+abs(dat(i  ,j  ,k  ,3))+abs(dat(i-1,j  ,k  ,3))))**2 + &
                             (abs(dat(i  ,j+1,k  ,3) -    dat(i  ,j  ,k  ,3))+abs(dat(i  ,j  ,k  ,3) -    dat(i  ,j-1,k  ,3))      + &
                         eps*(abs(dat(i  ,j+1,k  ,3))+abs(dat(i  ,j  ,k  ,3))+abs(dat(i  ,j  ,k  ,3))+abs(dat(i  ,j-1,k  ,3))))**2 + &
                             (abs(dat(i  ,j  ,k+1,3) -    dat(i  ,j  ,k  ,3))+abs(dat(i  ,j  ,k  ,3) -    dat(i  ,j  ,k-1,3))      + &
                         eps*(abs(dat(i  ,j  ,k+1,3))+abs(dat(i  ,j  ,k  ,3))+abs(dat(i  ,j  ,k  ,3))+abs(dat(i  ,j  ,k-1,3))))**2 + &
                        (0.5*(abs(dat(i+1,j+1,k  ,3) -    dat(i-1,j+1,k  ,3))+abs(dat(i+1,j-1,k  ,3) -    dat(i-1,j-1,k  ,3)))     + &
                         eps*(abs(dat(i+1,j+1,k  ,3))+abs(dat(i-1,j+1,k  ,3))+abs(dat(i+1,j-1,k  ,3))+abs(dat(i-1,j-1,k  ,3))))**2 + &
                        (0.5*(abs(dat(i+1,j+1,k  ,3) -    dat(i+1,j-1,k  ,3))+abs(dat(i-1,j+1,k  ,3) -    dat(i-1,j-1,k  ,3)))     + &
                         eps*(abs(dat(i+1,j+1,k  ,3))+abs(dat(i+1,j-1,k  ,3))+abs(dat(i-1,j+1,k  ,3))+abs(dat(i-1,j-1,k  ,3))))**2 + &
                        (0.5*(abs(dat(i+1,j  ,k+1,3) -    dat(i-1,j  ,k+1,3))+abs(dat(i+1,j  ,k-1,3) -    dat(i-1,j  ,k-1,3)))     + &
                         eps*(abs(dat(i+1,j  ,k+1,3))+abs(dat(i-1,j  ,k+1,3))+abs(dat(i+1,j  ,k-1,3))+abs(dat(i-1,j  ,k-1,3))))**2 + &
                        (0.5*(abs(dat(i+1,j  ,k+1,3) -    dat(i+1,j  ,k-1,3))+abs(dat(i-1,j  ,k+1,3) -    dat(i-1,j  ,k-1,3)))     + &
                         eps*(abs(dat(i+1,j  ,k+1,3))+abs(dat(i+1,j  ,k-1,3))+abs(dat(i-1,j  ,k+1,3))+abs(dat(i-1,j  ,k-1,3))))**2 + &
                        (0.5*(abs(dat(i  ,j+1,k+1,3) -    dat(i  ,j-1,k+1,3))+abs(dat(i  ,j+1,k-1,3) -    dat(i  ,j-1,k-1,3)))     + &
                         eps*(abs(dat(i  ,j+1,k+1,3))+abs(dat(i  ,j-1,k+1,3))+abs(dat(i  ,j+1,k-1,3))+abs(dat(i  ,j-1,k-1,3))))**2 + &
                        (0.5*(abs(dat(i  ,j+1,k+1,3) -    dat(i  ,j+1,k-1,3))+abs(dat(i  ,j-1,k+1,3) -    dat(i  ,j-1,k-1,3)))     + &
                         eps*(abs(dat(i  ,j+1,k+1,3))+abs(dat(i  ,j+1,k-1,3))+abs(dat(i  ,j-1,k+1,3))+abs(dat(i  ,j-1,k-1,3))))**2

                  err(i,j,k,1) = max(err(i,j,k,1),sqrt(top/bottom))

                  endif

                  ! print *, 'err',err(i,j,k,1)

            enddo
         enddo
      enddo

      end subroutine ca_lohnererror

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

      subroutine ca_dererrx(err,err_l1,err_l2,err_l3,err_h1,err_h2,err_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)
      !
      ! This routine calculates the error estimator for the fdm velocity (AxRe,AxIm)
      ! according to R. Loehner (1987) eq.4
      !

      use fdm_params_module, only : epsilon_L, mindens

      implicit none

      integer          lo(3), hi(3)
      integer          err_l1,err_l2,err_l3,err_h1,err_h2,err_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision err(err_l1:err_h1,err_l2:err_h2,err_l3:err_h3,nk)
      double precision    dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      double precision secondder, firstder, meanvalue
      integer i, j, k

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)

               secondder = dabs(dat(i+1,j,k,1)-2.*dat(i,j,k,1)+dat(i-1,j,k,1))
               firstder  = dabs(dat(i+1,j,k,1)-dat(i,j,k,1)) +dabs(dat(i,j,k,1)-dat(i-1,j,k,1))
               meanvalue = dabs(dat(i+1,j,k,1)+2.*dat(i,j,k,1)+dat(i-1,j,k,1))
               if ( ( firstder .gt. 1.0d-100 ) .and. ( dabs(dat(i,j,k,2)) .gt. mindens ) ) then
                  err(i,j,k,1) = secondder/(firstder+epsilon_L*meanvalue)
               else
                  err(i,j,k,1) = 0.0d0
               endif

            enddo
         enddo
      enddo

      end subroutine ca_dererrx

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

      subroutine ca_dererry(err,err_l1,err_l2,err_l3,err_h1,err_h2,err_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)
      !
      ! This routine calculates the error estimator for the fdm velocity (AxRe,AxIm)
      ! according to R. Loehner (1987) eq.4
      !

      use fdm_params_module, only : epsilon_L, mindens

      implicit none

      integer          lo(3), hi(3)
      integer          err_l1,err_l2,err_l3,err_h1,err_h2,err_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision err(err_l1:err_h1,err_l2:err_h2,err_l3:err_h3,nk)
      double precision    dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      double precision secondder, firstder, meanvalue
      integer i, j, k

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)

               secondder = dabs(dat(i,j+1,k,1)-2.*dat(i,j,k,1)+dat(i,j-1,k,1))
               firstder  = dabs(dat(i,j+1,k,1)-dat(i,j,k,1)) +dabs(dat(i,j,k,1)-dat(i,j-1,k,1))
               meanvalue = dabs(dat(i,j+1,k,1)+2.*dat(i,j,k,1)+dat(i,j-1,k,1))
               if ( ( firstder .gt. 1.0d-100 ) .and. ( dabs(dat(i,j,k,2)) .gt. mindens ) ) then
                  err(i,j,k,1) = secondder/(firstder+epsilon_L*meanvalue)
               else
                  err(i,j,k,1) = 0.0d0
               endif

            enddo
         enddo
      enddo

      end subroutine ca_dererry

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

      subroutine ca_dererrz(err,err_l1,err_l2,err_l3,err_h1,err_h2,err_h3,nk, &
                            dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc, &
                             lo,hi,domlo,domhi,delta,xlo,time,dt,bc,level,grid_no)
      !
      ! This routine calculates the error estimator for the fdm velocity (AxRe,AxIm)
      ! according to R. Loehner (1987) eq.4
      !

      use fdm_params_module, only : epsilon_L, mindens

      implicit none

      integer          lo(3), hi(3)
      integer          err_l1,err_l2,err_l3,err_h1,err_h2,err_h3,nk
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      double precision delta(3), xlo(3), time, dt
      double precision err(err_l1:err_h1,err_l2:err_h2,err_l3:err_h3,nk)
      double precision    dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      double precision secondder, firstder, meanvalue
      integer i, j, k

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)

               secondder = dabs(dat(i,j,k+1,1)-2.*dat(i,j,k,1)+dat(i,j,k-1,1))
               firstder  = dabs(dat(i,j,k+1,1)-dat(i,j,k,1)) +dabs(dat(i,j,k,1)-dat(i,j,k-1,1))
               meanvalue = dabs(dat(i,j,k+1,1)+2.*dat(i,j,k,1)+dat(i,j,k-1,1))
               if ( ( firstder .gt. 1.0d-100 ) .and. ( dabs(dat(i,j,k,2)) .gt. mindens ) ) then
                  err(i,j,k,1) = secondder/(firstder+epsilon_L*meanvalue)
               else
                  err(i,j,k,1) = 0.0d0
               endif

            enddo
         enddo
      enddo

      end subroutine ca_dererrz