fluxes_fast_b.f90

Go to the documentation of this file.

!        generated by tapenade     (inria, ecuador team)
!  tapenade 3.16 (develop) - 22 aug 2023 15:51
!
module fluxes_fast_b
  implicit none
 
contains
!  differentiation of inviscidcentralflux in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: *p *w *dw
!   with respect to varying inputs: *p *w *dw
!   rw status of diff variables: *p:incr *w:incr *dw:in-out
!   plus diff mem management of: p:in w:in dw:in
  subroutine inviscidcentralflux_fast_b()
!
!       inviscidcentralflux computes the euler fluxes using a central
!       discretization for a given block. therefore it is assumed that
!       the pointers in block pointer already point to the correct
!       block on the correct multigrid level.
!
    use constants
    use blockpointers, only : nx, il, ie, ny, jl, je, nz, kl, ke,&
&   spectralsol, w, wd, si, sj, sk, dw, dwd, pori, porj, pork, &
&   indfamilyi, indfamilyj, indfamilyk, p, pd, sfacei, sfacej, sfacek, &
&   nbkglobal, addgridvelocities, blockismoving, vol, factfamilyi, &
&   factfamilyj, factfamilyk
    use cgnsgrid, only : cgnsdoms, massflowfamilyinv
    use flowvarrefstate, only : timeref
    use inputphysics, only : equationmode
    implicit none
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k, ind, ii
    real(kind=realtype) :: qsp, qsm, rqsp, rqsm, porvel, porflux
    real(kind=realtype) :: qspd, qsmd, rqspd, rqsmd
    real(kind=realtype) :: pa, fs, sface, vnp, vnm
    real(kind=realtype) :: pad, fsd, vnpd, vnmd
    real(kind=realtype) :: wwx, wwy, wwz, rvol
    real(kind=realtype) :: rvold
    intrinsic mod
    real(kind=realtype) :: tempd
    integer :: branch
    if (blockismoving .and. equationmode .eq. steady) then
! compute the three nondimensional angular velocities.
      wwx = timeref*cgnsdoms(nbkglobal)%rotrate(1)
      wwy = timeref*cgnsdoms(nbkglobal)%rotrate(2)
      wwz = timeref*cgnsdoms(nbkglobal)%rotrate(3)
!$bwd-of ii-loop 
      do ii=0,nx*ny*nz-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, ny) + 2
        k = ii/(nx*ny) + 2
        rvol = w(i, j, k, irho)*vol(i, j, k)
        rvold = (wwx*w(i, j, k, ivy)-wwy*w(i, j, k, ivx))*dwd(i, j, k, &
&         imz) + (wwz*w(i, j, k, ivx)-wwx*w(i, j, k, ivz))*dwd(i, j, k, &
&         imy) + (wwy*w(i, j, k, ivz)-wwz*w(i, j, k, ivy))*dwd(i, j, k, &
&         imx)
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + wwx*rvol*dwd(i, j, k, imz)
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + wwz*rvol*dwd(i, j, k, imy)&
&         - wwy*rvol*dwd(i, j, k, imz)
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + wwy*rvol*dwd(i, j, k, imx)&
&         - wwx*rvol*dwd(i, j, k, imy)
        wd(i, j, k, ivy) = wd(i, j, k, ivy) - wwz*rvol*dwd(i, j, k, imx)
        wd(i, j, k, irho) = wd(i, j, k, irho) + vol(i, j, k)*rvold
      end do
    end if
    sface = zero
!$bwd-of ii-loop 
    do ii=0,nx*ny*kl-1
      i = mod(ii, nx) + 2
      j = mod(ii/nx, ny) + 2
      k = ii/(nx*ny) + 1
! set the dot product of the grid velocity and the
! normal in k-direction for a moving face.
      if (addgridvelocities) sface = sfacek(i, j, k)
! compute the normal velocities of the left and right state.
      vnp = w(i, j, k+1, ivx)*sk(i, j, k, 1) + w(i, j, k+1, ivy)*sk(i, j&
&       , k, 2) + w(i, j, k+1, ivz)*sk(i, j, k, 3)
      vnm = w(i, j, k, ivx)*sk(i, j, k, 1) + w(i, j, k, ivy)*sk(i, j, k&
&       , 2) + w(i, j, k, ivz)*sk(i, j, k, 3)
! set the values of the porosities for this face.
! porvel defines the porosity w.r.t. velocity;
! porflux defines the porosity w.r.t. the entire flux.
! the latter is only zero for a discontinuous block
! block boundary that must be treated conservatively.
! the default value of porflux is 0.5, such that the
! correct central flux is scattered to both cells.
! in case of a boundflux the normal velocity is set
! to sface.
      porvel = one
      porflux = half
      if (pork(i, j, k) .eq. noflux) porflux = zero
      if (pork(i, j, k) .eq. boundflux) then
        porvel = zero
        vnp = sface
        vnm = sface
myintptr = myintptr + 1
 myintstack(myintptr) = 0
      else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
      end if
! incorporate porflux in porvel.
      porvel = porvel*porflux
! compute the normal velocities for the face as well as the
! mass fluxes.
      qsp = (vnp-sface)*porvel
      qsm = (vnm-sface)*porvel
      rqsp = qsp*w(i, j, k+1, irho)
      rqsm = qsm*w(i, j, k, irho)
! compute the sum of the pressure multiplied by porflux.
! for the default value of porflux, 0.5, this leads to
! the average pressure.
! compute the fluxes and scatter them to the cells
! i,j,k and i,j,k+1. store the density flux in the
! mass flow of the appropriate sliding mesh interface.
      fsd = dwd(i, j, k, irhoe) - dwd(i, j, k+1, irhoe)
      qspd = w(i, j, k+1, irhoe)*fsd
      wd(i, j, k+1, irhoe) = wd(i, j, k+1, irhoe) + qsp*fsd
      qsmd = w(i, j, k, irhoe)*fsd
      wd(i, j, k, irhoe) = wd(i, j, k, irhoe) + qsm*fsd
      tempd = porflux*fsd
      fsd = dwd(i, j, k, imz) - dwd(i, j, k+1, imz)
      rqspd = w(i, j, k+1, ivz)*fsd
      wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + rqsp*fsd
      rqsmd = w(i, j, k, ivz)*fsd
      wd(i, j, k, ivz) = wd(i, j, k, ivz) + rqsm*fsd
      pad = sk(i, j, k, 3)*fsd
      fsd = dwd(i, j, k, imy) - dwd(i, j, k+1, imy)
      rqspd = rqspd + w(i, j, k+1, ivy)*fsd
      wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + rqsp*fsd
      rqsmd = rqsmd + w(i, j, k, ivy)*fsd
      wd(i, j, k, ivy) = wd(i, j, k, ivy) + rqsm*fsd
      pad = pad + sk(i, j, k, 2)*fsd
      fsd = dwd(i, j, k, imx) - dwd(i, j, k+1, imx)
      rqspd = rqspd + w(i, j, k+1, ivx)*fsd
      wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + rqsp*fsd
      rqsmd = rqsmd + w(i, j, k, ivx)*fsd
      wd(i, j, k, ivx) = wd(i, j, k, ivx) + rqsm*fsd
      pad = pad + sk(i, j, k, 1)*fsd
      pd(i, j, k) = pd(i, j, k) + vnm*tempd + porflux*pad
      pd(i, j, k+1) = pd(i, j, k+1) + vnp*tempd + porflux*pad
      fsd = dwd(i, j, k, irho) - dwd(i, j, k+1, irho)
      rqspd = rqspd + fsd
      rqsmd = rqsmd + fsd
      qsmd = qsmd + w(i, j, k, irho)*rqsmd
      vnmd = p(i, j, k)*tempd + porvel*qsmd
      wd(i, j, k, irho) = wd(i, j, k, irho) + qsm*rqsmd
      qspd = qspd + w(i, j, k+1, irho)*rqspd
      vnpd = p(i, j, k+1)*tempd + porvel*qspd
      wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + qsp*rqspd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
      if (branch .eq. 0) then
        vnmd = 0.0_8
        vnpd = 0.0_8
      end if
      wd(i, j, k, ivx) = wd(i, j, k, ivx) + sk(i, j, k, 1)*vnmd
      wd(i, j, k, ivy) = wd(i, j, k, ivy) + sk(i, j, k, 2)*vnmd
      wd(i, j, k, ivz) = wd(i, j, k, ivz) + sk(i, j, k, 3)*vnmd
      wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + sk(i, j, k, 1)*vnpd
      wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + sk(i, j, k, 2)*vnpd
      wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + sk(i, j, k, 3)*vnpd
    end do
    sface = zero
!$bwd-of ii-loop 
    do ii=0,nx*jl*nz-1
      i = mod(ii, nx) + 2
      j = mod(ii/nx, jl) + 1
      k = ii/(nx*jl) + 2
! set the dot product of the grid velocity and the
! normal in j-direction for a moving face.
      if (addgridvelocities) sface = sfacej(i, j, k)
! compute the normal velocities of the left and right state.
      vnp = w(i, j+1, k, ivx)*sj(i, j, k, 1) + w(i, j+1, k, ivy)*sj(i, j&
&       , k, 2) + w(i, j+1, k, ivz)*sj(i, j, k, 3)
      vnm = w(i, j, k, ivx)*sj(i, j, k, 1) + w(i, j, k, ivy)*sj(i, j, k&
&       , 2) + w(i, j, k, ivz)*sj(i, j, k, 3)
! set the values of the porosities for this face.
! porvel defines the porosity w.r.t. velocity;
! porflux defines the porosity w.r.t. the entire flux.
! the latter is only zero for a discontinuous block
! boundary that must be treated conservatively.
! the default value of porflux is 0.5, such that the
! correct central flux is scattered to both cells.
! in case of a boundflux the normal velocity is set
! to sface.
      porvel = one
      porflux = half
      if (porj(i, j, k) .eq. noflux) porflux = zero
      if (porj(i, j, k) .eq. boundflux) then
        porvel = zero
        vnp = sface
        vnm = sface
myintptr = myintptr + 1
 myintstack(myintptr) = 0
      else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
      end if
! incorporate porflux in porvel.
      porvel = porvel*porflux
! compute the normal velocities for the face as well as the
! mass fluxes.
      qsp = (vnp-sface)*porvel
      qsm = (vnm-sface)*porvel
      rqsp = qsp*w(i, j+1, k, irho)
      rqsm = qsm*w(i, j, k, irho)
! compute the sum of the pressure multiplied by porflux.
! for the default value of porflux, 0.5, this leads to
! the average pressure.
! compute the fluxes and scatter them to the cells
! i,j,k and i,j+1,k. store the density flux in the
! mass flow of the appropriate sliding mesh interface.
      fsd = dwd(i, j, k, irhoe) - dwd(i, j+1, k, irhoe)
      qspd = w(i, j+1, k, irhoe)*fsd
      wd(i, j+1, k, irhoe) = wd(i, j+1, k, irhoe) + qsp*fsd
      qsmd = w(i, j, k, irhoe)*fsd
      wd(i, j, k, irhoe) = wd(i, j, k, irhoe) + qsm*fsd
      tempd = porflux*fsd
      fsd = dwd(i, j, k, imz) - dwd(i, j+1, k, imz)
      rqspd = w(i, j+1, k, ivz)*fsd
      wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + rqsp*fsd
      rqsmd = w(i, j, k, ivz)*fsd
      wd(i, j, k, ivz) = wd(i, j, k, ivz) + rqsm*fsd
      pad = sj(i, j, k, 3)*fsd
      fsd = dwd(i, j, k, imy) - dwd(i, j+1, k, imy)
      rqspd = rqspd + w(i, j+1, k, ivy)*fsd
      wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + rqsp*fsd
      rqsmd = rqsmd + w(i, j, k, ivy)*fsd
      wd(i, j, k, ivy) = wd(i, j, k, ivy) + rqsm*fsd
      pad = pad + sj(i, j, k, 2)*fsd
      fsd = dwd(i, j, k, imx) - dwd(i, j+1, k, imx)
      rqspd = rqspd + w(i, j+1, k, ivx)*fsd
      wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + rqsp*fsd
      rqsmd = rqsmd + w(i, j, k, ivx)*fsd
      wd(i, j, k, ivx) = wd(i, j, k, ivx) + rqsm*fsd
      pad = pad + sj(i, j, k, 1)*fsd
      pd(i, j, k) = pd(i, j, k) + vnm*tempd + porflux*pad
      pd(i, j+1, k) = pd(i, j+1, k) + vnp*tempd + porflux*pad
      fsd = dwd(i, j, k, irho) - dwd(i, j+1, k, irho)
      rqspd = rqspd + fsd
      rqsmd = rqsmd + fsd
      qsmd = qsmd + w(i, j, k, irho)*rqsmd
      vnmd = p(i, j, k)*tempd + porvel*qsmd
      wd(i, j, k, irho) = wd(i, j, k, irho) + qsm*rqsmd
      qspd = qspd + w(i, j+1, k, irho)*rqspd
      vnpd = p(i, j+1, k)*tempd + porvel*qspd
      wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + qsp*rqspd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
      if (branch .eq. 0) then
        vnmd = 0.0_8
        vnpd = 0.0_8
      end if
      wd(i, j, k, ivx) = wd(i, j, k, ivx) + sj(i, j, k, 1)*vnmd
      wd(i, j, k, ivy) = wd(i, j, k, ivy) + sj(i, j, k, 2)*vnmd
      wd(i, j, k, ivz) = wd(i, j, k, ivz) + sj(i, j, k, 3)*vnmd
      wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + sj(i, j, k, 1)*vnpd
      wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + sj(i, j, k, 2)*vnpd
      wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + sj(i, j, k, 3)*vnpd
    end do
! initialize sface to zero. this value will be used if the
! block is not moving.
    sface = zero
!$bwd-of ii-loop 
    do ii=0,il*ny*nz-1
      i = mod(ii, il) + 1
      j = mod(ii/il, ny) + 2
      k = ii/(il*ny) + 2
! set the dot product of the grid velocity and the
! normal in i-direction for a moving face.
      if (addgridvelocities) sface = sfacei(i, j, k)
! compute the normal velocities of the left and right state.
      vnp = w(i+1, j, k, ivx)*si(i, j, k, 1) + w(i+1, j, k, ivy)*si(i, j&
&       , k, 2) + w(i+1, j, k, ivz)*si(i, j, k, 3)
      vnm = w(i, j, k, ivx)*si(i, j, k, 1) + w(i, j, k, ivy)*si(i, j, k&
&       , 2) + w(i, j, k, ivz)*si(i, j, k, 3)
! set the values of the porosities for this face.
! porvel defines the porosity w.r.t. velocity;
! porflux defines the porosity w.r.t. the entire flux.
! the latter is only zero for a discontinuous block
! boundary that must be treated conservatively.
! the default value of porflux is 0.5, such that the
! correct central flux is scattered to both cells.
! in case of a boundflux the normal velocity is set
! to sface.
      porvel = one
      porflux = half
      if (pori(i, j, k) .eq. noflux) porflux = zero
      if (pori(i, j, k) .eq. boundflux) then
        porvel = zero
        vnp = sface
        vnm = sface
myintptr = myintptr + 1
 myintstack(myintptr) = 0
      else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
      end if
! incorporate porflux in porvel.
      porvel = porvel*porflux
! compute the normal velocities relative to the grid for
! the face as well as the mass fluxes.
      qsp = (vnp-sface)*porvel
      qsm = (vnm-sface)*porvel
      rqsp = qsp*w(i+1, j, k, irho)
      rqsm = qsm*w(i, j, k, irho)
! compute the sum of the pressure multiplied by porflux.
! for the default value of porflux, 0.5, this leads to
! the average pressure.
! compute the fluxes and scatter them to the cells
! i,j,k and i+1,j,k. store the density flux in the
! mass flow of the appropriate sliding mesh interface.
      fsd = dwd(i, j, k, irhoe) - dwd(i+1, j, k, irhoe)
      qspd = w(i+1, j, k, irhoe)*fsd
      wd(i+1, j, k, irhoe) = wd(i+1, j, k, irhoe) + qsp*fsd
      qsmd = w(i, j, k, irhoe)*fsd
      wd(i, j, k, irhoe) = wd(i, j, k, irhoe) + qsm*fsd
      tempd = porflux*fsd
      fsd = dwd(i, j, k, imz) - dwd(i+1, j, k, imz)
      rqspd = w(i+1, j, k, ivz)*fsd
      wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + rqsp*fsd
      rqsmd = w(i, j, k, ivz)*fsd
      wd(i, j, k, ivz) = wd(i, j, k, ivz) + rqsm*fsd
      pad = si(i, j, k, 3)*fsd
      fsd = dwd(i, j, k, imy) - dwd(i+1, j, k, imy)
      rqspd = rqspd + w(i+1, j, k, ivy)*fsd
      wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + rqsp*fsd
      rqsmd = rqsmd + w(i, j, k, ivy)*fsd
      wd(i, j, k, ivy) = wd(i, j, k, ivy) + rqsm*fsd
      pad = pad + si(i, j, k, 2)*fsd
      fsd = dwd(i, j, k, imx) - dwd(i+1, j, k, imx)
      rqspd = rqspd + w(i+1, j, k, ivx)*fsd
      wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + rqsp*fsd
      rqsmd = rqsmd + w(i, j, k, ivx)*fsd
      wd(i, j, k, ivx) = wd(i, j, k, ivx) + rqsm*fsd
      pad = pad + si(i, j, k, 1)*fsd
      pd(i, j, k) = pd(i, j, k) + vnm*tempd + porflux*pad
      pd(i+1, j, k) = pd(i+1, j, k) + vnp*tempd + porflux*pad
      fsd = dwd(i, j, k, irho) - dwd(i+1, j, k, irho)
      rqspd = rqspd + fsd
      rqsmd = rqsmd + fsd
      qsmd = qsmd + w(i, j, k, irho)*rqsmd
      vnmd = p(i, j, k)*tempd + porvel*qsmd
      wd(i, j, k, irho) = wd(i, j, k, irho) + qsm*rqsmd
      qspd = qspd + w(i+1, j, k, irho)*rqspd
      vnpd = p(i+1, j, k)*tempd + porvel*qspd
      wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + qsp*rqspd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
      if (branch .eq. 0) then
        vnmd = 0.0_8
        vnpd = 0.0_8
      end if
      wd(i, j, k, ivx) = wd(i, j, k, ivx) + si(i, j, k, 1)*vnmd
      wd(i, j, k, ivy) = wd(i, j, k, ivy) + si(i, j, k, 2)*vnmd
      wd(i, j, k, ivz) = wd(i, j, k, ivz) + si(i, j, k, 3)*vnmd
      wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + si(i, j, k, 1)*vnpd
      wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + si(i, j, k, 2)*vnpd
      wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + si(i, j, k, 3)*vnpd
    end do
  end subroutine inviscidcentralflux_fast_b
 
  subroutine inviscidcentralflux()
!
!       inviscidcentralflux computes the euler fluxes using a central
!       discretization for a given block. therefore it is assumed that
!       the pointers in block pointer already point to the correct
!       block on the correct multigrid level.
!
    use constants
    use blockpointers, only : nx, il, ie, ny, jl, je, nz, kl, ke,&
&   spectralsol, w, si, sj, sk, dw, pori, porj, pork, indfamilyi, &
&   indfamilyj, indfamilyk, p, sfacei, sfacej, sfacek, nbkglobal, &
&   addgridvelocities, blockismoving, vol, factfamilyi, factfamilyj, &
&   factfamilyk
    use cgnsgrid, only : cgnsdoms, massflowfamilyinv
    use flowvarrefstate, only : timeref
    use inputphysics, only : equationmode
    implicit none
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k, ind, ii
    real(kind=realtype) :: qsp, qsm, rqsp, rqsm, porvel, porflux
    real(kind=realtype) :: pa, fs, sface, vnp, vnm
    real(kind=realtype) :: wwx, wwy, wwz, rvol
    intrinsic mod
!$ad checkpoint-start
! initialize sface to zero. this value will be used if the
! block is not moving.
    sface = zero
!$ad ii-loop
!
!       advective fluxes in the i-direction.
!
    do ii=0,il*ny*nz-1
      i = mod(ii, il) + 1
      j = mod(ii/il, ny) + 2
      k = ii/(il*ny) + 2
! set the dot product of the grid velocity and the
! normal in i-direction for a moving face.
      if (addgridvelocities) sface = sfacei(i, j, k)
! compute the normal velocities of the left and right state.
      vnp = w(i+1, j, k, ivx)*si(i, j, k, 1) + w(i+1, j, k, ivy)*si(i, j&
&       , k, 2) + w(i+1, j, k, ivz)*si(i, j, k, 3)
      vnm = w(i, j, k, ivx)*si(i, j, k, 1) + w(i, j, k, ivy)*si(i, j, k&
&       , 2) + w(i, j, k, ivz)*si(i, j, k, 3)
! set the values of the porosities for this face.
! porvel defines the porosity w.r.t. velocity;
! porflux defines the porosity w.r.t. the entire flux.
! the latter is only zero for a discontinuous block
! boundary that must be treated conservatively.
! the default value of porflux is 0.5, such that the
! correct central flux is scattered to both cells.
! in case of a boundflux the normal velocity is set
! to sface.
      porvel = one
      porflux = half
      if (pori(i, j, k) .eq. noflux) porflux = zero
      if (pori(i, j, k) .eq. boundflux) then
        porvel = zero
        vnp = sface
        vnm = sface
      end if
! incorporate porflux in porvel.
      porvel = porvel*porflux
! compute the normal velocities relative to the grid for
! the face as well as the mass fluxes.
      qsp = (vnp-sface)*porvel
      qsm = (vnm-sface)*porvel
      rqsp = qsp*w(i+1, j, k, irho)
      rqsm = qsm*w(i, j, k, irho)
! compute the sum of the pressure multiplied by porflux.
! for the default value of porflux, 0.5, this leads to
! the average pressure.
      pa = porflux*(p(i+1, j, k)+p(i, j, k))
! compute the fluxes and scatter them to the cells
! i,j,k and i+1,j,k. store the density flux in the
! mass flow of the appropriate sliding mesh interface.
      fs = rqsp + rqsm
      dw(i+1, j, k, irho) = dw(i+1, j, k, irho) - fs
      dw(i, j, k, irho) = dw(i, j, k, irho) + fs
      fs = rqsp*w(i+1, j, k, ivx) + rqsm*w(i, j, k, ivx) + pa*si(i, j, k&
&       , 1)
      dw(i+1, j, k, imx) = dw(i+1, j, k, imx) - fs
      dw(i, j, k, imx) = dw(i, j, k, imx) + fs
      fs = rqsp*w(i+1, j, k, ivy) + rqsm*w(i, j, k, ivy) + pa*si(i, j, k&
&       , 2)
      dw(i+1, j, k, imy) = dw(i+1, j, k, imy) - fs
      dw(i, j, k, imy) = dw(i, j, k, imy) + fs
      fs = rqsp*w(i+1, j, k, ivz) + rqsm*w(i, j, k, ivz) + pa*si(i, j, k&
&       , 3)
      dw(i+1, j, k, imz) = dw(i+1, j, k, imz) - fs
      dw(i, j, k, imz) = dw(i, j, k, imz) + fs
      fs = qsp*w(i+1, j, k, irhoe) + qsm*w(i, j, k, irhoe) + porflux*(&
&       vnp*p(i+1, j, k)+vnm*p(i, j, k))
      dw(i+1, j, k, irhoe) = dw(i+1, j, k, irhoe) - fs
      dw(i, j, k, irhoe) = dw(i, j, k, irhoe) + fs
    end do
!$ad checkpoint-end
!
!       advective fluxes in the j-direction.
!
    continue
!$ad checkpoint-start
    sface = zero
!$ad ii-loop
    do ii=0,nx*jl*nz-1
      i = mod(ii, nx) + 2
      j = mod(ii/nx, jl) + 1
      k = ii/(nx*jl) + 2
! set the dot product of the grid velocity and the
! normal in j-direction for a moving face.
      if (addgridvelocities) sface = sfacej(i, j, k)
! compute the normal velocities of the left and right state.
      vnp = w(i, j+1, k, ivx)*sj(i, j, k, 1) + w(i, j+1, k, ivy)*sj(i, j&
&       , k, 2) + w(i, j+1, k, ivz)*sj(i, j, k, 3)
      vnm = w(i, j, k, ivx)*sj(i, j, k, 1) + w(i, j, k, ivy)*sj(i, j, k&
&       , 2) + w(i, j, k, ivz)*sj(i, j, k, 3)
! set the values of the porosities for this face.
! porvel defines the porosity w.r.t. velocity;
! porflux defines the porosity w.r.t. the entire flux.
! the latter is only zero for a discontinuous block
! boundary that must be treated conservatively.
! the default value of porflux is 0.5, such that the
! correct central flux is scattered to both cells.
! in case of a boundflux the normal velocity is set
! to sface.
      porvel = one
      porflux = half
      if (porj(i, j, k) .eq. noflux) porflux = zero
      if (porj(i, j, k) .eq. boundflux) then
        porvel = zero
        vnp = sface
        vnm = sface
      end if
! incorporate porflux in porvel.
      porvel = porvel*porflux
! compute the normal velocities for the face as well as the
! mass fluxes.
      qsp = (vnp-sface)*porvel
      qsm = (vnm-sface)*porvel
      rqsp = qsp*w(i, j+1, k, irho)
      rqsm = qsm*w(i, j, k, irho)
! compute the sum of the pressure multiplied by porflux.
! for the default value of porflux, 0.5, this leads to
! the average pressure.
      pa = porflux*(p(i, j+1, k)+p(i, j, k))
! compute the fluxes and scatter them to the cells
! i,j,k and i,j+1,k. store the density flux in the
! mass flow of the appropriate sliding mesh interface.
      fs = rqsp + rqsm
      dw(i, j+1, k, irho) = dw(i, j+1, k, irho) - fs
      dw(i, j, k, irho) = dw(i, j, k, irho) + fs
      fs = rqsp*w(i, j+1, k, ivx) + rqsm*w(i, j, k, ivx) + pa*sj(i, j, k&
&       , 1)
      dw(i, j+1, k, imx) = dw(i, j+1, k, imx) - fs
      dw(i, j, k, imx) = dw(i, j, k, imx) + fs
      fs = rqsp*w(i, j+1, k, ivy) + rqsm*w(i, j, k, ivy) + pa*sj(i, j, k&
&       , 2)
      dw(i, j+1, k, imy) = dw(i, j+1, k, imy) - fs
      dw(i, j, k, imy) = dw(i, j, k, imy) + fs
      fs = rqsp*w(i, j+1, k, ivz) + rqsm*w(i, j, k, ivz) + pa*sj(i, j, k&
&       , 3)
      dw(i, j+1, k, imz) = dw(i, j+1, k, imz) - fs
      dw(i, j, k, imz) = dw(i, j, k, imz) + fs
      fs = qsp*w(i, j+1, k, irhoe) + qsm*w(i, j, k, irhoe) + porflux*(&
&       vnp*p(i, j+1, k)+vnm*p(i, j, k))
      dw(i, j+1, k, irhoe) = dw(i, j+1, k, irhoe) - fs
      dw(i, j, k, irhoe) = dw(i, j, k, irhoe) + fs
    end do
!$ad checkpoint-end
!
!       advective fluxes in the k-direction.
    continue
!$ad checkpoint-start
    sface = zero
!$ad ii-loop
    do ii=0,nx*ny*kl-1
      i = mod(ii, nx) + 2
      j = mod(ii/nx, ny) + 2
      k = ii/(nx*ny) + 1
! set the dot product of the grid velocity and the
! normal in k-direction for a moving face.
      if (addgridvelocities) sface = sfacek(i, j, k)
! compute the normal velocities of the left and right state.
      vnp = w(i, j, k+1, ivx)*sk(i, j, k, 1) + w(i, j, k+1, ivy)*sk(i, j&
&       , k, 2) + w(i, j, k+1, ivz)*sk(i, j, k, 3)
      vnm = w(i, j, k, ivx)*sk(i, j, k, 1) + w(i, j, k, ivy)*sk(i, j, k&
&       , 2) + w(i, j, k, ivz)*sk(i, j, k, 3)
! set the values of the porosities for this face.
! porvel defines the porosity w.r.t. velocity;
! porflux defines the porosity w.r.t. the entire flux.
! the latter is only zero for a discontinuous block
! block boundary that must be treated conservatively.
! the default value of porflux is 0.5, such that the
! correct central flux is scattered to both cells.
! in case of a boundflux the normal velocity is set
! to sface.
      porvel = one
      porflux = half
      if (pork(i, j, k) .eq. noflux) porflux = zero
      if (pork(i, j, k) .eq. boundflux) then
        porvel = zero
        vnp = sface
        vnm = sface
      end if
! incorporate porflux in porvel.
      porvel = porvel*porflux
! compute the normal velocities for the face as well as the
! mass fluxes.
      qsp = (vnp-sface)*porvel
      qsm = (vnm-sface)*porvel
      rqsp = qsp*w(i, j, k+1, irho)
      rqsm = qsm*w(i, j, k, irho)
! compute the sum of the pressure multiplied by porflux.
! for the default value of porflux, 0.5, this leads to
! the average pressure.
      pa = porflux*(p(i, j, k+1)+p(i, j, k))
! compute the fluxes and scatter them to the cells
! i,j,k and i,j,k+1. store the density flux in the
! mass flow of the appropriate sliding mesh interface.
      fs = rqsp + rqsm
      dw(i, j, k+1, irho) = dw(i, j, k+1, irho) - fs
      dw(i, j, k, irho) = dw(i, j, k, irho) + fs
      fs = rqsp*w(i, j, k+1, ivx) + rqsm*w(i, j, k, ivx) + pa*sk(i, j, k&
&       , 1)
      dw(i, j, k+1, imx) = dw(i, j, k+1, imx) - fs
      dw(i, j, k, imx) = dw(i, j, k, imx) + fs
      fs = rqsp*w(i, j, k+1, ivy) + rqsm*w(i, j, k, ivy) + pa*sk(i, j, k&
&       , 2)
      dw(i, j, k+1, imy) = dw(i, j, k+1, imy) - fs
      dw(i, j, k, imy) = dw(i, j, k, imy) + fs
      fs = rqsp*w(i, j, k+1, ivz) + rqsm*w(i, j, k, ivz) + pa*sk(i, j, k&
&       , 3)
      dw(i, j, k+1, imz) = dw(i, j, k+1, imz) - fs
      dw(i, j, k, imz) = dw(i, j, k, imz) + fs
      fs = qsp*w(i, j, k+1, irhoe) + qsm*w(i, j, k, irhoe) + porflux*(&
&       vnp*p(i, j, k+1)+vnm*p(i, j, k))
      dw(i, j, k+1, irhoe) = dw(i, j, k+1, irhoe) - fs
      dw(i, j, k, irhoe) = dw(i, j, k, irhoe) + fs
    end do
!$ad checkpoint-end
! add the rotational source terms for a moving block in a
! steady state computation. these source terms account for the
! centrifugal acceleration and the coriolis term. however, as
! the the equations are solved in the inertial frame and not
! in the moving frame, the form is different than what you
! normally find in a text book.
    continue
!$ad checkpoint-start
    if (blockismoving .and. equationmode .eq. steady) then
! compute the three nondimensional angular velocities.
      wwx = timeref*cgnsdoms(nbkglobal)%rotrate(1)
      wwy = timeref*cgnsdoms(nbkglobal)%rotrate(2)
      wwz = timeref*cgnsdoms(nbkglobal)%rotrate(3)
!$ad ii-loop
! loop over the internal cells of this block to compute the
! rotational terms for the momentum equations.
      do ii=0,nx*ny*nz-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, ny) + 2
        k = ii/(nx*ny) + 2
        rvol = w(i, j, k, irho)*vol(i, j, k)
        dw(i, j, k, imx) = dw(i, j, k, imx) + rvol*(wwy*w(i, j, k, ivz)-&
&         wwz*w(i, j, k, ivy))
        dw(i, j, k, imy) = dw(i, j, k, imy) + rvol*(wwz*w(i, j, k, ivx)-&
&         wwx*w(i, j, k, ivz))
        dw(i, j, k, imz) = dw(i, j, k, imz) + rvol*(wwx*w(i, j, k, ivy)-&
&         wwy*w(i, j, k, ivx))
      end do
    end if
!$ad checkpoint-end
 
  end subroutine inviscidcentralflux
 
!  differentiation of invisciddissfluxmatrix in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: *p *w *fw
!   with respect to varying inputs: *p *w *fw
!   rw status of diff variables: *p:incr *w:incr *fw:in-out
!   plus diff mem management of: p:in w:in fw:in
  subroutine invisciddissfluxmatrix_fast_b()
!
!       invisciddissfluxmatrix computes the matrix artificial
!       dissipation term. instead of the spectral radius, as used in
!       the scalar dissipation scheme, the absolute value of the flux
!       jacobian is used. this leads to a less diffusive and
!       consequently more accurate scheme. it is assumed that the
!       pointers in blockpointers already point to the correct block.
!
    use constants
    use blockpointers, only : nx, ny, nz, il, jl, kl, ie, je, ke,&
&   ib, jb, kb, w, wd, p, pd, pori, porj, pork, fw, fwd, gamma, si, sj, &
&   sk, indfamilyi, indfamilyj, indfamilyk, spectralsol, &
&   addgridvelocities, sfacei, sfacej, sfacek, factfamilyi, factfamilyj,&
&   factfamilyk
    use flowvarrefstate, only : pinfcorr
    use inputdiscretization, only : vis2, vis4
    use inputphysics, only : equations
    use iteration, only : rfil
    use cgnsgrid, only : massflowfamilydiss
    use utils_fast_b, only : getcorrectfork, mydim, mydim_fast_b
    implicit none
!
!      local parameters.
!
    real(kind=realtype), parameter :: dpmax=0.25_realtype
    real(kind=realtype), parameter :: epsacoustic=0.25_realtype
    real(kind=realtype), parameter :: epsshear=0.025_realtype
    real(kind=realtype), parameter :: omega=0.5_realtype
    real(kind=realtype), parameter :: oneminomega=one-omega
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k, ind, ii
    real(kind=realtype) :: plim, sface
    real(kind=realtype) :: sfil, fis2, fis4
    real(kind=realtype) :: gammaavg, gm1, ovgm1, gm53
    real(kind=realtype) :: ppor, rrad, dis2, dis4
    real(kind=realtype) :: rradd, dis2d, dis4d
    real(kind=realtype) :: dp1, dp2, tmp, fs
    real(kind=realtype) :: fsd
    real(kind=realtype) :: ddw1, ddw2, ddw3, ddw4, ddw5, ddw6
    real(kind=realtype) :: ddw1d, ddw2d, ddw3d, ddw4d, ddw5d, ddw6d
    real(kind=realtype) :: dr, dru, drv, drw, dre, drk, sx, sy, sz
    real(kind=realtype) :: drd, drud, drvd, drwd, dred, drkd
    real(kind=realtype) :: uavg, vavg, wavg, a2avg, aavg, havg
    real(kind=realtype) :: uavgd, vavgd, wavgd, a2avgd, aavgd, havgd
    real(kind=realtype) :: alphaavg, unavg, ovaavg, ova2avg
    real(kind=realtype) :: alphaavgd, unavgd, ovaavgd, ova2avgd
    real(kind=realtype) :: kavg, lam1, lam2, lam3, area
    real(kind=realtype) :: kavgd, lam1d, lam2d, lam3d
    real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
    real(kind=realtype) :: abv1d, abv2d, abv3d, abv4d, abv5d, abv6d, &
&   abv7d
    real(kind=realtype), dimension(ie, je, ke, 3) :: dss
    real(kind=realtype), dimension(ie, je, ke, 3) :: dssd
    logical :: correctfork
    intrinsic abs
    intrinsic mod
    intrinsic max
    intrinsic min
    intrinsic sqrt
    real(kind=realtype) :: x1
    real(kind=realtype) :: x1d
    real(kind=realtype) :: x2
    real(kind=realtype) :: x2d
    real(kind=realtype) :: x3
    real(kind=realtype) :: x3d
    real(kind=realtype) :: y1
    real(kind=realtype) :: y1d
    real(kind=realtype) :: y2
    real(kind=realtype) :: y2d
    real(kind=realtype) :: y3
    real(kind=realtype) :: y3d
    real(kind=realtype) :: abs0
    real(kind=realtype) :: min1
    real(kind=realtype) :: min1d
    real(realtype) :: max1
    real(kind=realtype) :: max2
    real(kind=realtype) :: max2d
    real(kind=realtype) :: max3
    real(kind=realtype) :: max3d
    real(kind=realtype) :: max4
    real(kind=realtype) :: max4d
    real(kind=realtype) :: min2
    real(kind=realtype) :: min2d
    real(realtype) :: max5
    real(kind=realtype) :: max6
    real(kind=realtype) :: max6d
    real(kind=realtype) :: max7
    real(kind=realtype) :: max7d
    real(kind=realtype) :: max8
    real(kind=realtype) :: max8d
    real(kind=realtype) :: min3
    real(kind=realtype) :: min3d
    real(realtype) :: max9
    real(kind=realtype) :: max10
    real(kind=realtype) :: max10d
    real(kind=realtype) :: max11
    real(kind=realtype) :: max11d
    real(kind=realtype) :: max12
    real(kind=realtype) :: max12d
    real(kind=realtype) :: abs1
    real(kind=realtype) :: abs1d
    real(kind=realtype) :: abs2
    real(kind=realtype) :: abs2d
    real(kind=realtype) :: abs3
    real(kind=realtype) :: abs3d
    real(kind=realtype) :: abs4
    real(kind=realtype) :: abs4d
    real(kind=realtype) :: abs5
    real(kind=realtype) :: abs5d
    real(kind=realtype) :: abs6
    real(kind=realtype) :: abs6d
    real(kind=realtype) :: arg1
    real(kind=realtype) :: arg1d
    real(kind=realtype) :: temp
    real(kind=realtype) :: temp0
    real(kind=realtype) :: tempd
    real(kind=realtype) :: tempd0
    real(kind=realtype) :: temp1
    real(kind=realtype) :: tempd1
    integer :: branch
    real(kind=realtype) :: temp2
    real(kind=realtype) :: temp3
    real(kind=realtype) :: tempd2
    real(kind=realtype) :: tempd3
    if (rfil .ge. 0.) then
      abs0 = rfil
    else
      abs0 = -rfil
    end if
! check if rfil == 0. if so, the dissipative flux needs not to
! be computed.
    if (abs0 .ge. thresholdreal) then
! set the value of plim. to be fully consistent this must have
! the dimension of a pressure. therefore a fraction of pinfcorr
! is used.
      plim = 0.001_realtype*pinfcorr
! determine whether or not the total energy must be corrected
! for the presence of the turbulent kinetic energy.
      correctfork = getcorrectfork()
! initialize sface to zero. this value will be used if the
! block is not moving.
      sface = zero
! set a couple of constants for the scheme.
      fis2 = rfil*vis2
      fis4 = rfil*vis4
      sfil = one - rfil
! initialize the dissipative residual to a certain times,
! possibly zero, the previously stored value.
!$fwd-of ii-loop 
! compute the pressure sensor for each cell, in each direction:
      do ii=0,ie*je*ke-1
        i = mod(ii, ie) + 1
        j = mod(ii/ie, je) + 1
        k = ii/(ie*je) + 1
        if (p(i+1, j, k) - p(i, j, k) .ge. 0.) then
          abs1 = p(i+1, j, k) - p(i, j, k)
        else
          abs1 = -(p(i+1, j, k)-p(i, j, k))
        end if
        if (p(i, j, k) - p(i-1, j, k) .ge. 0.) then
          abs4 = p(i, j, k) - p(i-1, j, k)
        else
          abs4 = -(p(i, j, k)-p(i-1, j, k))
        end if
        x1 = (p(i+1, j, k)-two*p(i, j, k)+p(i-1, j, k))/(omega*(p(i+1, j&
&         , k)+two*p(i, j, k)+p(i-1, j, k))+oneminomega*(abs1+abs4)+plim&
&         )
        if (x1 .ge. 0.) then
          dss(i, j, k, 1) = x1
        else
          dss(i, j, k, 1) = -x1
        end if
        if (p(i, j+1, k) - p(i, j, k) .ge. 0.) then
          abs2 = p(i, j+1, k) - p(i, j, k)
        else
          abs2 = -(p(i, j+1, k)-p(i, j, k))
        end if
        if (p(i, j, k) - p(i, j-1, k) .ge. 0.) then
          abs5 = p(i, j, k) - p(i, j-1, k)
        else
          abs5 = -(p(i, j, k)-p(i, j-1, k))
        end if
        x2 = (p(i, j+1, k)-two*p(i, j, k)+p(i, j-1, k))/(omega*(p(i, j+1&
&         , k)+two*p(i, j, k)+p(i, j-1, k))+oneminomega*(abs2+abs5)+plim&
&         )
        if (x2 .ge. 0.) then
          dss(i, j, k, 2) = x2
        else
          dss(i, j, k, 2) = -x2
        end if
        if (p(i, j, k+1) - p(i, j, k) .ge. 0.) then
          abs3 = p(i, j, k+1) - p(i, j, k)
        else
          abs3 = -(p(i, j, k+1)-p(i, j, k))
        end if
        if (p(i, j, k) - p(i, j, k-1) .ge. 0.) then
          abs6 = p(i, j, k) - p(i, j, k-1)
        else
          abs6 = -(p(i, j, k)-p(i, j, k-1))
        end if
        x3 = (p(i, j, k+1)-two*p(i, j, k)+p(i, j, k-1))/(omega*(p(i, j, &
&         k+1)+two*p(i, j, k)+p(i, j, k-1))+oneminomega*(abs3+abs6)+plim&
&         )
        if (x3 .ge. 0.) then
          dss(i, j, k, 3) = x3
        else
          dss(i, j, k, 3) = -x3
        end if
      end do
!$fwd-of ii-loop 
!
!       dissipative fluxes in the i-direction.
!
      do ii=0,il*ny*nz-1
        i = mod(ii, il) + 1
        j = mod(ii/il, ny) + 2
        k = ii/(il*ny) + 2
! compute the dissipation coefficients for this face.
        ppor = zero
        if (pori(i, j, k) .eq. normalflux) ppor = one
        if (dss(i, j, k, 1) .lt. dss(i+1, j, k, 1)) then
          y1 = dss(i+1, j, k, 1)
        else
          y1 = dss(i, j, k, 1)
        end if
        if (dpmax .gt. y1) then
          min1 = y1
        else
          min1 = dpmax
        end if
        dis2 = ppor*fis2*min1
        arg1 = ppor*fis4
        dis4 = mydim(arg1, dis2)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
        ddw1 = w(i+1, j, k, irho) - w(i, j, k, irho)
        dr = dis2*ddw1 - dis4*(w(i+2, j, k, irho)-w(i-1, j, k, irho)-&
&         three*ddw1)
        ddw2 = w(i+1, j, k, irho)*w(i+1, j, k, ivx) - w(i, j, k, irho)*w&
&         (i, j, k, ivx)
        dru = dis2*ddw2 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, ivx)-w(i&
&         -1, j, k, irho)*w(i-1, j, k, ivx)-three*ddw2)
        ddw3 = w(i+1, j, k, irho)*w(i+1, j, k, ivy) - w(i, j, k, irho)*w&
&         (i, j, k, ivy)
        drv = dis2*ddw3 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, ivy)-w(i&
&         -1, j, k, irho)*w(i-1, j, k, ivy)-three*ddw3)
        ddw4 = w(i+1, j, k, irho)*w(i+1, j, k, ivz) - w(i, j, k, irho)*w&
&         (i, j, k, ivz)
        drw = dis2*ddw4 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, ivz)-w(i&
&         -1, j, k, irho)*w(i-1, j, k, ivz)-three*ddw4)
        ddw5 = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
        dre = dis2*ddw5 - dis4*(w(i+2, j, k, irhoe)-w(i-1, j, k, irhoe)-&
&         three*ddw5)
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
        if (correctfork) then
          ddw6 = w(i+1, j, k, irho)*w(i+1, j, k, itu1) - w(i, j, k, irho&
&           )*w(i, j, k, itu1)
          drk = dis2*ddw6 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, itu1)-&
&           w(i-1, j, k, irho)*w(i-1, j, k, itu1)-three*ddw6)
          kavg = half*(w(i, j, k, itu1)+w(i+1, j, k, itu1))
        else
          drk = zero
          kavg = zero
        end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
        gammaavg = half*(gamma(i+1, j, k)+gamma(i, j, k))
        gm1 = gammaavg - one
        ovgm1 = one/gm1
        gm53 = gammaavg - five*third
! compute the average state at the interface.
        uavg = half*(w(i+1, j, k, ivx)+w(i, j, k, ivx))
        vavg = half*(w(i+1, j, k, ivy)+w(i, j, k, ivy))
        wavg = half*(w(i+1, j, k, ivz)+w(i, j, k, ivz))
        a2avg = half*(gamma(i+1, j, k)*p(i+1, j, k)/w(i+1, j, k, irho)+&
&         gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
        area = sqrt(si(i, j, k, 1)**2 + si(i, j, k, 2)**2 + si(i, j, k, &
&         3)**2)
        if (1.e-25_realtype .lt. area) then
          max1 = area
        else
          max1 = 1.e-25_realtype
        end if
        tmp = one/max1
        sx = si(i, j, k, 1)*tmp
        sy = si(i, j, k, 2)*tmp
        sz = si(i, j, k, 3)*tmp
        alphaavg = half*(uavg**2+vavg**2+wavg**2)
        havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
        aavg = sqrt(a2avg)
        unavg = uavg*sx + vavg*sy + wavg*sz
        ovaavg = one/aavg
        ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
        if (addgridvelocities) sface = sfacei(i, j, k)*tmp
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
        else
          lam1 = -(unavg-sface+aavg)
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
        else
          lam2 = -(unavg-sface-aavg)
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
        else
          lam3 = -(unavg-sface)
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max2 = epsacoustic*rrad
        else
          max2 = lam1
        end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
        lam1 = max2*area
        if (lam2 .lt. epsacoustic*rrad) then
          max3 = epsacoustic*rrad
        else
          max3 = lam2
        end if
        lam2 = max3*area
        if (lam3 .lt. epsshear*rrad) then
          max4 = epsshear*rrad
        else
          max4 = lam3
        end if
        lam3 = max4*area
! some abbreviations, which occur quite often in the
! dissipation terms.
        abv1 = half*(lam1+lam2)
        abv2 = half*(lam1-lam2)
        abv3 = abv1 - lam3
        abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53*&
&         drk
        abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
        abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
        abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
        fs = lam3*dr + abv6
        fw(i+1, j, k, irho) = fw(i+1, j, k, irho) + fs
        fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
        fs = lam3*dru + uavg*abv6 + sx*abv7
        fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fs
        fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
        fs = lam3*drv + vavg*abv6 + sy*abv7
        fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fs
        fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
        fs = lam3*drw + wavg*abv6 + sz*abv7
        fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fs
        fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
        fs = lam3*dre + havg*abv6 + unavg*abv7
        fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + fs
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
      end do
!$fwd-of ii-loop 
!
!       dissipative fluxes in the j-direction.
!
      do ii=0,nx*jl*nz-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, jl) + 1
        k = ii/(nx*jl) + 2
! compute the dissipation coefficients for this face.
        ppor = zero
        if (porj(i, j, k) .eq. normalflux) ppor = one
        if (dss(i, j, k, 2) .lt. dss(i, j+1, k, 2)) then
          y2 = dss(i, j+1, k, 2)
        else
          y2 = dss(i, j, k, 2)
        end if
        if (dpmax .gt. y2) then
          min2 = y2
        else
          min2 = dpmax
        end if
        dis2 = ppor*fis2*min2
        arg1 = ppor*fis4
        dis4 = mydim(arg1, dis2)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
        ddw1 = w(i, j+1, k, irho) - w(i, j, k, irho)
        dr = dis2*ddw1 - dis4*(w(i, j+2, k, irho)-w(i, j-1, k, irho)-&
&         three*ddw1)
        ddw2 = w(i, j+1, k, irho)*w(i, j+1, k, ivx) - w(i, j, k, irho)*w&
&         (i, j, k, ivx)
        dru = dis2*ddw2 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, ivx)-w(i&
&         , j-1, k, irho)*w(i, j-1, k, ivx)-three*ddw2)
        ddw3 = w(i, j+1, k, irho)*w(i, j+1, k, ivy) - w(i, j, k, irho)*w&
&         (i, j, k, ivy)
        drv = dis2*ddw3 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, ivy)-w(i&
&         , j-1, k, irho)*w(i, j-1, k, ivy)-three*ddw3)
        ddw4 = w(i, j+1, k, irho)*w(i, j+1, k, ivz) - w(i, j, k, irho)*w&
&         (i, j, k, ivz)
        drw = dis2*ddw4 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, ivz)-w(i&
&         , j-1, k, irho)*w(i, j-1, k, ivz)-three*ddw4)
        ddw5 = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
        dre = dis2*ddw5 - dis4*(w(i, j+2, k, irhoe)-w(i, j-1, k, irhoe)-&
&         three*ddw5)
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
        if (correctfork) then
          ddw6 = w(i, j+1, k, irho)*w(i, j+1, k, itu1) - w(i, j, k, irho&
&           )*w(i, j, k, itu1)
          drk = dis2*ddw6 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, itu1)-&
&           w(i, j-1, k, irho)*w(i, j-1, k, itu1)-three*ddw6)
          kavg = half*(w(i, j, k, itu1)+w(i, j+1, k, itu1))
        else
          drk = zero
          kavg = zero
        end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
        gammaavg = half*(gamma(i, j+1, k)+gamma(i, j, k))
        gm1 = gammaavg - one
        ovgm1 = one/gm1
        gm53 = gammaavg - five*third
! compute the average state at the interface.
        uavg = half*(w(i, j+1, k, ivx)+w(i, j, k, ivx))
        vavg = half*(w(i, j+1, k, ivy)+w(i, j, k, ivy))
        wavg = half*(w(i, j+1, k, ivz)+w(i, j, k, ivz))
        a2avg = half*(gamma(i, j+1, k)*p(i, j+1, k)/w(i, j+1, k, irho)+&
&         gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
        area = sqrt(sj(i, j, k, 1)**2 + sj(i, j, k, 2)**2 + sj(i, j, k, &
&         3)**2)
        if (1.e-25_realtype .lt. area) then
          max5 = area
        else
          max5 = 1.e-25_realtype
        end if
        tmp = one/max5
        sx = sj(i, j, k, 1)*tmp
        sy = sj(i, j, k, 2)*tmp
        sz = sj(i, j, k, 3)*tmp
        alphaavg = half*(uavg**2+vavg**2+wavg**2)
        havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
        aavg = sqrt(a2avg)
        unavg = uavg*sx + vavg*sy + wavg*sz
        ovaavg = one/aavg
        ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
        if (addgridvelocities) sface = sfacej(i, j, k)*tmp
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
        else
          lam1 = -(unavg-sface+aavg)
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
        else
          lam2 = -(unavg-sface-aavg)
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
        else
          lam3 = -(unavg-sface)
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max6 = epsacoustic*rrad
        else
          max6 = lam1
        end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
        lam1 = max6*area
        if (lam2 .lt. epsacoustic*rrad) then
          max7 = epsacoustic*rrad
        else
          max7 = lam2
        end if
        lam2 = max7*area
        if (lam3 .lt. epsshear*rrad) then
          max8 = epsshear*rrad
        else
          max8 = lam3
        end if
        lam3 = max8*area
! some abbreviations, which occur quite often in the
! dissipation terms.
        abv1 = half*(lam1+lam2)
        abv2 = half*(lam1-lam2)
        abv3 = abv1 - lam3
        abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53*&
&         drk
        abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
        abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
        abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
        fs = lam3*dr + abv6
        fw(i, j+1, k, irho) = fw(i, j+1, k, irho) + fs
        fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
        fs = lam3*dru + uavg*abv6 + sx*abv7
        fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fs
        fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
        fs = lam3*drv + vavg*abv6 + sy*abv7
        fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fs
        fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
        fs = lam3*drw + wavg*abv6 + sz*abv7
        fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fs
        fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
        fs = lam3*dre + havg*abv6 + unavg*abv7
        fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + fs
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
      end do
      dssd = 0.0_8
!$bwd-of ii-loop 
      do ii=0,nx*ny*kl-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, ny) + 2
        k = ii/(nx*ny) + 1
! compute the dissipation coefficients for this face.
        ppor = zero
        if (pork(i, j, k) .eq. normalflux) ppor = one
        if (dss(i, j, k, 3) .lt. dss(i, j, k+1, 3)) then
          y3 = dss(i, j, k+1, 3)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          y3 = dss(i, j, k, 3)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (dpmax .gt. y3) then
          min3 = y3
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          min3 = dpmax
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        dis2 = ppor*fis2*min3
        arg1 = ppor*fis4
        dis4 = mydim(arg1, dis2)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
        ddw1 = w(i, j, k+1, irho) - w(i, j, k, irho)
        dr = dis2*ddw1 - dis4*(w(i, j, k+2, irho)-w(i, j, k-1, irho)-&
&         three*ddw1)
        ddw2 = w(i, j, k+1, irho)*w(i, j, k+1, ivx) - w(i, j, k, irho)*w&
&         (i, j, k, ivx)
        dru = dis2*ddw2 - dis4*(w(i, j, k+2, irho)*w(i, j, k+2, ivx)-w(i&
&         , j, k-1, irho)*w(i, j, k-1, ivx)-three*ddw2)
        ddw3 = w(i, j, k+1, irho)*w(i, j, k+1, ivy) - w(i, j, k, irho)*w&
&         (i, j, k, ivy)
        drv = dis2*ddw3 - dis4*(w(i, j, k+2, irho)*w(i, j, k+2, ivy)-w(i&
&         , j, k-1, irho)*w(i, j, k-1, ivy)-three*ddw3)
        ddw4 = w(i, j, k+1, irho)*w(i, j, k+1, ivz) - w(i, j, k, irho)*w&
&         (i, j, k, ivz)
        drw = dis2*ddw4 - dis4*(w(i, j, k+2, irho)*w(i, j, k+2, ivz)-w(i&
&         , j, k-1, irho)*w(i, j, k-1, ivz)-three*ddw4)
        ddw5 = w(i, j, k+1, irhoe) - w(i, j, k, irhoe)
        dre = dis2*ddw5 - dis4*(w(i, j, k+2, irhoe)-w(i, j, k-1, irhoe)-&
&         three*ddw5)
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
        if (correctfork) then
          ddw6 = w(i, j, k+1, irho)*w(i, j, k+1, itu1) - w(i, j, k, irho&
&           )*w(i, j, k, itu1)
          drk = dis2*ddw6 - dis4*(w(i, j, k+2, irho)*w(i, j, k+2, itu1)-&
&           w(i, j, k-1, irho)*w(i, j, k-1, itu1)-three*ddw6)
          kavg = half*(w(i, j, k+1, itu1)+w(i, j, k, itu1))
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        else
          drk = zero
          kavg = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
        gammaavg = half*(gamma(i, j, k+1)+gamma(i, j, k))
        gm1 = gammaavg - one
        ovgm1 = one/gm1
        gm53 = gammaavg - five*third
! compute the average state at the interface.
        uavg = half*(w(i, j, k+1, ivx)+w(i, j, k, ivx))
        vavg = half*(w(i, j, k+1, ivy)+w(i, j, k, ivy))
        wavg = half*(w(i, j, k+1, ivz)+w(i, j, k, ivz))
        a2avg = half*(gamma(i, j, k+1)*p(i, j, k+1)/w(i, j, k+1, irho)+&
&         gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
        area = sqrt(sk(i, j, k, 1)**2 + sk(i, j, k, 2)**2 + sk(i, j, k, &
&         3)**2)
        if (1.e-25_realtype .lt. area) then
          max9 = area
        else
          max9 = 1.e-25_realtype
        end if
        tmp = one/max9
        sx = sk(i, j, k, 1)*tmp
        sy = sk(i, j, k, 2)*tmp
        sz = sk(i, j, k, 3)*tmp
        alphaavg = half*(uavg**2+vavg**2+wavg**2)
        havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
        aavg = sqrt(a2avg)
        unavg = uavg*sx + vavg*sy + wavg*sz
        ovaavg = one/aavg
        ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
        if (addgridvelocities) sface = sfacek(i, j, k)*tmp
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          lam1 = -(unavg-sface+aavg)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          lam2 = -(unavg-sface-aavg)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          lam3 = -(unavg-sface)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max10 = epsacoustic*rrad
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          max10 = lam1
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
        lam1 = max10*area
        if (lam2 .lt. epsacoustic*rrad) then
          max11 = epsacoustic*rrad
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          max11 = lam2
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        lam2 = max11*area
        if (lam3 .lt. epsshear*rrad) then
          max12 = epsshear*rrad
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          max12 = lam3
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        lam3 = max12*area
! some abbreviations, which occur quite often in the
! dissipation terms.
        abv1 = half*(lam1+lam2)
        abv2 = half*(lam1-lam2)
        abv3 = abv1 - lam3
        abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53*&
&         drk
        abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
        abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
        abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
! x-momentum.
! y-momentum.
! z-momentum.
! energy.
        fsd = fwd(i, j, k+1, irhoe) - fwd(i, j, k, irhoe)
        lam3d = dre*fsd
        dred = lam3*fsd
        havgd = abv6*fsd
        abv6d = havg*fsd
        unavgd = abv7*fsd
        abv7d = unavg*fsd
        fsd = fwd(i, j, k+1, imz) - fwd(i, j, k, imz)
        lam3d = lam3d + drw*fsd
        drwd = lam3*fsd
        wavgd = abv6*fsd
        abv6d = abv6d + wavg*fsd
        abv7d = abv7d + sz*fsd
        fsd = fwd(i, j, k+1, imy) - fwd(i, j, k, imy)
        lam3d = lam3d + drv*fsd
        drvd = lam3*fsd
        vavgd = abv6*fsd
        abv6d = abv6d + vavg*fsd
        abv7d = abv7d + sy*fsd
        fsd = fwd(i, j, k+1, imx) - fwd(i, j, k, imx)
        lam3d = lam3d + dru*fsd
        drud = lam3*fsd
        uavgd = abv6*fsd
        abv6d = abv6d + uavg*fsd
        abv7d = abv7d + sx*fsd
        fsd = fwd(i, j, k+1, irho) - fwd(i, j, k, irho)
        abv6d = abv6d + fsd
        abv2d = abv4*ovaavg*abv7d + abv5*ovaavg*abv6d
        abv4d = abv2*ovaavg*abv7d + abv3*ova2avg*abv6d
        ovaavgd = abv2*abv4*abv7d + abv2*abv5*abv6d
        abv3d = abv5*abv7d + abv4*ova2avg*abv6d
        lam3d = lam3d + dr*fsd - abv3d
        abv5d = abv3*abv7d + abv2*ovaavg*abv6d
        ova2avgd = abv3*abv4*abv6d
        unavgd = unavgd - dr*abv5d
        tempd2 = gm1*abv4d
        drd = lam3*fsd + alphaavg*tempd2 - unavg*abv5d
        drud = drud + sx*abv5d - uavg*tempd2
        drvd = drvd + sy*abv5d - vavg*tempd2
        drwd = drwd + sz*abv5d - wavg*tempd2
        drkd = -(gm53*abv4d)
        alphaavgd = dr*tempd2
        uavgd = uavgd - dru*tempd2
        vavgd = vavgd - drv*tempd2
        dred = dred + tempd2
        wavgd = wavgd - drw*tempd2
        abv1d = abv3d
        lam1d = half*abv2d + half*abv1d
        lam2d = half*abv1d - half*abv2d
        max12d = area*lam3d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          rradd = epsshear*max12d
          lam3d = 0.0_8
        else
          lam3d = max12d
          rradd = 0.0_8
        end if
        max11d = area*lam2d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max11d
          lam2d = 0.0_8
        else
          lam2d = max11d
        end if
        max10d = area*lam1d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max10d
          lam1d = 0.0_8
        else
          lam1d = max10d
        end if
        lam3d = lam3d + rradd
        aavgd = rradd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          unavgd = unavgd + lam3d
        else
          unavgd = unavgd - lam3d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          unavgd = unavgd + lam2d
          aavgd = aavgd - lam2d
        else
          aavgd = aavgd + lam2d
          unavgd = unavgd - lam2d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          unavgd = unavgd + lam1d
          aavgd = aavgd + lam1d
        else
          unavgd = unavgd - lam1d
          aavgd = aavgd - lam1d
        end if
        alphaavgd = alphaavgd + havgd
        tempd2 = half*alphaavgd
        aavgd = aavgd - one*ovaavgd/aavg**2
        if (a2avg .eq. 0.0_8) then
          a2avgd = ovgm1*havgd - one*ova2avgd/a2avg**2
        else
          a2avgd = aavgd/(2.0*sqrt(a2avg)) - one*ova2avgd/a2avg**2 + &
&           ovgm1*havgd
        end if
        uavgd = uavgd + sx*unavgd + 2*uavg*tempd2
        vavgd = vavgd + sy*unavgd + 2*vavg*tempd2
        wavgd = wavgd + sz*unavgd + 2*wavg*tempd2
        kavgd = -(gm53*ovgm1*havgd)
        temp3 = w(i, j, k+1, irho)
        temp1 = w(i, j, k, irho)
        tempd3 = gamma(i, j, k+1)*half*a2avgd/temp3
        tempd = gamma(i, j, k)*half*a2avgd/temp1
        pd(i, j, k) = pd(i, j, k) + tempd
        wd(i, j, k, irho) = wd(i, j, k, irho) - p(i, j, k)*tempd/temp1
        pd(i, j, k+1) = pd(i, j, k+1) + tempd3
        wd(i, j, k+1, irho) = wd(i, j, k+1, irho) - p(i, j, k+1)*tempd3/&
&         temp3
        wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + half*wavgd
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + half*wavgd
        wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + half*vavgd
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + half*vavgd
        wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + half*uavgd
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + half*uavgd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          dis2d = 0.0_8
          dis4d = 0.0_8
        else
          tempd0 = -(dis4*drkd)
          wd(i, j, k+1, itu1) = wd(i, j, k+1, itu1) + half*kavgd
          wd(i, j, k, itu1) = wd(i, j, k, itu1) + half*kavgd
          temp3 = w(i, j, k-1, itu1)
          temp2 = w(i, j, k-1, irho)
          temp1 = w(i, j, k+2, itu1)
          temp0 = w(i, j, k+2, irho)
          dis2d = ddw6*drkd
          ddw6d = dis2*drkd - three*tempd0
          dis4d = -((temp0*temp1-temp2*temp3-three*ddw6)*drkd)
          wd(i, j, k+2, irho) = wd(i, j, k+2, irho) + temp1*tempd0
          wd(i, j, k+2, itu1) = wd(i, j, k+2, itu1) + temp0*tempd0
          wd(i, j, k-1, irho) = wd(i, j, k-1, irho) - temp3*tempd0
          wd(i, j, k-1, itu1) = wd(i, j, k-1, itu1) - temp2*tempd0
          wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, itu1)&
&           *ddw6d
          wd(i, j, k+1, itu1) = wd(i, j, k+1, itu1) + w(i, j, k+1, irho)&
&           *ddw6d
          wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, itu1)*ddw6d
          wd(i, j, k, itu1) = wd(i, j, k, itu1) - w(i, j, k, irho)*ddw6d
        end if
        tempd0 = -(dis4*drwd)
        temp0 = w(i, j, k+2, irho)
        temp1 = w(i, j, k+2, ivz)
        temp2 = w(i, j, k-1, irho)
        temp3 = w(i, j, k-1, ivz)
        tempd2 = -(dis4*dred)
        dis2d = dis2d + ddw5*dred + ddw4*drwd + ddw3*drvd + ddw2*drud + &
&         ddw1*drd
        ddw5d = dis2*dred - three*tempd2
        dis4d = dis4d - (w(i, j, k+2, irhoe)-w(i, j, k-1, irhoe)-three*&
&         ddw5)*dred - (temp0*temp1-temp2*temp3-three*ddw4)*drwd
        wd(i, j, k+2, irhoe) = wd(i, j, k+2, irhoe) + tempd2
        wd(i, j, k-1, irhoe) = wd(i, j, k-1, irhoe) - tempd2
        wd(i, j, k+1, irhoe) = wd(i, j, k+1, irhoe) + ddw5d
        wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddw5d
        ddw4d = dis2*drwd - three*tempd0
        wd(i, j, k+2, irho) = wd(i, j, k+2, irho) + temp1*tempd0
        wd(i, j, k+2, ivz) = wd(i, j, k+2, ivz) + temp0*tempd0
        wd(i, j, k-1, irho) = wd(i, j, k-1, irho) - temp3*tempd0
        wd(i, j, k-1, ivz) = wd(i, j, k-1, ivz) - temp2*tempd0
        wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, ivz)*&
&         ddw4d
        wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + w(i, j, k+1, irho)*&
&         ddw4d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivz)*ddw4d
        wd(i, j, k, ivz) = wd(i, j, k, ivz) - w(i, j, k, irho)*ddw4d
        temp3 = w(i, j, k-1, ivy)
        temp2 = w(i, j, k-1, irho)
        temp1 = w(i, j, k+2, ivy)
        temp0 = w(i, j, k+2, irho)
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw3)*drvd
        tempd0 = -(dis4*drvd)
        ddw3d = dis2*drvd - three*tempd0
        wd(i, j, k+2, irho) = wd(i, j, k+2, irho) + temp1*tempd0
        wd(i, j, k+2, ivy) = wd(i, j, k+2, ivy) + temp0*tempd0
        wd(i, j, k-1, irho) = wd(i, j, k-1, irho) - temp3*tempd0
        wd(i, j, k-1, ivy) = wd(i, j, k-1, ivy) - temp2*tempd0
        wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, ivy)*&
&         ddw3d
        wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + w(i, j, k+1, irho)*&
&         ddw3d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivy)*ddw3d
        wd(i, j, k, ivy) = wd(i, j, k, ivy) - w(i, j, k, irho)*ddw3d
        temp3 = w(i, j, k-1, ivx)
        temp2 = w(i, j, k-1, irho)
        temp1 = w(i, j, k+2, ivx)
        temp0 = w(i, j, k+2, irho)
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw2)*drud - (w(i&
&         , j, k+2, irho)-w(i, j, k-1, irho)-three*ddw1)*drd
        tempd0 = -(dis4*drud)
        ddw2d = dis2*drud - three*tempd0
        wd(i, j, k+2, irho) = wd(i, j, k+2, irho) + temp1*tempd0
        wd(i, j, k+2, ivx) = wd(i, j, k+2, ivx) + temp0*tempd0
        wd(i, j, k-1, irho) = wd(i, j, k-1, irho) - temp3*tempd0
        wd(i, j, k-1, ivx) = wd(i, j, k-1, ivx) - temp2*tempd0
        wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, ivx)*&
&         ddw2d
        wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + w(i, j, k+1, irho)*&
&         ddw2d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivx)*ddw2d
        wd(i, j, k, ivx) = wd(i, j, k, ivx) - w(i, j, k, irho)*ddw2d
        tempd2 = -(dis4*drd)
        ddw1d = dis2*drd - three*tempd2
        wd(i, j, k+2, irho) = wd(i, j, k+2, irho) + tempd2
        wd(i, j, k-1, irho) = wd(i, j, k-1, irho) - tempd2
        wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + ddw1d
        wd(i, j, k, irho) = wd(i, j, k, irho) - ddw1d
        call mydim_fast_b(arg1, arg1d, dis2, dis2d, dis4d)
        min3d = ppor*fis2*dis2d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          y3d = min3d
        else
          y3d = 0.0_8
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          dssd(i, j, k+1, 3) = dssd(i, j, k+1, 3) + y3d
        else
          dssd(i, j, k, 3) = dssd(i, j, k, 3) + y3d
        end if
      end do
!$bwd-of ii-loop 
      do ii=0,nx*jl*nz-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, jl) + 1
        k = ii/(nx*jl) + 2
! compute the dissipation coefficients for this face.
        ppor = zero
        if (porj(i, j, k) .eq. normalflux) ppor = one
        if (dss(i, j, k, 2) .lt. dss(i, j+1, k, 2)) then
          y2 = dss(i, j+1, k, 2)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          y2 = dss(i, j, k, 2)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (dpmax .gt. y2) then
          min2 = y2
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          min2 = dpmax
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        dis2 = ppor*fis2*min2
        arg1 = ppor*fis4
        dis4 = mydim(arg1, dis2)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
        ddw1 = w(i, j+1, k, irho) - w(i, j, k, irho)
        dr = dis2*ddw1 - dis4*(w(i, j+2, k, irho)-w(i, j-1, k, irho)-&
&         three*ddw1)
        ddw2 = w(i, j+1, k, irho)*w(i, j+1, k, ivx) - w(i, j, k, irho)*w&
&         (i, j, k, ivx)
        dru = dis2*ddw2 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, ivx)-w(i&
&         , j-1, k, irho)*w(i, j-1, k, ivx)-three*ddw2)
        ddw3 = w(i, j+1, k, irho)*w(i, j+1, k, ivy) - w(i, j, k, irho)*w&
&         (i, j, k, ivy)
        drv = dis2*ddw3 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, ivy)-w(i&
&         , j-1, k, irho)*w(i, j-1, k, ivy)-three*ddw3)
        ddw4 = w(i, j+1, k, irho)*w(i, j+1, k, ivz) - w(i, j, k, irho)*w&
&         (i, j, k, ivz)
        drw = dis2*ddw4 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, ivz)-w(i&
&         , j-1, k, irho)*w(i, j-1, k, ivz)-three*ddw4)
        ddw5 = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
        dre = dis2*ddw5 - dis4*(w(i, j+2, k, irhoe)-w(i, j-1, k, irhoe)-&
&         three*ddw5)
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
        if (correctfork) then
          ddw6 = w(i, j+1, k, irho)*w(i, j+1, k, itu1) - w(i, j, k, irho&
&           )*w(i, j, k, itu1)
          drk = dis2*ddw6 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, itu1)-&
&           w(i, j-1, k, irho)*w(i, j-1, k, itu1)-three*ddw6)
          kavg = half*(w(i, j, k, itu1)+w(i, j+1, k, itu1))
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        else
          drk = zero
          kavg = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
        gammaavg = half*(gamma(i, j+1, k)+gamma(i, j, k))
        gm1 = gammaavg - one
        ovgm1 = one/gm1
        gm53 = gammaavg - five*third
! compute the average state at the interface.
        uavg = half*(w(i, j+1, k, ivx)+w(i, j, k, ivx))
        vavg = half*(w(i, j+1, k, ivy)+w(i, j, k, ivy))
        wavg = half*(w(i, j+1, k, ivz)+w(i, j, k, ivz))
        a2avg = half*(gamma(i, j+1, k)*p(i, j+1, k)/w(i, j+1, k, irho)+&
&         gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
        area = sqrt(sj(i, j, k, 1)**2 + sj(i, j, k, 2)**2 + sj(i, j, k, &
&         3)**2)
        if (1.e-25_realtype .lt. area) then
          max5 = area
        else
          max5 = 1.e-25_realtype
        end if
        tmp = one/max5
        sx = sj(i, j, k, 1)*tmp
        sy = sj(i, j, k, 2)*tmp
        sz = sj(i, j, k, 3)*tmp
        alphaavg = half*(uavg**2+vavg**2+wavg**2)
        havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
        aavg = sqrt(a2avg)
        unavg = uavg*sx + vavg*sy + wavg*sz
        ovaavg = one/aavg
        ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
        if (addgridvelocities) sface = sfacej(i, j, k)*tmp
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          lam1 = -(unavg-sface+aavg)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          lam2 = -(unavg-sface-aavg)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          lam3 = -(unavg-sface)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max6 = epsacoustic*rrad
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          max6 = lam1
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
        lam1 = max6*area
        if (lam2 .lt. epsacoustic*rrad) then
          max7 = epsacoustic*rrad
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          max7 = lam2
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        lam2 = max7*area
        if (lam3 .lt. epsshear*rrad) then
          max8 = epsshear*rrad
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          max8 = lam3
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        lam3 = max8*area
! some abbreviations, which occur quite often in the
! dissipation terms.
        abv1 = half*(lam1+lam2)
        abv2 = half*(lam1-lam2)
        abv3 = abv1 - lam3
        abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53*&
&         drk
        abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
        abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
        abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
! x-momentum.
! y-momentum.
! z-momentum.
! energy.
        fsd = fwd(i, j+1, k, irhoe) - fwd(i, j, k, irhoe)
        lam3d = dre*fsd
        dred = lam3*fsd
        havgd = abv6*fsd
        abv6d = havg*fsd
        unavgd = abv7*fsd
        abv7d = unavg*fsd
        fsd = fwd(i, j+1, k, imz) - fwd(i, j, k, imz)
        lam3d = lam3d + drw*fsd
        drwd = lam3*fsd
        wavgd = abv6*fsd
        abv6d = abv6d + wavg*fsd
        abv7d = abv7d + sz*fsd
        fsd = fwd(i, j+1, k, imy) - fwd(i, j, k, imy)
        lam3d = lam3d + drv*fsd
        drvd = lam3*fsd
        vavgd = abv6*fsd
        abv6d = abv6d + vavg*fsd
        abv7d = abv7d + sy*fsd
        fsd = fwd(i, j+1, k, imx) - fwd(i, j, k, imx)
        lam3d = lam3d + dru*fsd
        drud = lam3*fsd
        uavgd = abv6*fsd
        abv6d = abv6d + uavg*fsd
        abv7d = abv7d + sx*fsd
        fsd = fwd(i, j+1, k, irho) - fwd(i, j, k, irho)
        abv6d = abv6d + fsd
        abv2d = abv4*ovaavg*abv7d + abv5*ovaavg*abv6d
        abv4d = abv2*ovaavg*abv7d + abv3*ova2avg*abv6d
        ovaavgd = abv2*abv4*abv7d + abv2*abv5*abv6d
        abv3d = abv5*abv7d + abv4*ova2avg*abv6d
        lam3d = lam3d + dr*fsd - abv3d
        abv5d = abv3*abv7d + abv2*ovaavg*abv6d
        ova2avgd = abv3*abv4*abv6d
        unavgd = unavgd - dr*abv5d
        tempd2 = gm1*abv4d
        drd = lam3*fsd + alphaavg*tempd2 - unavg*abv5d
        drud = drud + sx*abv5d - uavg*tempd2
        drvd = drvd + sy*abv5d - vavg*tempd2
        drwd = drwd + sz*abv5d - wavg*tempd2
        drkd = -(gm53*abv4d)
        alphaavgd = dr*tempd2
        uavgd = uavgd - dru*tempd2
        vavgd = vavgd - drv*tempd2
        dred = dred + tempd2
        wavgd = wavgd - drw*tempd2
        abv1d = abv3d
        lam1d = half*abv2d + half*abv1d
        lam2d = half*abv1d - half*abv2d
        max8d = area*lam3d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          rradd = epsshear*max8d
          lam3d = 0.0_8
        else
          lam3d = max8d
          rradd = 0.0_8
        end if
        max7d = area*lam2d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max7d
          lam2d = 0.0_8
        else
          lam2d = max7d
        end if
        max6d = area*lam1d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max6d
          lam1d = 0.0_8
        else
          lam1d = max6d
        end if
        lam3d = lam3d + rradd
        aavgd = rradd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          unavgd = unavgd + lam3d
        else
          unavgd = unavgd - lam3d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          unavgd = unavgd + lam2d
          aavgd = aavgd - lam2d
        else
          aavgd = aavgd + lam2d
          unavgd = unavgd - lam2d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          unavgd = unavgd + lam1d
          aavgd = aavgd + lam1d
        else
          unavgd = unavgd - lam1d
          aavgd = aavgd - lam1d
        end if
        alphaavgd = alphaavgd + havgd
        tempd2 = half*alphaavgd
        aavgd = aavgd - one*ovaavgd/aavg**2
        if (a2avg .eq. 0.0_8) then
          a2avgd = ovgm1*havgd - one*ova2avgd/a2avg**2
        else
          a2avgd = aavgd/(2.0*sqrt(a2avg)) - one*ova2avgd/a2avg**2 + &
&           ovgm1*havgd
        end if
        uavgd = uavgd + sx*unavgd + 2*uavg*tempd2
        vavgd = vavgd + sy*unavgd + 2*vavg*tempd2
        wavgd = wavgd + sz*unavgd + 2*wavg*tempd2
        kavgd = -(gm53*ovgm1*havgd)
        temp3 = w(i, j+1, k, irho)
        temp1 = w(i, j, k, irho)
        tempd3 = gamma(i, j+1, k)*half*a2avgd/temp3
        tempd = gamma(i, j, k)*half*a2avgd/temp1
        pd(i, j, k) = pd(i, j, k) + tempd
        wd(i, j, k, irho) = wd(i, j, k, irho) - p(i, j, k)*tempd/temp1
        pd(i, j+1, k) = pd(i, j+1, k) + tempd3
        wd(i, j+1, k, irho) = wd(i, j+1, k, irho) - p(i, j+1, k)*tempd3/&
&         temp3
        wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + half*wavgd
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + half*wavgd
        wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + half*vavgd
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + half*vavgd
        wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + half*uavgd
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + half*uavgd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          dis2d = 0.0_8
          dis4d = 0.0_8
        else
          tempd0 = -(dis4*drkd)
          wd(i, j, k, itu1) = wd(i, j, k, itu1) + half*kavgd
          wd(i, j+1, k, itu1) = wd(i, j+1, k, itu1) + half*kavgd
          temp3 = w(i, j-1, k, itu1)
          temp2 = w(i, j-1, k, irho)
          temp1 = w(i, j+2, k, itu1)
          temp0 = w(i, j+2, k, irho)
          dis2d = ddw6*drkd
          ddw6d = dis2*drkd - three*tempd0
          dis4d = -((temp0*temp1-temp2*temp3-three*ddw6)*drkd)
          wd(i, j+2, k, irho) = wd(i, j+2, k, irho) + temp1*tempd0
          wd(i, j+2, k, itu1) = wd(i, j+2, k, itu1) + temp0*tempd0
          wd(i, j-1, k, irho) = wd(i, j-1, k, irho) - temp3*tempd0
          wd(i, j-1, k, itu1) = wd(i, j-1, k, itu1) - temp2*tempd0
          wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, itu1)&
&           *ddw6d
          wd(i, j+1, k, itu1) = wd(i, j+1, k, itu1) + w(i, j+1, k, irho)&
&           *ddw6d
          wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, itu1)*ddw6d
          wd(i, j, k, itu1) = wd(i, j, k, itu1) - w(i, j, k, irho)*ddw6d
        end if
        tempd0 = -(dis4*drwd)
        temp0 = w(i, j+2, k, irho)
        temp1 = w(i, j+2, k, ivz)
        temp2 = w(i, j-1, k, irho)
        temp3 = w(i, j-1, k, ivz)
        tempd2 = -(dis4*dred)
        dis2d = dis2d + ddw5*dred + ddw4*drwd + ddw3*drvd + ddw2*drud + &
&         ddw1*drd
        ddw5d = dis2*dred - three*tempd2
        dis4d = dis4d - (w(i, j+2, k, irhoe)-w(i, j-1, k, irhoe)-three*&
&         ddw5)*dred - (temp0*temp1-temp2*temp3-three*ddw4)*drwd
        wd(i, j+2, k, irhoe) = wd(i, j+2, k, irhoe) + tempd2
        wd(i, j-1, k, irhoe) = wd(i, j-1, k, irhoe) - tempd2
        wd(i, j+1, k, irhoe) = wd(i, j+1, k, irhoe) + ddw5d
        wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddw5d
        ddw4d = dis2*drwd - three*tempd0
        wd(i, j+2, k, irho) = wd(i, j+2, k, irho) + temp1*tempd0
        wd(i, j+2, k, ivz) = wd(i, j+2, k, ivz) + temp0*tempd0
        wd(i, j-1, k, irho) = wd(i, j-1, k, irho) - temp3*tempd0
        wd(i, j-1, k, ivz) = wd(i, j-1, k, ivz) - temp2*tempd0
        wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, ivz)*&
&         ddw4d
        wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + w(i, j+1, k, irho)*&
&         ddw4d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivz)*ddw4d
        wd(i, j, k, ivz) = wd(i, j, k, ivz) - w(i, j, k, irho)*ddw4d
        temp3 = w(i, j-1, k, ivy)
        temp2 = w(i, j-1, k, irho)
        temp1 = w(i, j+2, k, ivy)
        temp0 = w(i, j+2, k, irho)
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw3)*drvd
        tempd0 = -(dis4*drvd)
        ddw3d = dis2*drvd - three*tempd0
        wd(i, j+2, k, irho) = wd(i, j+2, k, irho) + temp1*tempd0
        wd(i, j+2, k, ivy) = wd(i, j+2, k, ivy) + temp0*tempd0
        wd(i, j-1, k, irho) = wd(i, j-1, k, irho) - temp3*tempd0
        wd(i, j-1, k, ivy) = wd(i, j-1, k, ivy) - temp2*tempd0
        wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, ivy)*&
&         ddw3d
        wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + w(i, j+1, k, irho)*&
&         ddw3d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivy)*ddw3d
        wd(i, j, k, ivy) = wd(i, j, k, ivy) - w(i, j, k, irho)*ddw3d
        temp3 = w(i, j-1, k, ivx)
        temp2 = w(i, j-1, k, irho)
        temp1 = w(i, j+2, k, ivx)
        temp0 = w(i, j+2, k, irho)
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw2)*drud - (w(i&
&         , j+2, k, irho)-w(i, j-1, k, irho)-three*ddw1)*drd
        tempd0 = -(dis4*drud)
        ddw2d = dis2*drud - three*tempd0
        wd(i, j+2, k, irho) = wd(i, j+2, k, irho) + temp1*tempd0
        wd(i, j+2, k, ivx) = wd(i, j+2, k, ivx) + temp0*tempd0
        wd(i, j-1, k, irho) = wd(i, j-1, k, irho) - temp3*tempd0
        wd(i, j-1, k, ivx) = wd(i, j-1, k, ivx) - temp2*tempd0
        wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, ivx)*&
&         ddw2d
        wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + w(i, j+1, k, irho)*&
&         ddw2d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivx)*ddw2d
        wd(i, j, k, ivx) = wd(i, j, k, ivx) - w(i, j, k, irho)*ddw2d
        tempd2 = -(dis4*drd)
        ddw1d = dis2*drd - three*tempd2
        wd(i, j+2, k, irho) = wd(i, j+2, k, irho) + tempd2
        wd(i, j-1, k, irho) = wd(i, j-1, k, irho) - tempd2
        wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + ddw1d
        wd(i, j, k, irho) = wd(i, j, k, irho) - ddw1d
        call mydim_fast_b(arg1, arg1d, dis2, dis2d, dis4d)
        min2d = ppor*fis2*dis2d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          y2d = min2d
        else
          y2d = 0.0_8
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          dssd(i, j+1, k, 2) = dssd(i, j+1, k, 2) + y2d
        else
          dssd(i, j, k, 2) = dssd(i, j, k, 2) + y2d
        end if
      end do
!$bwd-of ii-loop 
      do ii=0,il*ny*nz-1
        i = mod(ii, il) + 1
        j = mod(ii/il, ny) + 2
        k = ii/(il*ny) + 2
! compute the dissipation coefficients for this face.
        ppor = zero
        if (pori(i, j, k) .eq. normalflux) ppor = one
        if (dss(i, j, k, 1) .lt. dss(i+1, j, k, 1)) then
          y1 = dss(i+1, j, k, 1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          y1 = dss(i, j, k, 1)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (dpmax .gt. y1) then
          min1 = y1
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          min1 = dpmax
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        dis2 = ppor*fis2*min1
        arg1 = ppor*fis4
        dis4 = mydim(arg1, dis2)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
        ddw1 = w(i+1, j, k, irho) - w(i, j, k, irho)
        dr = dis2*ddw1 - dis4*(w(i+2, j, k, irho)-w(i-1, j, k, irho)-&
&         three*ddw1)
        ddw2 = w(i+1, j, k, irho)*w(i+1, j, k, ivx) - w(i, j, k, irho)*w&
&         (i, j, k, ivx)
        dru = dis2*ddw2 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, ivx)-w(i&
&         -1, j, k, irho)*w(i-1, j, k, ivx)-three*ddw2)
        ddw3 = w(i+1, j, k, irho)*w(i+1, j, k, ivy) - w(i, j, k, irho)*w&
&         (i, j, k, ivy)
        drv = dis2*ddw3 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, ivy)-w(i&
&         -1, j, k, irho)*w(i-1, j, k, ivy)-three*ddw3)
        ddw4 = w(i+1, j, k, irho)*w(i+1, j, k, ivz) - w(i, j, k, irho)*w&
&         (i, j, k, ivz)
        drw = dis2*ddw4 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, ivz)-w(i&
&         -1, j, k, irho)*w(i-1, j, k, ivz)-three*ddw4)
        ddw5 = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
        dre = dis2*ddw5 - dis4*(w(i+2, j, k, irhoe)-w(i-1, j, k, irhoe)-&
&         three*ddw5)
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
        if (correctfork) then
          ddw6 = w(i+1, j, k, irho)*w(i+1, j, k, itu1) - w(i, j, k, irho&
&           )*w(i, j, k, itu1)
          drk = dis2*ddw6 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, itu1)-&
&           w(i-1, j, k, irho)*w(i-1, j, k, itu1)-three*ddw6)
          kavg = half*(w(i, j, k, itu1)+w(i+1, j, k, itu1))
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        else
          drk = zero
          kavg = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
        gammaavg = half*(gamma(i+1, j, k)+gamma(i, j, k))
        gm1 = gammaavg - one
        ovgm1 = one/gm1
        gm53 = gammaavg - five*third
! compute the average state at the interface.
        uavg = half*(w(i+1, j, k, ivx)+w(i, j, k, ivx))
        vavg = half*(w(i+1, j, k, ivy)+w(i, j, k, ivy))
        wavg = half*(w(i+1, j, k, ivz)+w(i, j, k, ivz))
        a2avg = half*(gamma(i+1, j, k)*p(i+1, j, k)/w(i+1, j, k, irho)+&
&         gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
        area = sqrt(si(i, j, k, 1)**2 + si(i, j, k, 2)**2 + si(i, j, k, &
&         3)**2)
        if (1.e-25_realtype .lt. area) then
          max1 = area
        else
          max1 = 1.e-25_realtype
        end if
        tmp = one/max1
        sx = si(i, j, k, 1)*tmp
        sy = si(i, j, k, 2)*tmp
        sz = si(i, j, k, 3)*tmp
        alphaavg = half*(uavg**2+vavg**2+wavg**2)
        havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
        aavg = sqrt(a2avg)
        unavg = uavg*sx + vavg*sy + wavg*sz
        ovaavg = one/aavg
        ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
        if (addgridvelocities) sface = sfacei(i, j, k)*tmp
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          lam1 = -(unavg-sface+aavg)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          lam2 = -(unavg-sface-aavg)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          lam3 = -(unavg-sface)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max2 = epsacoustic*rrad
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          max2 = lam1
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
        lam1 = max2*area
        if (lam2 .lt. epsacoustic*rrad) then
          max3 = epsacoustic*rrad
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          max3 = lam2
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        lam2 = max3*area
        if (lam3 .lt. epsshear*rrad) then
          max4 = epsshear*rrad
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          max4 = lam3
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        lam3 = max4*area
! some abbreviations, which occur quite often in the
! dissipation terms.
        abv1 = half*(lam1+lam2)
        abv2 = half*(lam1-lam2)
        abv3 = abv1 - lam3
        abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53*&
&         drk
        abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
        abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
        abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
! x-momentum.
! y-momentum.
! z-momentum.
! energy.
        fsd = fwd(i+1, j, k, irhoe) - fwd(i, j, k, irhoe)
        lam3d = dre*fsd
        dred = lam3*fsd
        havgd = abv6*fsd
        abv6d = havg*fsd
        unavgd = abv7*fsd
        abv7d = unavg*fsd
        fsd = fwd(i+1, j, k, imz) - fwd(i, j, k, imz)
        lam3d = lam3d + drw*fsd
        drwd = lam3*fsd
        wavgd = abv6*fsd
        abv6d = abv6d + wavg*fsd
        abv7d = abv7d + sz*fsd
        fsd = fwd(i+1, j, k, imy) - fwd(i, j, k, imy)
        lam3d = lam3d + drv*fsd
        drvd = lam3*fsd
        vavgd = abv6*fsd
        abv6d = abv6d + vavg*fsd
        abv7d = abv7d + sy*fsd
        fsd = fwd(i+1, j, k, imx) - fwd(i, j, k, imx)
        lam3d = lam3d + dru*fsd
        drud = lam3*fsd
        uavgd = abv6*fsd
        abv6d = abv6d + uavg*fsd
        abv7d = abv7d + sx*fsd
        fsd = fwd(i+1, j, k, irho) - fwd(i, j, k, irho)
        abv6d = abv6d + fsd
        abv2d = abv4*ovaavg*abv7d + abv5*ovaavg*abv6d
        abv4d = abv2*ovaavg*abv7d + abv3*ova2avg*abv6d
        ovaavgd = abv2*abv4*abv7d + abv2*abv5*abv6d
        abv3d = abv5*abv7d + abv4*ova2avg*abv6d
        lam3d = lam3d + dr*fsd - abv3d
        abv5d = abv3*abv7d + abv2*ovaavg*abv6d
        ova2avgd = abv3*abv4*abv6d
        unavgd = unavgd - dr*abv5d
        tempd2 = gm1*abv4d
        drd = lam3*fsd + alphaavg*tempd2 - unavg*abv5d
        drud = drud + sx*abv5d - uavg*tempd2
        drvd = drvd + sy*abv5d - vavg*tempd2
        drwd = drwd + sz*abv5d - wavg*tempd2
        drkd = -(gm53*abv4d)
        alphaavgd = dr*tempd2
        uavgd = uavgd - dru*tempd2
        vavgd = vavgd - drv*tempd2
        dred = dred + tempd2
        wavgd = wavgd - drw*tempd2
        abv1d = abv3d
        lam1d = half*abv2d + half*abv1d
        lam2d = half*abv1d - half*abv2d
        max4d = area*lam3d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          rradd = epsshear*max4d
          lam3d = 0.0_8
        else
          lam3d = max4d
          rradd = 0.0_8
        end if
        max3d = area*lam2d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max3d
          lam2d = 0.0_8
        else
          lam2d = max3d
        end if
        max2d = area*lam1d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max2d
          lam1d = 0.0_8
        else
          lam1d = max2d
        end if
        lam3d = lam3d + rradd
        aavgd = rradd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          unavgd = unavgd + lam3d
        else
          unavgd = unavgd - lam3d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          unavgd = unavgd + lam2d
          aavgd = aavgd - lam2d
        else
          aavgd = aavgd + lam2d
          unavgd = unavgd - lam2d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          unavgd = unavgd + lam1d
          aavgd = aavgd + lam1d
        else
          unavgd = unavgd - lam1d
          aavgd = aavgd - lam1d
        end if
        alphaavgd = alphaavgd + havgd
        tempd2 = half*alphaavgd
        aavgd = aavgd - one*ovaavgd/aavg**2
        if (a2avg .eq. 0.0_8) then
          a2avgd = ovgm1*havgd - one*ova2avgd/a2avg**2
        else
          a2avgd = aavgd/(2.0*sqrt(a2avg)) - one*ova2avgd/a2avg**2 + &
&           ovgm1*havgd
        end if
        uavgd = uavgd + sx*unavgd + 2*uavg*tempd2
        vavgd = vavgd + sy*unavgd + 2*vavg*tempd2
        wavgd = wavgd + sz*unavgd + 2*wavg*tempd2
        kavgd = -(gm53*ovgm1*havgd)
        temp3 = w(i+1, j, k, irho)
        temp1 = w(i, j, k, irho)
        tempd3 = gamma(i+1, j, k)*half*a2avgd/temp3
        tempd = gamma(i, j, k)*half*a2avgd/temp1
        pd(i, j, k) = pd(i, j, k) + tempd
        wd(i, j, k, irho) = wd(i, j, k, irho) - p(i, j, k)*tempd/temp1
        pd(i+1, j, k) = pd(i+1, j, k) + tempd3
        wd(i+1, j, k, irho) = wd(i+1, j, k, irho) - p(i+1, j, k)*tempd3/&
&         temp3
        wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + half*wavgd
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + half*wavgd
        wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + half*vavgd
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + half*vavgd
        wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + half*uavgd
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + half*uavgd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          dis2d = 0.0_8
          dis4d = 0.0_8
        else
          tempd0 = -(dis4*drkd)
          wd(i, j, k, itu1) = wd(i, j, k, itu1) + half*kavgd
          wd(i+1, j, k, itu1) = wd(i+1, j, k, itu1) + half*kavgd
          temp3 = w(i-1, j, k, itu1)
          temp2 = w(i-1, j, k, irho)
          temp1 = w(i+2, j, k, itu1)
          temp0 = w(i+2, j, k, irho)
          dis2d = ddw6*drkd
          ddw6d = dis2*drkd - three*tempd0
          dis4d = -((temp0*temp1-temp2*temp3-three*ddw6)*drkd)
          wd(i+2, j, k, irho) = wd(i+2, j, k, irho) + temp1*tempd0
          wd(i+2, j, k, itu1) = wd(i+2, j, k, itu1) + temp0*tempd0
          wd(i-1, j, k, irho) = wd(i-1, j, k, irho) - temp3*tempd0
          wd(i-1, j, k, itu1) = wd(i-1, j, k, itu1) - temp2*tempd0
          wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, itu1)&
&           *ddw6d
          wd(i+1, j, k, itu1) = wd(i+1, j, k, itu1) + w(i+1, j, k, irho)&
&           *ddw6d
          wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, itu1)*ddw6d
          wd(i, j, k, itu1) = wd(i, j, k, itu1) - w(i, j, k, irho)*ddw6d
        end if
        tempd1 = -(dis4*drd)
        tempd0 = -(dis4*drwd)
        temp0 = w(i+2, j, k, irho)
        temp1 = w(i+2, j, k, ivz)
        temp2 = w(i-1, j, k, irho)
        temp3 = w(i-1, j, k, ivz)
        tempd2 = -(dis4*dred)
        dis2d = dis2d + ddw5*dred + ddw4*drwd + ddw3*drvd + ddw2*drud + &
&         ddw1*drd
        ddw5d = dis2*dred - three*tempd2
        dis4d = dis4d - (w(i+2, j, k, irhoe)-w(i-1, j, k, irhoe)-three*&
&         ddw5)*dred - (temp0*temp1-temp2*temp3-three*ddw4)*drwd
        wd(i+2, j, k, irhoe) = wd(i+2, j, k, irhoe) + tempd2
        wd(i-1, j, k, irhoe) = wd(i-1, j, k, irhoe) - tempd2
        wd(i+1, j, k, irhoe) = wd(i+1, j, k, irhoe) + ddw5d
        wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddw5d
        ddw4d = dis2*drwd - three*tempd0
        wd(i+2, j, k, irho) = wd(i+2, j, k, irho) + temp1*tempd0
        wd(i+2, j, k, ivz) = wd(i+2, j, k, ivz) + temp0*tempd0
        wd(i-1, j, k, irho) = wd(i-1, j, k, irho) - temp3*tempd0
        wd(i-1, j, k, ivz) = wd(i-1, j, k, ivz) - temp2*tempd0
        wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, ivz)*&
&         ddw4d
        wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + w(i+1, j, k, irho)*&
&         ddw4d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivz)*ddw4d
        wd(i, j, k, ivz) = wd(i, j, k, ivz) - w(i, j, k, irho)*ddw4d
        temp3 = w(i-1, j, k, ivy)
        temp2 = w(i-1, j, k, irho)
        temp1 = w(i+2, j, k, ivy)
        temp0 = w(i+2, j, k, irho)
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw3)*drvd
        tempd0 = -(dis4*drvd)
        ddw3d = dis2*drvd - three*tempd0
        wd(i+2, j, k, irho) = wd(i+2, j, k, irho) + temp1*tempd0
        wd(i+2, j, k, ivy) = wd(i+2, j, k, ivy) + temp0*tempd0
        wd(i-1, j, k, irho) = wd(i-1, j, k, irho) - temp3*tempd0
        wd(i-1, j, k, ivy) = wd(i-1, j, k, ivy) - temp2*tempd0
        wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, ivy)*&
&         ddw3d
        wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + w(i+1, j, k, irho)*&
&         ddw3d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivy)*ddw3d
        wd(i, j, k, ivy) = wd(i, j, k, ivy) - w(i, j, k, irho)*ddw3d
        temp1 = w(i-1, j, k, ivx)
        temp0 = w(i-1, j, k, irho)
        temp = w(i+2, j, k, ivx)
        temp2 = w(i+2, j, k, irho)
        dis4d = dis4d - (temp2*temp-temp0*temp1-three*ddw2)*drud - (w(i+&
&         2, j, k, irho)-w(i-1, j, k, irho)-three*ddw1)*drd
        tempd2 = -(dis4*drud)
        ddw2d = dis2*drud - three*tempd2
        wd(i+2, j, k, irho) = wd(i+2, j, k, irho) + temp*tempd2
        wd(i+2, j, k, ivx) = wd(i+2, j, k, ivx) + temp2*tempd2
        wd(i-1, j, k, irho) = wd(i-1, j, k, irho) - temp1*tempd2
        wd(i-1, j, k, ivx) = wd(i-1, j, k, ivx) - temp0*tempd2
        wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, ivx)*&
&         ddw2d
        wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + w(i+1, j, k, irho)*&
&         ddw2d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivx)*ddw2d
        wd(i, j, k, ivx) = wd(i, j, k, ivx) - w(i, j, k, irho)*ddw2d
        ddw1d = dis2*drd - three*tempd1
        wd(i+2, j, k, irho) = wd(i+2, j, k, irho) + tempd1
        wd(i-1, j, k, irho) = wd(i-1, j, k, irho) - tempd1
        wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + ddw1d
        wd(i, j, k, irho) = wd(i, j, k, irho) - ddw1d
        call mydim_fast_b(arg1, arg1d, dis2, dis2d, dis4d)
        min1d = ppor*fis2*dis2d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          y1d = min1d
        else
          y1d = 0.0_8
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          dssd(i+1, j, k, 1) = dssd(i+1, j, k, 1) + y1d
        else
          dssd(i, j, k, 1) = dssd(i, j, k, 1) + y1d
        end if
      end do
!$bwd-of ii-loop 
      do ii=0,ie*je*ke-1
        i = mod(ii, ie) + 1
        j = mod(ii/ie, je) + 1
        k = ii/(ie*je) + 1
        if (p(i+1, j, k) - p(i, j, k) .ge. 0.) then
          abs1 = p(i+1, j, k) - p(i, j, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        else
          abs1 = -(p(i+1, j, k)-p(i, j, k))
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        end if
        if (p(i, j, k) - p(i-1, j, k) .ge. 0.) then
          abs4 = p(i, j, k) - p(i-1, j, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          abs4 = -(p(i, j, k)-p(i-1, j, k))
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        x1 = (p(i+1, j, k)-two*p(i, j, k)+p(i-1, j, k))/(omega*(p(i+1, j&
&         , k)+two*p(i, j, k)+p(i-1, j, k))+oneminomega*(abs1+abs4)+plim&
&         )
        if (x1 .ge. 0.) then
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (p(i, j+1, k) - p(i, j, k) .ge. 0.) then
          abs2 = p(i, j+1, k) - p(i, j, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        else
          abs2 = -(p(i, j+1, k)-p(i, j, k))
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        end if
        if (p(i, j, k) - p(i, j-1, k) .ge. 0.) then
          abs5 = p(i, j, k) - p(i, j-1, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          abs5 = -(p(i, j, k)-p(i, j-1, k))
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        x2 = (p(i, j+1, k)-two*p(i, j, k)+p(i, j-1, k))/(omega*(p(i, j+1&
&         , k)+two*p(i, j, k)+p(i, j-1, k))+oneminomega*(abs2+abs5)+plim&
&         )
        if (x2 .ge. 0.) then
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (p(i, j, k+1) - p(i, j, k) .ge. 0.) then
          abs3 = p(i, j, k+1) - p(i, j, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        else
          abs3 = -(p(i, j, k+1)-p(i, j, k))
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        end if
        if (p(i, j, k) - p(i, j, k-1) .ge. 0.) then
          abs6 = p(i, j, k) - p(i, j, k-1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          abs6 = -(p(i, j, k)-p(i, j, k-1))
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        x3 = (p(i, j, k+1)-two*p(i, j, k)+p(i, j, k-1))/(omega*(p(i, j, &
&         k+1)+two*p(i, j, k)+p(i, j, k-1))+oneminomega*(abs3+abs6)+plim&
&         )
        if (x3 .ge. 0.) then
          x3d = dssd(i, j, k, 3)
          dssd(i, j, k, 3) = 0.0_8
        else
          x3d = -dssd(i, j, k, 3)
          dssd(i, j, k, 3) = 0.0_8
        end if
        temp1 = plim + omega*(p(i, j, k+1)+two*p(i, j, k)+p(i, j, k-1)) &
&         + oneminomega*(abs3+abs6)
        tempd = x3d/temp1
        tempd1 = -((p(i, j, k+1)-two*p(i, j, k)+p(i, j, k-1))*tempd/&
&         temp1)
        tempd0 = omega*tempd1
        pd(i, j, k+1) = pd(i, j, k+1) + tempd + tempd0
        pd(i, j, k) = pd(i, j, k) + two*tempd0 - two*tempd
        pd(i, j, k-1) = pd(i, j, k-1) + tempd + tempd0
        abs3d = oneminomega*tempd1
        abs6d = oneminomega*tempd1
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          pd(i, j, k) = pd(i, j, k) + abs6d
          pd(i, j, k-1) = pd(i, j, k-1) - abs6d
        else
          pd(i, j, k-1) = pd(i, j, k-1) + abs6d
          pd(i, j, k) = pd(i, j, k) - abs6d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          pd(i, j, k) = pd(i, j, k) + abs3d
          pd(i, j, k+1) = pd(i, j, k+1) - abs3d
        else
          pd(i, j, k+1) = pd(i, j, k+1) + abs3d
          pd(i, j, k) = pd(i, j, k) - abs3d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          x2d = dssd(i, j, k, 2)
          dssd(i, j, k, 2) = 0.0_8
        else
          x2d = -dssd(i, j, k, 2)
          dssd(i, j, k, 2) = 0.0_8
        end if
        temp1 = plim + omega*(p(i, j+1, k)+two*p(i, j, k)+p(i, j-1, k)) &
&         + oneminomega*(abs2+abs5)
        tempd = x2d/temp1
        tempd1 = -((p(i, j+1, k)-two*p(i, j, k)+p(i, j-1, k))*tempd/&
&         temp1)
        tempd0 = omega*tempd1
        pd(i, j+1, k) = pd(i, j+1, k) + tempd + tempd0
        pd(i, j, k) = pd(i, j, k) + two*tempd0 - two*tempd
        pd(i, j-1, k) = pd(i, j-1, k) + tempd + tempd0
        abs2d = oneminomega*tempd1
        abs5d = oneminomega*tempd1
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          pd(i, j, k) = pd(i, j, k) + abs5d
          pd(i, j-1, k) = pd(i, j-1, k) - abs5d
        else
          pd(i, j-1, k) = pd(i, j-1, k) + abs5d
          pd(i, j, k) = pd(i, j, k) - abs5d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          pd(i, j, k) = pd(i, j, k) + abs2d
          pd(i, j+1, k) = pd(i, j+1, k) - abs2d
        else
          pd(i, j+1, k) = pd(i, j+1, k) + abs2d
          pd(i, j, k) = pd(i, j, k) - abs2d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          x1d = dssd(i, j, k, 1)
          dssd(i, j, k, 1) = 0.0_8
        else
          x1d = -dssd(i, j, k, 1)
          dssd(i, j, k, 1) = 0.0_8
        end if
        temp = plim + omega*(p(i+1, j, k)+two*p(i, j, k)+p(i-1, j, k)) +&
&         oneminomega*(abs1+abs4)
        tempd = x1d/temp
        tempd0 = -((p(i+1, j, k)-two*p(i, j, k)+p(i-1, j, k))*tempd/temp&
&         )
        tempd1 = omega*tempd0
        pd(i+1, j, k) = pd(i+1, j, k) + tempd + tempd1
        pd(i, j, k) = pd(i, j, k) + two*tempd1 - two*tempd
        pd(i-1, j, k) = pd(i-1, j, k) + tempd + tempd1
        abs1d = oneminomega*tempd0
        abs4d = oneminomega*tempd0
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          pd(i, j, k) = pd(i, j, k) + abs4d
          pd(i-1, j, k) = pd(i-1, j, k) - abs4d
        else
          pd(i-1, j, k) = pd(i-1, j, k) + abs4d
          pd(i, j, k) = pd(i, j, k) - abs4d
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          pd(i, j, k) = pd(i, j, k) + abs1d
          pd(i+1, j, k) = pd(i+1, j, k) - abs1d
        else
          pd(i+1, j, k) = pd(i+1, j, k) + abs1d
          pd(i, j, k) = pd(i, j, k) - abs1d
        end if
      end do
      fwd = sfil*fwd
    end if
  end subroutine invisciddissfluxmatrix_fast_b
 
  subroutine invisciddissfluxmatrix()
!
!       invisciddissfluxmatrix computes the matrix artificial
!       dissipation term. instead of the spectral radius, as used in
!       the scalar dissipation scheme, the absolute value of the flux
!       jacobian is used. this leads to a less diffusive and
!       consequently more accurate scheme. it is assumed that the
!       pointers in blockpointers already point to the correct block.
!
    use constants
    use blockpointers, only : nx, ny, nz, il, jl, kl, ie, je, ke,&
&   ib, jb, kb, w, p, pori, porj, pork, fw, gamma, si, sj, sk, &
&   indfamilyi, indfamilyj, indfamilyk, spectralsol, addgridvelocities, &
&   sfacei, sfacej, sfacek, factfamilyi, factfamilyj, factfamilyk
    use flowvarrefstate, only : pinfcorr
    use inputdiscretization, only : vis2, vis4
    use inputphysics, only : equations
    use iteration, only : rfil
    use cgnsgrid, only : massflowfamilydiss
    use utils_fast_b, only : getcorrectfork, mydim
    implicit none
!
!      local parameters.
!
    real(kind=realtype), parameter :: dpmax=0.25_realtype
    real(kind=realtype), parameter :: epsacoustic=0.25_realtype
    real(kind=realtype), parameter :: epsshear=0.025_realtype
    real(kind=realtype), parameter :: omega=0.5_realtype
    real(kind=realtype), parameter :: oneminomega=one-omega
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k, ind, ii
    real(kind=realtype) :: plim, sface
    real(kind=realtype) :: sfil, fis2, fis4
    real(kind=realtype) :: gammaavg, gm1, ovgm1, gm53
    real(kind=realtype) :: ppor, rrad, dis2, dis4
    real(kind=realtype) :: dp1, dp2, tmp, fs
    real(kind=realtype) :: ddw1, ddw2, ddw3, ddw4, ddw5, ddw6
    real(kind=realtype) :: dr, dru, drv, drw, dre, drk, sx, sy, sz
    real(kind=realtype) :: uavg, vavg, wavg, a2avg, aavg, havg
    real(kind=realtype) :: alphaavg, unavg, ovaavg, ova2avg
    real(kind=realtype) :: kavg, lam1, lam2, lam3, area
    real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
    real(kind=realtype), dimension(ie, je, ke, 3) :: dss
    logical :: correctfork
    intrinsic abs
    intrinsic mod
    intrinsic max
    intrinsic min
    intrinsic sqrt
    real(kind=realtype) :: x1
    real(kind=realtype) :: x2
    real(kind=realtype) :: x3
    real(kind=realtype) :: y1
    real(kind=realtype) :: y2
    real(kind=realtype) :: y3
    real(kind=realtype) :: abs0
    real(kind=realtype) :: min1
    real(realtype) :: max1
    real(kind=realtype) :: max2
    real(kind=realtype) :: max3
    real(kind=realtype) :: max4
    real(kind=realtype) :: min2
    real(realtype) :: max5
    real(kind=realtype) :: max6
    real(kind=realtype) :: max7
    real(kind=realtype) :: max8
    real(kind=realtype) :: min3
    real(realtype) :: max9
    real(kind=realtype) :: max10
    real(kind=realtype) :: max11
    real(kind=realtype) :: max12
    real(kind=realtype) :: abs1
    real(kind=realtype) :: abs2
    real(kind=realtype) :: abs3
    real(kind=realtype) :: abs4
    real(kind=realtype) :: abs5
    real(kind=realtype) :: abs6
    real(kind=realtype) :: arg1
    if (rfil .ge. 0.) then
      abs0 = rfil
    else
      abs0 = -rfil
    end if
! check if rfil == 0. if so, the dissipative flux needs not to
! be computed.
    if (abs0 .lt. thresholdreal) then
      return
    else
! set the value of plim. to be fully consistent this must have
! the dimension of a pressure. therefore a fraction of pinfcorr
! is used.
      plim = 0.001_realtype*pinfcorr
! determine whether or not the total energy must be corrected
! for the presence of the turbulent kinetic energy.
      correctfork = getcorrectfork()
! initialize sface to zero. this value will be used if the
! block is not moving.
      sface = zero
! set a couple of constants for the scheme.
      fis2 = rfil*vis2
      fis4 = rfil*vis4
      sfil = one - rfil
! initialize the dissipative residual to a certain times,
! possibly zero, the previously stored value.
      fw = sfil*fw
!$ad ii-loop
! compute the pressure sensor for each cell, in each direction:
      do ii=0,ie*je*ke-1
        i = mod(ii, ie) + 1
        j = mod(ii/ie, je) + 1
        k = ii/(ie*je) + 1
        if (p(i+1, j, k) - p(i, j, k) .ge. 0.) then
          abs1 = p(i+1, j, k) - p(i, j, k)
        else
          abs1 = -(p(i+1, j, k)-p(i, j, k))
        end if
        if (p(i, j, k) - p(i-1, j, k) .ge. 0.) then
          abs4 = p(i, j, k) - p(i-1, j, k)
        else
          abs4 = -(p(i, j, k)-p(i-1, j, k))
        end if
        x1 = (p(i+1, j, k)-two*p(i, j, k)+p(i-1, j, k))/(omega*(p(i+1, j&
&         , k)+two*p(i, j, k)+p(i-1, j, k))+oneminomega*(abs1+abs4)+plim&
&         )
        if (x1 .ge. 0.) then
          dss(i, j, k, 1) = x1
        else
          dss(i, j, k, 1) = -x1
        end if
        if (p(i, j+1, k) - p(i, j, k) .ge. 0.) then
          abs2 = p(i, j+1, k) - p(i, j, k)
        else
          abs2 = -(p(i, j+1, k)-p(i, j, k))
        end if
        if (p(i, j, k) - p(i, j-1, k) .ge. 0.) then
          abs5 = p(i, j, k) - p(i, j-1, k)
        else
          abs5 = -(p(i, j, k)-p(i, j-1, k))
        end if
        x2 = (p(i, j+1, k)-two*p(i, j, k)+p(i, j-1, k))/(omega*(p(i, j+1&
&         , k)+two*p(i, j, k)+p(i, j-1, k))+oneminomega*(abs2+abs5)+plim&
&         )
        if (x2 .ge. 0.) then
          dss(i, j, k, 2) = x2
        else
          dss(i, j, k, 2) = -x2
        end if
        if (p(i, j, k+1) - p(i, j, k) .ge. 0.) then
          abs3 = p(i, j, k+1) - p(i, j, k)
        else
          abs3 = -(p(i, j, k+1)-p(i, j, k))
        end if
        if (p(i, j, k) - p(i, j, k-1) .ge. 0.) then
          abs6 = p(i, j, k) - p(i, j, k-1)
        else
          abs6 = -(p(i, j, k)-p(i, j, k-1))
        end if
        x3 = (p(i, j, k+1)-two*p(i, j, k)+p(i, j, k-1))/(omega*(p(i, j, &
&         k+1)+two*p(i, j, k)+p(i, j, k-1))+oneminomega*(abs3+abs6)+plim&
&         )
        if (x3 .ge. 0.) then
          dss(i, j, k, 3) = x3
        else
          dss(i, j, k, 3) = -x3
        end if
      end do
!$ad ii-loop
!
!       dissipative fluxes in the i-direction.
!
      do ii=0,il*ny*nz-1
        i = mod(ii, il) + 1
        j = mod(ii/il, ny) + 2
        k = ii/(il*ny) + 2
! compute the dissipation coefficients for this face.
        ppor = zero
        if (pori(i, j, k) .eq. normalflux) ppor = one
        if (dss(i, j, k, 1) .lt. dss(i+1, j, k, 1)) then
          y1 = dss(i+1, j, k, 1)
        else
          y1 = dss(i, j, k, 1)
        end if
        if (dpmax .gt. y1) then
          min1 = y1
        else
          min1 = dpmax
        end if
        dis2 = ppor*fis2*min1
        arg1 = ppor*fis4
        dis4 = mydim(arg1, dis2)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
        ddw1 = w(i+1, j, k, irho) - w(i, j, k, irho)
        dr = dis2*ddw1 - dis4*(w(i+2, j, k, irho)-w(i-1, j, k, irho)-&
&         three*ddw1)
        ddw2 = w(i+1, j, k, irho)*w(i+1, j, k, ivx) - w(i, j, k, irho)*w&
&         (i, j, k, ivx)
        dru = dis2*ddw2 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, ivx)-w(i&
&         -1, j, k, irho)*w(i-1, j, k, ivx)-three*ddw2)
        ddw3 = w(i+1, j, k, irho)*w(i+1, j, k, ivy) - w(i, j, k, irho)*w&
&         (i, j, k, ivy)
        drv = dis2*ddw3 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, ivy)-w(i&
&         -1, j, k, irho)*w(i-1, j, k, ivy)-three*ddw3)
        ddw4 = w(i+1, j, k, irho)*w(i+1, j, k, ivz) - w(i, j, k, irho)*w&
&         (i, j, k, ivz)
        drw = dis2*ddw4 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, ivz)-w(i&
&         -1, j, k, irho)*w(i-1, j, k, ivz)-three*ddw4)
        ddw5 = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
        dre = dis2*ddw5 - dis4*(w(i+2, j, k, irhoe)-w(i-1, j, k, irhoe)-&
&         three*ddw5)
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
        if (correctfork) then
          ddw6 = w(i+1, j, k, irho)*w(i+1, j, k, itu1) - w(i, j, k, irho&
&           )*w(i, j, k, itu1)
          drk = dis2*ddw6 - dis4*(w(i+2, j, k, irho)*w(i+2, j, k, itu1)-&
&           w(i-1, j, k, irho)*w(i-1, j, k, itu1)-three*ddw6)
          kavg = half*(w(i, j, k, itu1)+w(i+1, j, k, itu1))
        else
          drk = zero
          kavg = zero
        end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
        gammaavg = half*(gamma(i+1, j, k)+gamma(i, j, k))
        gm1 = gammaavg - one
        ovgm1 = one/gm1
        gm53 = gammaavg - five*third
! compute the average state at the interface.
        uavg = half*(w(i+1, j, k, ivx)+w(i, j, k, ivx))
        vavg = half*(w(i+1, j, k, ivy)+w(i, j, k, ivy))
        wavg = half*(w(i+1, j, k, ivz)+w(i, j, k, ivz))
        a2avg = half*(gamma(i+1, j, k)*p(i+1, j, k)/w(i+1, j, k, irho)+&
&         gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
        area = sqrt(si(i, j, k, 1)**2 + si(i, j, k, 2)**2 + si(i, j, k, &
&         3)**2)
        if (1.e-25_realtype .lt. area) then
          max1 = area
        else
          max1 = 1.e-25_realtype
        end if
        tmp = one/max1
        sx = si(i, j, k, 1)*tmp
        sy = si(i, j, k, 2)*tmp
        sz = si(i, j, k, 3)*tmp
        alphaavg = half*(uavg**2+vavg**2+wavg**2)
        havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
        aavg = sqrt(a2avg)
        unavg = uavg*sx + vavg*sy + wavg*sz
        ovaavg = one/aavg
        ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
        if (addgridvelocities) sface = sfacei(i, j, k)*tmp
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
        else
          lam1 = -(unavg-sface+aavg)
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
        else
          lam2 = -(unavg-sface-aavg)
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
        else
          lam3 = -(unavg-sface)
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max2 = epsacoustic*rrad
        else
          max2 = lam1
        end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
        lam1 = max2*area
        if (lam2 .lt. epsacoustic*rrad) then
          max3 = epsacoustic*rrad
        else
          max3 = lam2
        end if
        lam2 = max3*area
        if (lam3 .lt. epsshear*rrad) then
          max4 = epsshear*rrad
        else
          max4 = lam3
        end if
        lam3 = max4*area
! some abbreviations, which occur quite often in the
! dissipation terms.
        abv1 = half*(lam1+lam2)
        abv2 = half*(lam1-lam2)
        abv3 = abv1 - lam3
        abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53*&
&         drk
        abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
        abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
        abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
        fs = lam3*dr + abv6
        fw(i+1, j, k, irho) = fw(i+1, j, k, irho) + fs
        fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
        fs = lam3*dru + uavg*abv6 + sx*abv7
        fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fs
        fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
        fs = lam3*drv + vavg*abv6 + sy*abv7
        fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fs
        fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
        fs = lam3*drw + wavg*abv6 + sz*abv7
        fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fs
        fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
        fs = lam3*dre + havg*abv6 + unavg*abv7
        fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + fs
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
      end do
!$ad ii-loop
!
!       dissipative fluxes in the j-direction.
!
      do ii=0,nx*jl*nz-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, jl) + 1
        k = ii/(nx*jl) + 2
! compute the dissipation coefficients for this face.
        ppor = zero
        if (porj(i, j, k) .eq. normalflux) ppor = one
        if (dss(i, j, k, 2) .lt. dss(i, j+1, k, 2)) then
          y2 = dss(i, j+1, k, 2)
        else
          y2 = dss(i, j, k, 2)
        end if
        if (dpmax .gt. y2) then
          min2 = y2
        else
          min2 = dpmax
        end if
        dis2 = ppor*fis2*min2
        arg1 = ppor*fis4
        dis4 = mydim(arg1, dis2)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
        ddw1 = w(i, j+1, k, irho) - w(i, j, k, irho)
        dr = dis2*ddw1 - dis4*(w(i, j+2, k, irho)-w(i, j-1, k, irho)-&
&         three*ddw1)
        ddw2 = w(i, j+1, k, irho)*w(i, j+1, k, ivx) - w(i, j, k, irho)*w&
&         (i, j, k, ivx)
        dru = dis2*ddw2 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, ivx)-w(i&
&         , j-1, k, irho)*w(i, j-1, k, ivx)-three*ddw2)
        ddw3 = w(i, j+1, k, irho)*w(i, j+1, k, ivy) - w(i, j, k, irho)*w&
&         (i, j, k, ivy)
        drv = dis2*ddw3 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, ivy)-w(i&
&         , j-1, k, irho)*w(i, j-1, k, ivy)-three*ddw3)
        ddw4 = w(i, j+1, k, irho)*w(i, j+1, k, ivz) - w(i, j, k, irho)*w&
&         (i, j, k, ivz)
        drw = dis2*ddw4 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, ivz)-w(i&
&         , j-1, k, irho)*w(i, j-1, k, ivz)-three*ddw4)
        ddw5 = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
        dre = dis2*ddw5 - dis4*(w(i, j+2, k, irhoe)-w(i, j-1, k, irhoe)-&
&         three*ddw5)
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
        if (correctfork) then
          ddw6 = w(i, j+1, k, irho)*w(i, j+1, k, itu1) - w(i, j, k, irho&
&           )*w(i, j, k, itu1)
          drk = dis2*ddw6 - dis4*(w(i, j+2, k, irho)*w(i, j+2, k, itu1)-&
&           w(i, j-1, k, irho)*w(i, j-1, k, itu1)-three*ddw6)
          kavg = half*(w(i, j, k, itu1)+w(i, j+1, k, itu1))
        else
          drk = zero
          kavg = zero
        end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
        gammaavg = half*(gamma(i, j+1, k)+gamma(i, j, k))
        gm1 = gammaavg - one
        ovgm1 = one/gm1
        gm53 = gammaavg - five*third
! compute the average state at the interface.
        uavg = half*(w(i, j+1, k, ivx)+w(i, j, k, ivx))
        vavg = half*(w(i, j+1, k, ivy)+w(i, j, k, ivy))
        wavg = half*(w(i, j+1, k, ivz)+w(i, j, k, ivz))
        a2avg = half*(gamma(i, j+1, k)*p(i, j+1, k)/w(i, j+1, k, irho)+&
&         gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
        area = sqrt(sj(i, j, k, 1)**2 + sj(i, j, k, 2)**2 + sj(i, j, k, &
&         3)**2)
        if (1.e-25_realtype .lt. area) then
          max5 = area
        else
          max5 = 1.e-25_realtype
        end if
        tmp = one/max5
        sx = sj(i, j, k, 1)*tmp
        sy = sj(i, j, k, 2)*tmp
        sz = sj(i, j, k, 3)*tmp
        alphaavg = half*(uavg**2+vavg**2+wavg**2)
        havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
        aavg = sqrt(a2avg)
        unavg = uavg*sx + vavg*sy + wavg*sz
        ovaavg = one/aavg
        ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
        if (addgridvelocities) sface = sfacej(i, j, k)*tmp
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
        else
          lam1 = -(unavg-sface+aavg)
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
        else
          lam2 = -(unavg-sface-aavg)
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
        else
          lam3 = -(unavg-sface)
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max6 = epsacoustic*rrad
        else
          max6 = lam1
        end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
        lam1 = max6*area
        if (lam2 .lt. epsacoustic*rrad) then
          max7 = epsacoustic*rrad
        else
          max7 = lam2
        end if
        lam2 = max7*area
        if (lam3 .lt. epsshear*rrad) then
          max8 = epsshear*rrad
        else
          max8 = lam3
        end if
        lam3 = max8*area
! some abbreviations, which occur quite often in the
! dissipation terms.
        abv1 = half*(lam1+lam2)
        abv2 = half*(lam1-lam2)
        abv3 = abv1 - lam3
        abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53*&
&         drk
        abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
        abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
        abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
        fs = lam3*dr + abv6
        fw(i, j+1, k, irho) = fw(i, j+1, k, irho) + fs
        fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
        fs = lam3*dru + uavg*abv6 + sx*abv7
        fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fs
        fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
        fs = lam3*drv + vavg*abv6 + sy*abv7
        fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fs
        fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
        fs = lam3*drw + wavg*abv6 + sz*abv7
        fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fs
        fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
        fs = lam3*dre + havg*abv6 + unavg*abv7
        fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + fs
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
      end do
!$ad ii-loop
!
!       dissipative fluxes in the k-direction.
!
      do ii=0,nx*ny*kl-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, ny) + 2
        k = ii/(nx*ny) + 1
! compute the dissipation coefficients for this face.
        ppor = zero
        if (pork(i, j, k) .eq. normalflux) ppor = one
        if (dss(i, j, k, 3) .lt. dss(i, j, k+1, 3)) then
          y3 = dss(i, j, k+1, 3)
        else
          y3 = dss(i, j, k, 3)
        end if
        if (dpmax .gt. y3) then
          min3 = y3
        else
          min3 = dpmax
        end if
        dis2 = ppor*fis2*min3
        arg1 = ppor*fis4
        dis4 = mydim(arg1, dis2)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
        ddw1 = w(i, j, k+1, irho) - w(i, j, k, irho)
        dr = dis2*ddw1 - dis4*(w(i, j, k+2, irho)-w(i, j, k-1, irho)-&
&         three*ddw1)
        ddw2 = w(i, j, k+1, irho)*w(i, j, k+1, ivx) - w(i, j, k, irho)*w&
&         (i, j, k, ivx)
        dru = dis2*ddw2 - dis4*(w(i, j, k+2, irho)*w(i, j, k+2, ivx)-w(i&
&         , j, k-1, irho)*w(i, j, k-1, ivx)-three*ddw2)
        ddw3 = w(i, j, k+1, irho)*w(i, j, k+1, ivy) - w(i, j, k, irho)*w&
&         (i, j, k, ivy)
        drv = dis2*ddw3 - dis4*(w(i, j, k+2, irho)*w(i, j, k+2, ivy)-w(i&
&         , j, k-1, irho)*w(i, j, k-1, ivy)-three*ddw3)
        ddw4 = w(i, j, k+1, irho)*w(i, j, k+1, ivz) - w(i, j, k, irho)*w&
&         (i, j, k, ivz)
        drw = dis2*ddw4 - dis4*(w(i, j, k+2, irho)*w(i, j, k+2, ivz)-w(i&
&         , j, k-1, irho)*w(i, j, k-1, ivz)-three*ddw4)
        ddw5 = w(i, j, k+1, irhoe) - w(i, j, k, irhoe)
        dre = dis2*ddw5 - dis4*(w(i, j, k+2, irhoe)-w(i, j, k-1, irhoe)-&
&         three*ddw5)
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
        if (correctfork) then
          ddw6 = w(i, j, k+1, irho)*w(i, j, k+1, itu1) - w(i, j, k, irho&
&           )*w(i, j, k, itu1)
          drk = dis2*ddw6 - dis4*(w(i, j, k+2, irho)*w(i, j, k+2, itu1)-&
&           w(i, j, k-1, irho)*w(i, j, k-1, itu1)-three*ddw6)
          kavg = half*(w(i, j, k+1, itu1)+w(i, j, k, itu1))
        else
          drk = zero
          kavg = zero
        end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
        gammaavg = half*(gamma(i, j, k+1)+gamma(i, j, k))
        gm1 = gammaavg - one
        ovgm1 = one/gm1
        gm53 = gammaavg - five*third
! compute the average state at the interface.
        uavg = half*(w(i, j, k+1, ivx)+w(i, j, k, ivx))
        vavg = half*(w(i, j, k+1, ivy)+w(i, j, k, ivy))
        wavg = half*(w(i, j, k+1, ivz)+w(i, j, k, ivz))
        a2avg = half*(gamma(i, j, k+1)*p(i, j, k+1)/w(i, j, k+1, irho)+&
&         gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
        area = sqrt(sk(i, j, k, 1)**2 + sk(i, j, k, 2)**2 + sk(i, j, k, &
&         3)**2)
        if (1.e-25_realtype .lt. area) then
          max9 = area
        else
          max9 = 1.e-25_realtype
        end if
        tmp = one/max9
        sx = sk(i, j, k, 1)*tmp
        sy = sk(i, j, k, 2)*tmp
        sz = sk(i, j, k, 3)*tmp
        alphaavg = half*(uavg**2+vavg**2+wavg**2)
        havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
        aavg = sqrt(a2avg)
        unavg = uavg*sx + vavg*sy + wavg*sz
        ovaavg = one/aavg
        ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
        if (addgridvelocities) sface = sfacek(i, j, k)*tmp
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
        else
          lam1 = -(unavg-sface+aavg)
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
        else
          lam2 = -(unavg-sface-aavg)
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
        else
          lam3 = -(unavg-sface)
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max10 = epsacoustic*rrad
        else
          max10 = lam1
        end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
        lam1 = max10*area
        if (lam2 .lt. epsacoustic*rrad) then
          max11 = epsacoustic*rrad
        else
          max11 = lam2
        end if
        lam2 = max11*area
        if (lam3 .lt. epsshear*rrad) then
          max12 = epsshear*rrad
        else
          max12 = lam3
        end if
        lam3 = max12*area
! some abbreviations, which occur quite often in the
! dissipation terms.
        abv1 = half*(lam1+lam2)
        abv2 = half*(lam1-lam2)
        abv3 = abv1 - lam3
        abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53*&
&         drk
        abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
        abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
        abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
        fs = lam3*dr + abv6
        fw(i, j, k+1, irho) = fw(i, j, k+1, irho) + fs
        fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
        fs = lam3*dru + uavg*abv6 + sx*abv7
        fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fs
        fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
        fs = lam3*drv + vavg*abv6 + sy*abv7
        fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fs
        fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
        fs = lam3*drw + wavg*abv6 + sz*abv7
        fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fs
        fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
        fs = lam3*dre + havg*abv6 + unavg*abv7
        fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + fs
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
      end do
    end if
  end subroutine invisciddissfluxmatrix
 
!  differentiation of invisciddissfluxscalar in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: *p *w *fw
!   with respect to varying inputs: *p *w *fw *radi *radj *radk
!   rw status of diff variables: *p:incr *w:incr *fw:in-out *radi:out
!                *radj:out *radk:out
!   plus diff mem management of: p:in w:in fw:in radi:in radj:in
!                radk:in
  subroutine invisciddissfluxscalar_fast_b()
!
!       invisciddissfluxscalar computes the scalar artificial
!       dissipation, see aiaa paper 81-1259, for a given block.
!       therefore it is assumed that the pointers in  blockpointers
!       already point to the correct block.
!
    use constants
    use blockpointers, only : nx, ny, nz, il, jl, kl, ie, je, ke,&
&   ib, jb, kb, w, wd, p, pd, pori, porj, pork, fw, fwd, radi, radid, &
&   radj, radjd, radk, radkd, gamma
    use flowvarrefstate, only : gammainf, pinfcorr, rhoinf
    use inputdiscretization, only : vis2, vis4
    use inputiteration, only : usedisscontinuation, disscontmagnitude, &
&   disscontmidpoint, disscontsharpness
    use inputphysics, only : equations
    use iteration, only : rfil, totalr0, totalr
    use utils_fast_b, only : mydim, mydim_fast_b
    implicit none
!
!      local parameter.
!
    real(kind=realtype), parameter :: dssmax=0.25_realtype
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k, ind, ii
    real(kind=realtype) :: sslim, rhoi
    real(kind=realtype) :: sfil, fis2, fis4
    real(kind=realtype) :: ppor, rrad, dis2, dis4
    real(kind=realtype) :: rradd, dis2d, dis4d
    real(kind=realtype) :: ddw1, ddw2, ddw3, ddw4, ddw5, fs
    real(kind=realtype) :: ddw1d, ddw2d, ddw3d, ddw4d, ddw5d, fsd
    real(kind=realtype), dimension(ie, je, ke, 3) :: dss
    real(kind=realtype), dimension(ie, je, ke, 3) :: dssd
    real(kind=realtype), dimension(0:ib, 0:jb, 0:kb) :: ss
    real(kind=realtype), dimension(0:ib, 0:jb, 0:kb) :: ssd
    intrinsic abs
    intrinsic mod
    intrinsic exp
    intrinsic log10
    intrinsic max
    intrinsic min
    real(kind=realtype) :: x1
    real(kind=realtype) :: x1d
    real(kind=realtype) :: x2
    real(kind=realtype) :: x2d
    real(kind=realtype) :: x3
    real(kind=realtype) :: x3d
    real(kind=realtype) :: y1
    real(kind=realtype) :: y1d
    real(kind=realtype) :: y2
    real(kind=realtype) :: y2d
    real(kind=realtype) :: y3
    real(kind=realtype) :: y3d
    real(kind=realtype) :: abs0
    real(kind=realtype) :: min1
    real(kind=realtype) :: min1d
    real(kind=realtype) :: min2
    real(kind=realtype) :: min2d
    real(kind=realtype) :: min3
    real(kind=realtype) :: min3d
    real(kind=realtype) :: arg1
    real(kind=realtype) :: arg1d
    real(kind=realtype) :: temp
    real(kind=realtype) :: temp0
    real(kind=realtype) :: temp1
    real(kind=realtype) :: tempd
    real(kind=realtype) :: tempd0
    integer :: branch
    real(kind=realtype) :: temp2
    real(kind=realtype) :: temp3
    real(kind=realtype) :: tempd1
    real(kind=realtype) :: tempd2
    if (rfil .ge. 0.) then
      abs0 = rfil
    else
      abs0 = -rfil
    end if
! check if rfil == 0. if so, the dissipative flux needs not to
! be computed.
    if (abs0 .lt. thresholdreal) then
      if (associated(radid)) radid = 0.0_8
      if (associated(radjd)) radjd = 0.0_8
      if (associated(radkd)) radkd = 0.0_8
    else
! determine the variables used to compute the switch.
! for the inviscid case this is the pressure; for the viscous
! case it is the entropy.
      select case  (equations) 
      case (eulerequations) 
! inviscid case. pressure switch is based on the pressure.
! also set the value of sslim. to be fully consistent this
! must have the dimension of pressure and it is therefore
! set to a fraction of the free stream value.
        sslim = 0.001_realtype*pinfcorr
! copy the pressure in ss. only need the entries used in the
! discretization, i.e. not including the corner halo's, but we'll
! just copy all anyway.
        ss = p
!===============================================================
        call pushcontrol2b(1)
      case (nsequations, ransequations) 
! viscous case. pressure switch is based on the entropy.
! also set the value of sslim. to be fully consistent this
! must have the dimension of entropy and it is therefore
! set to a fraction of the free stream value.
        sslim = 0.001_realtype*pinfcorr/rhoinf**gammainf
!$fwd-of ii-loop 
! store the entropy in ss. see above.
        do ii=0,(ib+1)*(jb+1)*(kb+1)-1
          i = mod(ii, ib + 1)
          j = mod(ii/(ib+1), jb + 1)
          k = ii/((ib+1)*(jb+1))
          ss(i, j, k) = p(i, j, k)/w(i, j, k, irho)**gamma(i, j, k)
        end do
        call pushcontrol2b(2)
      case default
        call pushcontrol2b(0)
      end select
!$fwd-of ii-loop 
! compute the pressure sensor for each cell, in each direction:
      do ii=0,ie*je*ke-1
        i = mod(ii, ie) + 1
        j = mod(ii/ie, je) + 1
        k = ii/(ie*je) + 1
        x1 = (ss(i+1, j, k)-two*ss(i, j, k)+ss(i-1, j, k))/(ss(i+1, j, k&
&         )+two*ss(i, j, k)+ss(i-1, j, k)+sslim)
        if (x1 .ge. 0.) then
          dss(i, j, k, 1) = x1
        else
          dss(i, j, k, 1) = -x1
        end if
        x2 = (ss(i, j+1, k)-two*ss(i, j, k)+ss(i, j-1, k))/(ss(i, j+1, k&
&         )+two*ss(i, j, k)+ss(i, j-1, k)+sslim)
        if (x2 .ge. 0.) then
          dss(i, j, k, 2) = x2
        else
          dss(i, j, k, 2) = -x2
        end if
        x3 = (ss(i, j, k+1)-two*ss(i, j, k)+ss(i, j, k-1))/(ss(i, j, k+1&
&         )+two*ss(i, j, k)+ss(i, j, k-1)+sslim)
        if (x3 .ge. 0.) then
          dss(i, j, k, 3) = x3
        else
          dss(i, j, k, 3) = -x3
        end if
      end do
! set the dissipation constants for the scheme.
! rfil and sfil are fractions used by the runge-kutta solver to compute residuals at intermediate steps.
! this means that fis2 and fis4 will be some fraction of vis2 and vis4, respectively.
! for other solvers, rfil==1, sfil==0, fis2==vis2, and fis4==vis4.
! the sigmoid function used for dissipation-based continuation is described in eq. 28 and eq. 29 from the paper:
! "improving the performance of a compressible rans solver for low and high mach number flows" (seraj2022c).
! the options documentation also has information on the parameters in this formulation.
      if (usedisscontinuation) then
        if (totalr .eq. zero .or. totalr0 .eq. zero) then
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          fis2 = rfil*(vis2+disscontmagnitude/(1+exp(-(disscontsharpness&
&           *disscontmidpoint))))
        else
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          fis2 = rfil*(vis2+disscontmagnitude/(1+exp(-(disscontsharpness&
&           *(log10(totalr/totalr0)+disscontmidpoint)))))
        end if
      else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        fis2 = rfil*vis2
      end if
      fis4 = rfil*vis4
      sfil = one - rfil
! initialize the dissipative residual to a certain times,
! possibly zero, the previously stored value. owned cells
! only, because the halo values do not matter.
      if (associated(radkd)) radkd = 0.0_8
      dssd = 0.0_8
!$bwd-of ii-loop 
      do ii=0,nx*ny*kl-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, ny) + 2
        k = ii/(nx*ny) + 1
! compute the dissipation coefficients for this face.
        ppor = zero
        if (pork(i, j, k) .eq. normalflux) ppor = half
        rrad = ppor*(radk(i, j, k)+radk(i, j, k+1))
        if (dss(i, j, k, 3) .lt. dss(i, j, k+1, 3)) then
          y3 = dss(i, j, k+1, 3)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          y3 = dss(i, j, k, 3)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (dssmax .gt. y3) then
          min3 = y3
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          min3 = dssmax
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        dis2 = fis2*rrad*min3
        arg1 = fis4*rrad
        dis4 = mydim(arg1, dis2)
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
        ddw1 = w(i, j, k+1, irho) - w(i, j, k, irho)
! x-momentum.
        ddw2 = w(i, j, k+1, ivx)*w(i, j, k+1, irho) - w(i, j, k, ivx)*w(&
&         i, j, k, irho)
! y-momentum.
        ddw3 = w(i, j, k+1, ivy)*w(i, j, k+1, irho) - w(i, j, k, ivy)*w(&
&         i, j, k, irho)
! z-momentum.
        ddw4 = w(i, j, k+1, ivz)*w(i, j, k+1, irho) - w(i, j, k, ivz)*w(&
&         i, j, k, irho)
! energy.
        ddw5 = w(i, j, k+1, irhoe) + p(i, j, k+1) - (w(i, j, k, irhoe)+p&
&         (i, j, k))
        fsd = fwd(i, j, k+1, irhoe) - fwd(i, j, k, irhoe)
        dis2d = ddw5*fsd
        dis4d = -((w(i, j, k+2, irhoe)+p(i, j, k+2)-w(i, j, k-1, irhoe)-&
&         p(i, j, k-1)-three*ddw5)*fsd)
        tempd1 = -(dis4*fsd)
        ddw5d = dis2*fsd - three*tempd1
        wd(i, j, k+2, irhoe) = wd(i, j, k+2, irhoe) + tempd1
        pd(i, j, k+2) = pd(i, j, k+2) + tempd1
        wd(i, j, k-1, irhoe) = wd(i, j, k-1, irhoe) - tempd1
        pd(i, j, k-1) = pd(i, j, k-1) - tempd1
        wd(i, j, k+1, irhoe) = wd(i, j, k+1, irhoe) + ddw5d
        pd(i, j, k+1) = pd(i, j, k+1) + ddw5d
        wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddw5d
        pd(i, j, k) = pd(i, j, k) - ddw5d
        fsd = fwd(i, j, k+1, imz) - fwd(i, j, k, imz)
        temp3 = w(i, j, k-1, irho)
        temp2 = w(i, j, k-1, ivz)
        temp1 = w(i, j, k+2, irho)
        temp0 = w(i, j, k+2, ivz)
        dis2d = dis2d + ddw4*fsd
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw4)*fsd
        tempd2 = -(dis4*fsd)
        ddw4d = dis2*fsd - three*tempd2
        wd(i, j, k+2, ivz) = wd(i, j, k+2, ivz) + temp1*tempd2
        wd(i, j, k+2, irho) = wd(i, j, k+2, irho) + temp0*tempd2
        wd(i, j, k-1, ivz) = wd(i, j, k-1, ivz) - temp3*tempd2
        wd(i, j, k-1, irho) = wd(i, j, k-1, irho) - temp2*tempd2
        wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + w(i, j, k+1, irho)*&
&         ddw4d
        wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, ivz)*&
&         ddw4d
        wd(i, j, k, ivz) = wd(i, j, k, ivz) - w(i, j, k, irho)*ddw4d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivz)*ddw4d
        fsd = fwd(i, j, k+1, imy) - fwd(i, j, k, imy)
        temp3 = w(i, j, k-1, irho)
        temp2 = w(i, j, k-1, ivy)
        temp1 = w(i, j, k+2, irho)
        temp0 = w(i, j, k+2, ivy)
        dis2d = dis2d + ddw3*fsd
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw3)*fsd
        tempd2 = -(dis4*fsd)
        ddw3d = dis2*fsd - three*tempd2
        wd(i, j, k+2, ivy) = wd(i, j, k+2, ivy) + temp1*tempd2
        wd(i, j, k+2, irho) = wd(i, j, k+2, irho) + temp0*tempd2
        wd(i, j, k-1, ivy) = wd(i, j, k-1, ivy) - temp3*tempd2
        wd(i, j, k-1, irho) = wd(i, j, k-1, irho) - temp2*tempd2
        wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + w(i, j, k+1, irho)*&
&         ddw3d
        wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, ivy)*&
&         ddw3d
        wd(i, j, k, ivy) = wd(i, j, k, ivy) - w(i, j, k, irho)*ddw3d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivy)*ddw3d
        fsd = fwd(i, j, k+1, imx) - fwd(i, j, k, imx)
        temp3 = w(i, j, k-1, irho)
        temp2 = w(i, j, k-1, ivx)
        temp1 = w(i, j, k+2, irho)
        temp0 = w(i, j, k+2, ivx)
        dis2d = dis2d + ddw2*fsd
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw2)*fsd
        tempd2 = -(dis4*fsd)
        ddw2d = dis2*fsd - three*tempd2
        wd(i, j, k+2, ivx) = wd(i, j, k+2, ivx) + temp1*tempd2
        wd(i, j, k+2, irho) = wd(i, j, k+2, irho) + temp0*tempd2
        wd(i, j, k-1, ivx) = wd(i, j, k-1, ivx) - temp3*tempd2
        wd(i, j, k-1, irho) = wd(i, j, k-1, irho) - temp2*tempd2
        wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + w(i, j, k+1, irho)*&
&         ddw2d
        wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, ivx)*&
&         ddw2d
        wd(i, j, k, ivx) = wd(i, j, k, ivx) - w(i, j, k, irho)*ddw2d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivx)*ddw2d
        fsd = fwd(i, j, k+1, irho) - fwd(i, j, k, irho)
        dis2d = dis2d + ddw1*fsd
        dis4d = dis4d - (w(i, j, k+2, irho)-w(i, j, k-1, irho)-three*&
&         ddw1)*fsd
        tempd1 = -(dis4*fsd)
        ddw1d = dis2*fsd - three*tempd1
        wd(i, j, k+2, irho) = wd(i, j, k+2, irho) + tempd1
        wd(i, j, k-1, irho) = wd(i, j, k-1, irho) - tempd1
        wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + ddw1d
        wd(i, j, k, irho) = wd(i, j, k, irho) - ddw1d
        call mydim_fast_b(arg1, arg1d, dis2, dis2d, dis4d)
        rradd = fis4*arg1d + min3*fis2*dis2d
        min3d = rrad*fis2*dis2d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          y3d = min3d
        else
          y3d = 0.0_8
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          dssd(i, j, k+1, 3) = dssd(i, j, k+1, 3) + y3d
        else
          dssd(i, j, k, 3) = dssd(i, j, k, 3) + y3d
        end if
        radkd(i, j, k) = radkd(i, j, k) + ppor*rradd
        radkd(i, j, k+1) = radkd(i, j, k+1) + ppor*rradd
      end do
      if (associated(radjd)) radjd = 0.0_8
!$bwd-of ii-loop 
      do ii=0,nx*jl*nz-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, jl) + 1
        k = ii/(nx*jl) + 2
! compute the dissipation coefficients for this face.
        ppor = zero
        if (porj(i, j, k) .eq. normalflux) ppor = half
        rrad = ppor*(radj(i, j, k)+radj(i, j+1, k))
        if (dss(i, j, k, 2) .lt. dss(i, j+1, k, 2)) then
          y2 = dss(i, j+1, k, 2)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          y2 = dss(i, j, k, 2)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (dssmax .gt. y2) then
          min2 = y2
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          min2 = dssmax
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        dis2 = fis2*rrad*min2
        arg1 = fis4*rrad
        dis4 = mydim(arg1, dis2)
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
        ddw1 = w(i, j+1, k, irho) - w(i, j, k, irho)
! x-momentum.
        ddw2 = w(i, j+1, k, ivx)*w(i, j+1, k, irho) - w(i, j, k, ivx)*w(&
&         i, j, k, irho)
! y-momentum.
        ddw3 = w(i, j+1, k, ivy)*w(i, j+1, k, irho) - w(i, j, k, ivy)*w(&
&         i, j, k, irho)
! z-momentum.
        ddw4 = w(i, j+1, k, ivz)*w(i, j+1, k, irho) - w(i, j, k, ivz)*w(&
&         i, j, k, irho)
! energy.
        ddw5 = w(i, j+1, k, irhoe) + p(i, j+1, k) - (w(i, j, k, irhoe)+p&
&         (i, j, k))
        fsd = fwd(i, j+1, k, irhoe) - fwd(i, j, k, irhoe)
        dis2d = ddw5*fsd
        dis4d = -((w(i, j+2, k, irhoe)+p(i, j+2, k)-w(i, j-1, k, irhoe)-&
&         p(i, j-1, k)-three*ddw5)*fsd)
        tempd1 = -(dis4*fsd)
        ddw5d = dis2*fsd - three*tempd1
        wd(i, j+2, k, irhoe) = wd(i, j+2, k, irhoe) + tempd1
        pd(i, j+2, k) = pd(i, j+2, k) + tempd1
        wd(i, j-1, k, irhoe) = wd(i, j-1, k, irhoe) - tempd1
        pd(i, j-1, k) = pd(i, j-1, k) - tempd1
        wd(i, j+1, k, irhoe) = wd(i, j+1, k, irhoe) + ddw5d
        pd(i, j+1, k) = pd(i, j+1, k) + ddw5d
        wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddw5d
        pd(i, j, k) = pd(i, j, k) - ddw5d
        fsd = fwd(i, j+1, k, imz) - fwd(i, j, k, imz)
        temp3 = w(i, j-1, k, irho)
        temp2 = w(i, j-1, k, ivz)
        temp1 = w(i, j+2, k, irho)
        temp0 = w(i, j+2, k, ivz)
        dis2d = dis2d + ddw4*fsd
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw4)*fsd
        tempd2 = -(dis4*fsd)
        ddw4d = dis2*fsd - three*tempd2
        wd(i, j+2, k, ivz) = wd(i, j+2, k, ivz) + temp1*tempd2
        wd(i, j+2, k, irho) = wd(i, j+2, k, irho) + temp0*tempd2
        wd(i, j-1, k, ivz) = wd(i, j-1, k, ivz) - temp3*tempd2
        wd(i, j-1, k, irho) = wd(i, j-1, k, irho) - temp2*tempd2
        wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + w(i, j+1, k, irho)*&
&         ddw4d
        wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, ivz)*&
&         ddw4d
        wd(i, j, k, ivz) = wd(i, j, k, ivz) - w(i, j, k, irho)*ddw4d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivz)*ddw4d
        fsd = fwd(i, j+1, k, imy) - fwd(i, j, k, imy)
        temp3 = w(i, j-1, k, irho)
        temp2 = w(i, j-1, k, ivy)
        temp1 = w(i, j+2, k, irho)
        temp0 = w(i, j+2, k, ivy)
        dis2d = dis2d + ddw3*fsd
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw3)*fsd
        tempd2 = -(dis4*fsd)
        ddw3d = dis2*fsd - three*tempd2
        wd(i, j+2, k, ivy) = wd(i, j+2, k, ivy) + temp1*tempd2
        wd(i, j+2, k, irho) = wd(i, j+2, k, irho) + temp0*tempd2
        wd(i, j-1, k, ivy) = wd(i, j-1, k, ivy) - temp3*tempd2
        wd(i, j-1, k, irho) = wd(i, j-1, k, irho) - temp2*tempd2
        wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + w(i, j+1, k, irho)*&
&         ddw3d
        wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, ivy)*&
&         ddw3d
        wd(i, j, k, ivy) = wd(i, j, k, ivy) - w(i, j, k, irho)*ddw3d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivy)*ddw3d
        fsd = fwd(i, j+1, k, imx) - fwd(i, j, k, imx)
        temp3 = w(i, j-1, k, irho)
        temp2 = w(i, j-1, k, ivx)
        temp1 = w(i, j+2, k, irho)
        temp0 = w(i, j+2, k, ivx)
        dis2d = dis2d + ddw2*fsd
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw2)*fsd
        tempd2 = -(dis4*fsd)
        ddw2d = dis2*fsd - three*tempd2
        wd(i, j+2, k, ivx) = wd(i, j+2, k, ivx) + temp1*tempd2
        wd(i, j+2, k, irho) = wd(i, j+2, k, irho) + temp0*tempd2
        wd(i, j-1, k, ivx) = wd(i, j-1, k, ivx) - temp3*tempd2
        wd(i, j-1, k, irho) = wd(i, j-1, k, irho) - temp2*tempd2
        wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + w(i, j+1, k, irho)*&
&         ddw2d
        wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, ivx)*&
&         ddw2d
        wd(i, j, k, ivx) = wd(i, j, k, ivx) - w(i, j, k, irho)*ddw2d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivx)*ddw2d
        fsd = fwd(i, j+1, k, irho) - fwd(i, j, k, irho)
        dis2d = dis2d + ddw1*fsd
        dis4d = dis4d - (w(i, j+2, k, irho)-w(i, j-1, k, irho)-three*&
&         ddw1)*fsd
        tempd1 = -(dis4*fsd)
        ddw1d = dis2*fsd - three*tempd1
        wd(i, j+2, k, irho) = wd(i, j+2, k, irho) + tempd1
        wd(i, j-1, k, irho) = wd(i, j-1, k, irho) - tempd1
        wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + ddw1d
        wd(i, j, k, irho) = wd(i, j, k, irho) - ddw1d
        call mydim_fast_b(arg1, arg1d, dis2, dis2d, dis4d)
        rradd = fis4*arg1d + min2*fis2*dis2d
        min2d = rrad*fis2*dis2d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          y2d = min2d
        else
          y2d = 0.0_8
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          dssd(i, j+1, k, 2) = dssd(i, j+1, k, 2) + y2d
        else
          dssd(i, j, k, 2) = dssd(i, j, k, 2) + y2d
        end if
        radjd(i, j, k) = radjd(i, j, k) + ppor*rradd
        radjd(i, j+1, k) = radjd(i, j+1, k) + ppor*rradd
      end do
      if (associated(radid)) radid = 0.0_8
!$bwd-of ii-loop 
      do ii=0,il*ny*nz-1
        i = mod(ii, il) + 1
        j = mod(ii/il, ny) + 2
        k = ii/(il*ny) + 2
! compute the dissipation coefficients for this face.
        ppor = zero
        if (pori(i, j, k) .eq. normalflux) ppor = half
        rrad = ppor*(radi(i, j, k)+radi(i+1, j, k))
        if (dss(i, j, k, 1) .lt. dss(i+1, j, k, 1)) then
          y1 = dss(i+1, j, k, 1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          y1 = dss(i, j, k, 1)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        if (dssmax .gt. y1) then
          min1 = y1
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
          min1 = dssmax
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        dis2 = fis2*rrad*min1
        arg1 = fis4*rrad
        dis4 = mydim(arg1, dis2)
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
        ddw1 = w(i+1, j, k, irho) - w(i, j, k, irho)
! x-momentum.
        ddw2 = w(i+1, j, k, ivx)*w(i+1, j, k, irho) - w(i, j, k, ivx)*w(&
&         i, j, k, irho)
! y-momentum.
        ddw3 = w(i+1, j, k, ivy)*w(i+1, j, k, irho) - w(i, j, k, ivy)*w(&
&         i, j, k, irho)
! z-momentum.
        ddw4 = w(i+1, j, k, ivz)*w(i+1, j, k, irho) - w(i, j, k, ivz)*w(&
&         i, j, k, irho)
! energy.
        ddw5 = w(i+1, j, k, irhoe) + p(i+1, j, k) - (w(i, j, k, irhoe)+p&
&         (i, j, k))
        fsd = fwd(i+1, j, k, irhoe) - fwd(i, j, k, irhoe)
        dis2d = ddw5*fsd
        dis4d = -((w(i+2, j, k, irhoe)+p(i+2, j, k)-w(i-1, j, k, irhoe)-&
&         p(i-1, j, k)-three*ddw5)*fsd)
        tempd1 = -(dis4*fsd)
        ddw5d = dis2*fsd - three*tempd1
        wd(i+2, j, k, irhoe) = wd(i+2, j, k, irhoe) + tempd1
        pd(i+2, j, k) = pd(i+2, j, k) + tempd1
        wd(i-1, j, k, irhoe) = wd(i-1, j, k, irhoe) - tempd1
        pd(i-1, j, k) = pd(i-1, j, k) - tempd1
        wd(i+1, j, k, irhoe) = wd(i+1, j, k, irhoe) + ddw5d
        pd(i+1, j, k) = pd(i+1, j, k) + ddw5d
        wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddw5d
        pd(i, j, k) = pd(i, j, k) - ddw5d
        fsd = fwd(i+1, j, k, imz) - fwd(i, j, k, imz)
        temp3 = w(i-1, j, k, irho)
        temp2 = w(i-1, j, k, ivz)
        temp1 = w(i+2, j, k, irho)
        temp0 = w(i+2, j, k, ivz)
        dis2d = dis2d + ddw4*fsd
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw4)*fsd
        tempd2 = -(dis4*fsd)
        ddw4d = dis2*fsd - three*tempd2
        wd(i+2, j, k, ivz) = wd(i+2, j, k, ivz) + temp1*tempd2
        wd(i+2, j, k, irho) = wd(i+2, j, k, irho) + temp0*tempd2
        wd(i-1, j, k, ivz) = wd(i-1, j, k, ivz) - temp3*tempd2
        wd(i-1, j, k, irho) = wd(i-1, j, k, irho) - temp2*tempd2
        wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + w(i+1, j, k, irho)*&
&         ddw4d
        wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, ivz)*&
&         ddw4d
        wd(i, j, k, ivz) = wd(i, j, k, ivz) - w(i, j, k, irho)*ddw4d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivz)*ddw4d
        fsd = fwd(i+1, j, k, imy) - fwd(i, j, k, imy)
        temp3 = w(i-1, j, k, irho)
        temp2 = w(i-1, j, k, ivy)
        temp1 = w(i+2, j, k, irho)
        temp0 = w(i+2, j, k, ivy)
        dis2d = dis2d + ddw3*fsd
        dis4d = dis4d - (temp0*temp1-temp2*temp3-three*ddw3)*fsd
        tempd2 = -(dis4*fsd)
        ddw3d = dis2*fsd - three*tempd2
        wd(i+2, j, k, ivy) = wd(i+2, j, k, ivy) + temp1*tempd2
        wd(i+2, j, k, irho) = wd(i+2, j, k, irho) + temp0*tempd2
        wd(i-1, j, k, ivy) = wd(i-1, j, k, ivy) - temp3*tempd2
        wd(i-1, j, k, irho) = wd(i-1, j, k, irho) - temp2*tempd2
        wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + w(i+1, j, k, irho)*&
&         ddw3d
        wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, ivy)*&
&         ddw3d
        wd(i, j, k, ivy) = wd(i, j, k, ivy) - w(i, j, k, irho)*ddw3d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivy)*ddw3d
        fsd = fwd(i+1, j, k, imx) - fwd(i, j, k, imx)
        temp1 = w(i-1, j, k, irho)
        temp0 = w(i-1, j, k, ivx)
        temp = w(i+2, j, k, irho)
        temp2 = w(i+2, j, k, ivx)
        dis2d = dis2d + ddw2*fsd
        dis4d = dis4d - (temp2*temp-temp0*temp1-three*ddw2)*fsd
        tempd1 = -(dis4*fsd)
        ddw2d = dis2*fsd - three*tempd1
        wd(i+2, j, k, ivx) = wd(i+2, j, k, ivx) + temp*tempd1
        wd(i+2, j, k, irho) = wd(i+2, j, k, irho) + temp2*tempd1
        wd(i-1, j, k, ivx) = wd(i-1, j, k, ivx) - temp1*tempd1
        wd(i-1, j, k, irho) = wd(i-1, j, k, irho) - temp0*tempd1
        wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + w(i+1, j, k, irho)*&
&         ddw2d
        wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, ivx)*&
&         ddw2d
        wd(i, j, k, ivx) = wd(i, j, k, ivx) - w(i, j, k, irho)*ddw2d
        wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivx)*ddw2d
        fsd = fwd(i+1, j, k, irho) - fwd(i, j, k, irho)
        dis2d = dis2d + ddw1*fsd
        dis4d = dis4d - (w(i+2, j, k, irho)-w(i-1, j, k, irho)-three*&
&         ddw1)*fsd
        tempd0 = -(dis4*fsd)
        ddw1d = dis2*fsd - three*tempd0
        wd(i+2, j, k, irho) = wd(i+2, j, k, irho) + tempd0
        wd(i-1, j, k, irho) = wd(i-1, j, k, irho) - tempd0
        wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + ddw1d
        wd(i, j, k, irho) = wd(i, j, k, irho) - ddw1d
        call mydim_fast_b(arg1, arg1d, dis2, dis2d, dis4d)
        rradd = fis4*arg1d + min1*fis2*dis2d
        min1d = rrad*fis2*dis2d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          y1d = min1d
        else
          y1d = 0.0_8
        end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          dssd(i+1, j, k, 1) = dssd(i+1, j, k, 1) + y1d
        else
          dssd(i, j, k, 1) = dssd(i, j, k, 1) + y1d
        end if
        radid(i, j, k) = radid(i, j, k) + ppor*rradd
        radid(i+1, j, k) = radid(i+1, j, k) + ppor*rradd
      end do
      fwd = sfil*fwd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
      ssd = 0.0_8
!$bwd-of ii-loop 
      do ii=0,ie*je*ke-1
        i = mod(ii, ie) + 1
        j = mod(ii/ie, je) + 1
        k = ii/(ie*je) + 1
        x1 = (ss(i+1, j, k)-two*ss(i, j, k)+ss(i-1, j, k))/(ss(i+1, j, k&
&         )+two*ss(i, j, k)+ss(i-1, j, k)+sslim)
        if (x1 .ge. 0.) then
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        x2 = (ss(i, j+1, k)-two*ss(i, j, k)+ss(i, j-1, k))/(ss(i, j+1, k&
&         )+two*ss(i, j, k)+ss(i, j-1, k)+sslim)
        if (x2 .ge. 0.) then
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        x3 = (ss(i, j, k+1)-two*ss(i, j, k)+ss(i, j, k-1))/(ss(i, j, k+1&
&         )+two*ss(i, j, k)+ss(i, j, k-1)+sslim)
        if (x3 .ge. 0.) then
          x3d = dssd(i, j, k, 3)
          dssd(i, j, k, 3) = 0.0_8
        else
          x3d = -dssd(i, j, k, 3)
          dssd(i, j, k, 3) = 0.0_8
        end if
        temp1 = sslim + ss(i, j, k+1) + two*ss(i, j, k) + ss(i, j, k-1)
        tempd = x3d/temp1
        tempd0 = -((ss(i, j, k+1)-two*ss(i, j, k)+ss(i, j, k-1))*tempd/&
&         temp1)
        ssd(i, j, k+1) = ssd(i, j, k+1) + tempd + tempd0
        ssd(i, j, k) = ssd(i, j, k) + two*tempd0 - two*tempd
        ssd(i, j, k-1) = ssd(i, j, k-1) + tempd + tempd0
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          x2d = dssd(i, j, k, 2)
          dssd(i, j, k, 2) = 0.0_8
        else
          x2d = -dssd(i, j, k, 2)
          dssd(i, j, k, 2) = 0.0_8
        end if
        temp1 = sslim + ss(i, j+1, k) + two*ss(i, j, k) + ss(i, j-1, k)
        tempd = x2d/temp1
        tempd0 = -((ss(i, j+1, k)-two*ss(i, j, k)+ss(i, j-1, k))*tempd/&
&         temp1)
        ssd(i, j+1, k) = ssd(i, j+1, k) + tempd + tempd0
        ssd(i, j, k) = ssd(i, j, k) + two*tempd0 - two*tempd
        ssd(i, j-1, k) = ssd(i, j-1, k) + tempd + tempd0
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          x1d = dssd(i, j, k, 1)
          dssd(i, j, k, 1) = 0.0_8
        else
          x1d = -dssd(i, j, k, 1)
          dssd(i, j, k, 1) = 0.0_8
        end if
        temp1 = sslim + ss(i+1, j, k) + two*ss(i, j, k) + ss(i-1, j, k)
        tempd = x1d/temp1
        tempd0 = -((ss(i+1, j, k)-two*ss(i, j, k)+ss(i-1, j, k))*tempd/&
&         temp1)
        ssd(i+1, j, k) = ssd(i+1, j, k) + tempd + tempd0
        ssd(i, j, k) = ssd(i, j, k) + two*tempd0 - two*tempd
        ssd(i-1, j, k) = ssd(i-1, j, k) + tempd + tempd0
      end do
      call popcontrol2b(branch)
      if (branch .ne. 0) then
        if (branch .eq. 1) then
          pd = pd + ssd
        else
!$bwd-of ii-loop 
          do ii=0,(ib+1)*(jb+1)*(kb+1)-1
            i = mod(ii, ib + 1)
            j = mod(ii/(ib+1), jb + 1)
            k = ii/((ib+1)*(jb+1))
            temp = gamma(i, j, k)
            temp0 = w(i, j, k, irho)
            temp1 = temp0**temp
            pd(i, j, k) = pd(i, j, k) + ssd(i, j, k)/temp1
            if (.not.(temp0 .le. 0.0_8 .and. (temp .eq. 0.0_8 .or. temp &
&               .ne. int(temp)))) wd(i, j, k, irho) = wd(i, j, k, irho) &
&               - temp*temp0**(temp-1)*p(i, j, k)*ssd(i, j, k)/temp1**2
            ssd(i, j, k) = 0.0_8
          end do
        end if
      end if
    end if
  end subroutine invisciddissfluxscalar_fast_b
 
  subroutine invisciddissfluxscalar()
!
!       invisciddissfluxscalar computes the scalar artificial
!       dissipation, see aiaa paper 81-1259, for a given block.
!       therefore it is assumed that the pointers in  blockpointers
!       already point to the correct block.
!
    use constants
    use blockpointers, only : nx, ny, nz, il, jl, kl, ie, je, ke,&
&   ib, jb, kb, w, p, pori, porj, pork, fw, radi, radj, radk, gamma
    use flowvarrefstate, only : gammainf, pinfcorr, rhoinf
    use inputdiscretization, only : vis2, vis4
    use inputiteration, only : usedisscontinuation, disscontmagnitude, &
&   disscontmidpoint, disscontsharpness
    use inputphysics, only : equations
    use iteration, only : rfil, totalr0, totalr
    use utils_fast_b, only : mydim
    implicit none
!
!      local parameter.
!
    real(kind=realtype), parameter :: dssmax=0.25_realtype
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k, ind, ii
    real(kind=realtype) :: sslim, rhoi
    real(kind=realtype) :: sfil, fis2, fis4
    real(kind=realtype) :: ppor, rrad, dis2, dis4
    real(kind=realtype) :: ddw1, ddw2, ddw3, ddw4, ddw5, fs
    real(kind=realtype), dimension(ie, je, ke, 3) :: dss
    real(kind=realtype), dimension(0:ib, 0:jb, 0:kb) :: ss
    intrinsic abs
    intrinsic mod
    intrinsic exp
    intrinsic log10
    intrinsic max
    intrinsic min
    real(kind=realtype) :: x1
    real(kind=realtype) :: x2
    real(kind=realtype) :: x3
    real(kind=realtype) :: y1
    real(kind=realtype) :: y2
    real(kind=realtype) :: y3
    real(kind=realtype) :: abs0
    real(kind=realtype) :: min1
    real(kind=realtype) :: min2
    real(kind=realtype) :: min3
    real(kind=realtype) :: arg1
    if (rfil .ge. 0.) then
      abs0 = rfil
    else
      abs0 = -rfil
    end if
! check if rfil == 0. if so, the dissipative flux needs not to
! be computed.
    if (abs0 .lt. thresholdreal) then
      return
    else
! determine the variables used to compute the switch.
! for the inviscid case this is the pressure; for the viscous
! case it is the entropy.
      select case  (equations) 
      case (eulerequations) 
! inviscid case. pressure switch is based on the pressure.
! also set the value of sslim. to be fully consistent this
! must have the dimension of pressure and it is therefore
! set to a fraction of the free stream value.
        sslim = 0.001_realtype*pinfcorr
! copy the pressure in ss. only need the entries used in the
! discretization, i.e. not including the corner halo's, but we'll
! just copy all anyway.
        ss = p
!===============================================================
      case (nsequations, ransequations) 
! viscous case. pressure switch is based on the entropy.
! also set the value of sslim. to be fully consistent this
! must have the dimension of entropy and it is therefore
! set to a fraction of the free stream value.
        sslim = 0.001_realtype*pinfcorr/rhoinf**gammainf
!$ad ii-loop
! store the entropy in ss. see above.
        do ii=0,(ib+1)*(jb+1)*(kb+1)-1
          i = mod(ii, ib + 1)
          j = mod(ii/(ib+1), jb + 1)
          k = ii/((ib+1)*(jb+1))
          ss(i, j, k) = p(i, j, k)/w(i, j, k, irho)**gamma(i, j, k)
        end do
      end select
!$ad ii-loop
! compute the pressure sensor for each cell, in each direction:
      do ii=0,ie*je*ke-1
        i = mod(ii, ie) + 1
        j = mod(ii/ie, je) + 1
        k = ii/(ie*je) + 1
        x1 = (ss(i+1, j, k)-two*ss(i, j, k)+ss(i-1, j, k))/(ss(i+1, j, k&
&         )+two*ss(i, j, k)+ss(i-1, j, k)+sslim)
        if (x1 .ge. 0.) then
          dss(i, j, k, 1) = x1
        else
          dss(i, j, k, 1) = -x1
        end if
        x2 = (ss(i, j+1, k)-two*ss(i, j, k)+ss(i, j-1, k))/(ss(i, j+1, k&
&         )+two*ss(i, j, k)+ss(i, j-1, k)+sslim)
        if (x2 .ge. 0.) then
          dss(i, j, k, 2) = x2
        else
          dss(i, j, k, 2) = -x2
        end if
        x3 = (ss(i, j, k+1)-two*ss(i, j, k)+ss(i, j, k-1))/(ss(i, j, k+1&
&         )+two*ss(i, j, k)+ss(i, j, k-1)+sslim)
        if (x3 .ge. 0.) then
          dss(i, j, k, 3) = x3
        else
          dss(i, j, k, 3) = -x3
        end if
      end do
! set the dissipation constants for the scheme.
! rfil and sfil are fractions used by the runge-kutta solver to compute residuals at intermediate steps.
! this means that fis2 and fis4 will be some fraction of vis2 and vis4, respectively.
! for other solvers, rfil==1, sfil==0, fis2==vis2, and fis4==vis4.
! the sigmoid function used for dissipation-based continuation is described in eq. 28 and eq. 29 from the paper:
! "improving the performance of a compressible rans solver for low and high mach number flows" (seraj2022c).
! the options documentation also has information on the parameters in this formulation.
      if (usedisscontinuation) then
        if (totalr .eq. zero .or. totalr0 .eq. zero) then
          fis2 = rfil*(vis2+disscontmagnitude/(1+exp(-(disscontsharpness&
&           *disscontmidpoint))))
        else
          fis2 = rfil*(vis2+disscontmagnitude/(1+exp(-(disscontsharpness&
&           *(log10(totalr/totalr0)+disscontmidpoint)))))
        end if
      else
        fis2 = rfil*vis2
      end if
      fis4 = rfil*vis4
      sfil = one - rfil
! initialize the dissipative residual to a certain times,
! possibly zero, the previously stored value. owned cells
! only, because the halo values do not matter.
      fw = sfil*fw
!$ad ii-loop
!
!       dissipative fluxes in the i-direction.
!
      do ii=0,il*ny*nz-1
        i = mod(ii, il) + 1
        j = mod(ii/il, ny) + 2
        k = ii/(il*ny) + 2
! compute the dissipation coefficients for this face.
        ppor = zero
        if (pori(i, j, k) .eq. normalflux) ppor = half
        rrad = ppor*(radi(i, j, k)+radi(i+1, j, k))
        if (dss(i, j, k, 1) .lt. dss(i+1, j, k, 1)) then
          y1 = dss(i+1, j, k, 1)
        else
          y1 = dss(i, j, k, 1)
        end if
        if (dssmax .gt. y1) then
          min1 = y1
        else
          min1 = dssmax
        end if
        dis2 = fis2*rrad*min1
        arg1 = fis4*rrad
        dis4 = mydim(arg1, dis2)
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
        ddw1 = w(i+1, j, k, irho) - w(i, j, k, irho)
        fs = dis2*ddw1 - dis4*(w(i+2, j, k, irho)-w(i-1, j, k, irho)-&
&         three*ddw1)
        fw(i+1, j, k, irho) = fw(i+1, j, k, irho) + fs
        fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
        ddw2 = w(i+1, j, k, ivx)*w(i+1, j, k, irho) - w(i, j, k, ivx)*w(&
&         i, j, k, irho)
        fs = dis2*ddw2 - dis4*(w(i+2, j, k, ivx)*w(i+2, j, k, irho)-w(i-&
&         1, j, k, ivx)*w(i-1, j, k, irho)-three*ddw2)
        fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fs
        fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
        ddw3 = w(i+1, j, k, ivy)*w(i+1, j, k, irho) - w(i, j, k, ivy)*w(&
&         i, j, k, irho)
        fs = dis2*ddw3 - dis4*(w(i+2, j, k, ivy)*w(i+2, j, k, irho)-w(i-&
&         1, j, k, ivy)*w(i-1, j, k, irho)-three*ddw3)
        fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fs
        fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
        ddw4 = w(i+1, j, k, ivz)*w(i+1, j, k, irho) - w(i, j, k, ivz)*w(&
&         i, j, k, irho)
        fs = dis2*ddw4 - dis4*(w(i+2, j, k, ivz)*w(i+2, j, k, irho)-w(i-&
&         1, j, k, ivz)*w(i-1, j, k, irho)-three*ddw4)
        fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fs
        fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
        ddw5 = w(i+1, j, k, irhoe) + p(i+1, j, k) - (w(i, j, k, irhoe)+p&
&         (i, j, k))
        fs = dis2*ddw5 - dis4*(w(i+2, j, k, irhoe)+p(i+2, j, k)-(w(i-1, &
&         j, k, irhoe)+p(i-1, j, k))-three*ddw5)
        fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + fs
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
      end do
!$ad ii-loop
!
!       dissipative fluxes in the j-direction.
!
      do ii=0,nx*jl*nz-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, jl) + 1
        k = ii/(nx*jl) + 2
! compute the dissipation coefficients for this face.
        ppor = zero
        if (porj(i, j, k) .eq. normalflux) ppor = half
        rrad = ppor*(radj(i, j, k)+radj(i, j+1, k))
        if (dss(i, j, k, 2) .lt. dss(i, j+1, k, 2)) then
          y2 = dss(i, j+1, k, 2)
        else
          y2 = dss(i, j, k, 2)
        end if
        if (dssmax .gt. y2) then
          min2 = y2
        else
          min2 = dssmax
        end if
        dis2 = fis2*rrad*min2
        arg1 = fis4*rrad
        dis4 = mydim(arg1, dis2)
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
        ddw1 = w(i, j+1, k, irho) - w(i, j, k, irho)
        fs = dis2*ddw1 - dis4*(w(i, j+2, k, irho)-w(i, j-1, k, irho)-&
&         three*ddw1)
        fw(i, j+1, k, irho) = fw(i, j+1, k, irho) + fs
        fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
        ddw2 = w(i, j+1, k, ivx)*w(i, j+1, k, irho) - w(i, j, k, ivx)*w(&
&         i, j, k, irho)
        fs = dis2*ddw2 - dis4*(w(i, j+2, k, ivx)*w(i, j+2, k, irho)-w(i&
&         , j-1, k, ivx)*w(i, j-1, k, irho)-three*ddw2)
        fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fs
        fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
        ddw3 = w(i, j+1, k, ivy)*w(i, j+1, k, irho) - w(i, j, k, ivy)*w(&
&         i, j, k, irho)
        fs = dis2*ddw3 - dis4*(w(i, j+2, k, ivy)*w(i, j+2, k, irho)-w(i&
&         , j-1, k, ivy)*w(i, j-1, k, irho)-three*ddw3)
        fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fs
        fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
        ddw4 = w(i, j+1, k, ivz)*w(i, j+1, k, irho) - w(i, j, k, ivz)*w(&
&         i, j, k, irho)
        fs = dis2*ddw4 - dis4*(w(i, j+2, k, ivz)*w(i, j+2, k, irho)-w(i&
&         , j-1, k, ivz)*w(i, j-1, k, irho)-three*ddw4)
        fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fs
        fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
        ddw5 = w(i, j+1, k, irhoe) + p(i, j+1, k) - (w(i, j, k, irhoe)+p&
&         (i, j, k))
        fs = dis2*ddw5 - dis4*(w(i, j+2, k, irhoe)+p(i, j+2, k)-(w(i, j-&
&         1, k, irhoe)+p(i, j-1, k))-three*ddw5)
        fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + fs
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
      end do
!$ad ii-loop
!
!       dissipative fluxes in the k-direction.
!
      do ii=0,nx*ny*kl-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, ny) + 2
        k = ii/(nx*ny) + 1
! compute the dissipation coefficients for this face.
        ppor = zero
        if (pork(i, j, k) .eq. normalflux) ppor = half
        rrad = ppor*(radk(i, j, k)+radk(i, j, k+1))
        if (dss(i, j, k, 3) .lt. dss(i, j, k+1, 3)) then
          y3 = dss(i, j, k+1, 3)
        else
          y3 = dss(i, j, k, 3)
        end if
        if (dssmax .gt. y3) then
          min3 = y3
        else
          min3 = dssmax
        end if
        dis2 = fis2*rrad*min3
        arg1 = fis4*rrad
        dis4 = mydim(arg1, dis2)
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
        ddw1 = w(i, j, k+1, irho) - w(i, j, k, irho)
        fs = dis2*ddw1 - dis4*(w(i, j, k+2, irho)-w(i, j, k-1, irho)-&
&         three*ddw1)
        fw(i, j, k+1, irho) = fw(i, j, k+1, irho) + fs
        fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
        ddw2 = w(i, j, k+1, ivx)*w(i, j, k+1, irho) - w(i, j, k, ivx)*w(&
&         i, j, k, irho)
        fs = dis2*ddw2 - dis4*(w(i, j, k+2, ivx)*w(i, j, k+2, irho)-w(i&
&         , j, k-1, ivx)*w(i, j, k-1, irho)-three*ddw2)
        fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fs
        fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
        ddw3 = w(i, j, k+1, ivy)*w(i, j, k+1, irho) - w(i, j, k, ivy)*w(&
&         i, j, k, irho)
        fs = dis2*ddw3 - dis4*(w(i, j, k+2, ivy)*w(i, j, k+2, irho)-w(i&
&         , j, k-1, ivy)*w(i, j, k-1, irho)-three*ddw3)
        fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fs
        fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
        ddw4 = w(i, j, k+1, ivz)*w(i, j, k+1, irho) - w(i, j, k, ivz)*w(&
&         i, j, k, irho)
        fs = dis2*ddw4 - dis4*(w(i, j, k+2, ivz)*w(i, j, k+2, irho)-w(i&
&         , j, k-1, ivz)*w(i, j, k-1, irho)-three*ddw4)
        fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fs
        fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
        ddw5 = w(i, j, k+1, irhoe) + p(i, j, k+1) - (w(i, j, k, irhoe)+p&
&         (i, j, k))
        fs = dis2*ddw5 - dis4*(w(i, j, k+2, irhoe)+p(i, j, k+2)-(w(i, j&
&         , k-1, irhoe)+p(i, j, k-1))-three*ddw5)
        fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + fs
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
      end do
    end if
  end subroutine invisciddissfluxscalar
 
!  differentiation of inviscidupwindflux in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: *p *w *fw
!   with respect to varying inputs: *p *w *fw
!   rw status of diff variables: *p:incr *w:incr *fw:in-out
!   plus diff mem management of: p:in w:in fw:in
  subroutine inviscidupwindflux_fast_b(finegrid)
!
!       inviscidupwindflux computes the artificial dissipation part of
!       the euler fluxes by means of an approximate solution of the 1d
!       riemann problem on the face. for first order schemes,
!       finegrid == .false., the states in the cells are assumed to
!       be constant; for the second order schemes on the fine grid a
!       nonlinear reconstruction of the left and right state is done
!       for which several options exist.
!       it is assumed that the pointers in blockpointers already
!       point to the correct block.
!
    use constants
    use blockpointers, only : il, jl, kl, ie, je, ke, ib, jb, kb,&
&   w, wd, p, pd, pori, porj, pork, fw, fwd, gamma, si, sj, sk, &
&   indfamilyi, indfamilyj, indfamilyk, spectralsol, addgridvelocities, &
&   sfacei, sfacej, sfacek, rotmatrixi, rotmatrixj, rotmatrixk, &
&   factfamilyi, factfamilyj, factfamilyk
    use flowvarrefstate, only : kpresent, nw, nwf, rgas, tref
    use inputdiscretization, only : limiter, lumpeddiss, precond, &
&   riemann, riemanncoarse, orderturb, kappacoef
    use inputphysics, only : equations
    use iteration, only : rfil, currentlevel, groundlevel
    use cgnsgrid, only : massflowfamilydiss
    use utils_fast_b, only : getcorrectfork, terminate
    use flowutils_fast_b, only : etot, etot_fast_b
    implicit none
!
!      subroutine arguments.
!
    logical, intent(in) :: finegrid
!
!      local variables.
!
    integer(kind=portype) :: por
    integer(kind=inttype) :: nwint
    integer(kind=inttype) :: i, j, k, ind
    integer(kind=inttype) :: limused, riemannused
    real(kind=realtype) :: sx, sy, sz, omk, opk, sfil, gammaface
    real(kind=realtype) :: factminmod, sface
    real(kind=realtype), dimension(nw) :: left, right
    real(kind=realtype), dimension(nw) :: leftd, rightd
    real(kind=realtype), dimension(nw) :: du1, du2, du3
    real(kind=realtype), dimension(nw) :: du1d, du2d, du3d
    real(kind=realtype), dimension(nwf) :: flux
    real(kind=realtype), dimension(nwf) :: fluxd
    logical :: firstorderk, correctfork, rotationalperiodic
    intrinsic abs
    intrinsic associated
    intrinsic max
    real(kind=realtype) :: abs0
    real(realtype) :: max1
    integer :: branch
    if (rfil .ge. 0.) then
      abs0 = rfil
    else
      abs0 = -rfil
    end if
!
! check if rfil == 0. if so, the dissipative flux needs not to
! be computed.
    if (abs0 .ge. thresholdreal) then
! check if the formulation for rotational periodic problems
! must be used.
      if (associated(rotmatrixi)) then
        rotationalperiodic = .true.
      else
        rotationalperiodic = .false.
      end if
! initialize the dissipative residual to a certain times,
! possibly zero, the previously stored value. owned cells
! only, because the halo values do not matter.
      sfil = one - rfil
! determine whether or not the total energy must be corrected
! for the presence of the turbulent kinetic energy.
      correctfork = getcorrectfork()
      if (1.e-10_realtype .lt. one - kappacoef) then
        max1 = one - kappacoef
      else
        max1 = 1.e-10_realtype
      end if
! compute the factor used in the minmod limiter.
      factminmod = (three-kappacoef)/max1
! determine the limiter scheme to be used. on the fine grid the
! user specified scheme is used; on the coarse grid a first order
! scheme is computed.
      limused = firstorder
      if (finegrid) limused = limiter
! lumped diss is true for doing approx pc
      if (lumpeddiss) limused = firstorder
! determine the riemann solver which must be used.
      riemannused = riemanncoarse
      if (finegrid) riemannused = riemann
! store 1-kappa and 1+kappa a bit easier and multiply it by 0.25.
      omk = fourth*(one-kappacoef)
      opk = fourth*(one+kappacoef)
! initialize sface to zero. this value will be used if the
! block is not moving.
      sface = zero
! set the number of variables to be interpolated depending
! whether or not a k-equation is present. if a k-equation is
! present also set the logical firstorderk. this indicates
! whether or not only a first order approximation is to be used
! for the turbulent kinetic energy.
      if (correctfork) then
        if (orderturb .eq. firstorder) then
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          nwint = nwf
          firstorderk = .true.
        else
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          nwint = itu1
          firstorderk = .false.
        end if
      else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        nwint = nwf
        firstorderk = .false.
      end if
!
!       flux computation. a distinction is made between first and
!       second order schemes to avoid the overhead for the first order
!       scheme.
!
      if (limused .eq. firstorder) then
!
!         first order reconstruction. the states in the cells are
!         constant. the left and right states are constructed easily.
!
! fluxes in the i-direction.
        do k=2,kl
          do j=2,jl
            do i=1,il
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = si(i, j, k, 1)
              sy = si(i, j, k, 2)
              sz = si(i, j, k, 3)
              if (addgridvelocities) then
                sface = sfacei(i, j, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
! determine the left and right state.
              left(irho) = w(i, j, k, irho)
              left(ivx) = w(i, j, k, ivx)
              left(ivy) = w(i, j, k, ivy)
              left(ivz) = w(i, j, k, ivz)
              left(irhoe) = p(i, j, k)
              if (correctfork) then
                left(itu1) = w(i, j, k, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
              right(irho) = w(i+1, j, k, irho)
              right(ivx) = w(i+1, j, k, ivx)
              right(ivy) = w(i+1, j, k, ivy)
              right(ivz) = w(i+1, j, k, ivz)
              right(irhoe) = p(i+1, j, k)
              if (correctfork) then
                right(itu1) = w(i+1, j, k, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
            end do
          end do
        end do
! fluxes in j-direction.
        do k=2,kl
          do j=1,jl
            do i=2,il
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = sj(i, j, k, 1)
              sy = sj(i, j, k, 2)
              sz = sj(i, j, k, 3)
              if (addgridvelocities) then
                sface = sfacej(i, j, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
! determine the left and right state.
              left(irho) = w(i, j, k, irho)
              left(ivx) = w(i, j, k, ivx)
              left(ivy) = w(i, j, k, ivy)
              left(ivz) = w(i, j, k, ivz)
              left(irhoe) = p(i, j, k)
              if (correctfork) then
                left(itu1) = w(i, j, k, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
              right(irho) = w(i, j+1, k, irho)
              right(ivx) = w(i, j+1, k, ivx)
              right(ivy) = w(i, j+1, k, ivy)
              right(ivz) = w(i, j+1, k, ivz)
              right(irhoe) = p(i, j+1, k)
              if (correctfork) then
                right(itu1) = w(i, j+1, k, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
            end do
          end do
        end do
! fluxes in k-direction.
        do k=1,kl
          do j=2,jl
            do i=2,il
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = sk(i, j, k, 1)
              sy = sk(i, j, k, 2)
              sz = sk(i, j, k, 3)
              if (addgridvelocities) then
                sface = sfacek(i, j, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
! determine the left and right state.
              left(irho) = w(i, j, k, irho)
              left(ivx) = w(i, j, k, ivx)
              left(ivy) = w(i, j, k, ivy)
              left(ivz) = w(i, j, k, ivz)
              left(irhoe) = p(i, j, k)
              if (correctfork) then
                left(itu1) = w(i, j, k, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
              right(irho) = w(i, j, k+1, irho)
              right(ivx) = w(i, j, k+1, ivx)
              right(ivy) = w(i, j, k+1, ivy)
              right(ivz) = w(i, j, k+1, ivz)
              right(irhoe) = p(i, j, k+1)
              if (correctfork) then
                right(itu1) = w(i, j, k+1, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
            end do
          end do
        end do
        fluxd = 0.0_8
        leftd = 0.0_8
        rightd = 0.0_8
        do k=kl,1,-1
          do j=jl,2,-1
            do i=il,2,-1
              fluxd(irhoe) = fluxd(irhoe) - fwd(i, j, k+1, irhoe)
              fluxd(imz) = fluxd(imz) - fwd(i, j, k+1, imz)
              fluxd(imy) = fluxd(imy) - fwd(i, j, k+1, imy)
              fluxd(imx) = fluxd(imx) - fwd(i, j, k+1, imx)
              fluxd(irho) = fluxd(irho) - fwd(i, j, k+1, irho)
              fluxd(irhoe) = fluxd(irhoe) + fwd(i, j, k, irhoe)
              fluxd(imz) = fluxd(imz) + fwd(i, j, k, imz)
              fluxd(imy) = fluxd(imy) + fwd(i, j, k, imy)
              fluxd(imx) = fluxd(imx) + fwd(i, j, k, imx)
              fluxd(irho) = fluxd(irho) + fwd(i, j, k, irho)
              gammaface = half*(gamma(i, j, k)+gamma(i, j, k+1))
              por = pork(i, j, k)
              call riemannflux_fast_b(left, leftd, right, rightd, flux, &
&                               fluxd)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i, j, k+1, itu1) = wd(i, j, k+1, itu1) + rightd(itu1)
                rightd(itu1) = 0.0_8
              end if
              pd(i, j, k+1) = pd(i, j, k+1) + rightd(irhoe)
              rightd(irhoe) = 0.0_8
              wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + rightd(ivz)
              rightd(ivz) = 0.0_8
              wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + rightd(ivy)
              rightd(ivy) = 0.0_8
              wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + rightd(ivx)
              rightd(ivx) = 0.0_8
              wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + rightd(irho)
              rightd(irho) = 0.0_8
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + leftd(itu1)
                leftd(itu1) = 0.0_8
              end if
              pd(i, j, k) = pd(i, j, k) + leftd(irhoe)
              leftd(irhoe) = 0.0_8
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + leftd(ivz)
              leftd(ivz) = 0.0_8
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + leftd(ivy)
              leftd(ivy) = 0.0_8
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + leftd(ivx)
              leftd(ivx) = 0.0_8
              wd(i, j, k, irho) = wd(i, j, k, irho) + leftd(irho)
              leftd(irho) = 0.0_8
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) call popreal8(sface)
            end do
          end do
        end do
        do k=kl,2,-1
          do j=jl,1,-1
            do i=il,2,-1
              fluxd(irhoe) = fluxd(irhoe) - fwd(i, j+1, k, irhoe)
              fluxd(imz) = fluxd(imz) - fwd(i, j+1, k, imz)
              fluxd(imy) = fluxd(imy) - fwd(i, j+1, k, imy)
              fluxd(imx) = fluxd(imx) - fwd(i, j+1, k, imx)
              fluxd(irho) = fluxd(irho) - fwd(i, j+1, k, irho)
              fluxd(irhoe) = fluxd(irhoe) + fwd(i, j, k, irhoe)
              fluxd(imz) = fluxd(imz) + fwd(i, j, k, imz)
              fluxd(imy) = fluxd(imy) + fwd(i, j, k, imy)
              fluxd(imx) = fluxd(imx) + fwd(i, j, k, imx)
              fluxd(irho) = fluxd(irho) + fwd(i, j, k, irho)
              gammaface = half*(gamma(i, j, k)+gamma(i, j+1, k))
              por = porj(i, j, k)
              call riemannflux_fast_b(left, leftd, right, rightd, flux, &
&                               fluxd)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i, j+1, k, itu1) = wd(i, j+1, k, itu1) + rightd(itu1)
                rightd(itu1) = 0.0_8
              end if
              pd(i, j+1, k) = pd(i, j+1, k) + rightd(irhoe)
              rightd(irhoe) = 0.0_8
              wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + rightd(ivz)
              rightd(ivz) = 0.0_8
              wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + rightd(ivy)
              rightd(ivy) = 0.0_8
              wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + rightd(ivx)
              rightd(ivx) = 0.0_8
              wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + rightd(irho)
              rightd(irho) = 0.0_8
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + leftd(itu1)
                leftd(itu1) = 0.0_8
              end if
              pd(i, j, k) = pd(i, j, k) + leftd(irhoe)
              leftd(irhoe) = 0.0_8
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + leftd(ivz)
              leftd(ivz) = 0.0_8
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + leftd(ivy)
              leftd(ivy) = 0.0_8
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + leftd(ivx)
              leftd(ivx) = 0.0_8
              wd(i, j, k, irho) = wd(i, j, k, irho) + leftd(irho)
              leftd(irho) = 0.0_8
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) call popreal8(sface)
            end do
          end do
        end do
        do k=kl,2,-1
          do j=jl,2,-1
            do i=il,1,-1
              fluxd(irhoe) = fluxd(irhoe) - fwd(i+1, j, k, irhoe)
              fluxd(imz) = fluxd(imz) - fwd(i+1, j, k, imz)
              fluxd(imy) = fluxd(imy) - fwd(i+1, j, k, imy)
              fluxd(imx) = fluxd(imx) - fwd(i+1, j, k, imx)
              fluxd(irho) = fluxd(irho) - fwd(i+1, j, k, irho)
              fluxd(irhoe) = fluxd(irhoe) + fwd(i, j, k, irhoe)
              fluxd(imz) = fluxd(imz) + fwd(i, j, k, imz)
              fluxd(imy) = fluxd(imy) + fwd(i, j, k, imy)
              fluxd(imx) = fluxd(imx) + fwd(i, j, k, imx)
              fluxd(irho) = fluxd(irho) + fwd(i, j, k, irho)
              gammaface = half*(gamma(i, j, k)+gamma(i+1, j, k))
              por = pori(i, j, k)
              call riemannflux_fast_b(left, leftd, right, rightd, flux, &
&                               fluxd)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i+1, j, k, itu1) = wd(i+1, j, k, itu1) + rightd(itu1)
                rightd(itu1) = 0.0_8
              end if
              pd(i+1, j, k) = pd(i+1, j, k) + rightd(irhoe)
              rightd(irhoe) = 0.0_8
              wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + rightd(ivz)
              rightd(ivz) = 0.0_8
              wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + rightd(ivy)
              rightd(ivy) = 0.0_8
              wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + rightd(ivx)
              rightd(ivx) = 0.0_8
              wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + rightd(irho)
              rightd(irho) = 0.0_8
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + leftd(itu1)
                leftd(itu1) = 0.0_8
              end if
              pd(i, j, k) = pd(i, j, k) + leftd(irhoe)
              leftd(irhoe) = 0.0_8
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + leftd(ivz)
              leftd(ivz) = 0.0_8
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + leftd(ivy)
              leftd(ivy) = 0.0_8
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + leftd(ivx)
              leftd(ivx) = 0.0_8
              wd(i, j, k, irho) = wd(i, j, k, irho) + leftd(irho)
              leftd(irho) = 0.0_8
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) call popreal8(sface)
            end do
          end do
        end do
      else
!      ==================================================================
!      ==================================================================
!
!         second order reconstruction of the left and right state.
!         the three differences used in the, possibly nonlinear,
!         interpolation are constructed here; the actual left and
!         right states, or at least the differences from the first
!         order interpolation, are computed in the subroutine
!         leftrightstate.
!
! fluxes in the i-direction.
        do k=2,kl
          do j=2,jl
            do i=1,il
! store the three differences used in the interpolation
! in du1, du2, du3.
              du1(irho) = w(i, j, k, irho) - w(i-1, j, k, irho)
              du2(irho) = w(i+1, j, k, irho) - w(i, j, k, irho)
              du3(irho) = w(i+2, j, k, irho) - w(i+1, j, k, irho)
              du1(ivx) = w(i, j, k, ivx) - w(i-1, j, k, ivx)
              du2(ivx) = w(i+1, j, k, ivx) - w(i, j, k, ivx)
              du3(ivx) = w(i+2, j, k, ivx) - w(i+1, j, k, ivx)
              du1(ivy) = w(i, j, k, ivy) - w(i-1, j, k, ivy)
              du2(ivy) = w(i+1, j, k, ivy) - w(i, j, k, ivy)
              du3(ivy) = w(i+2, j, k, ivy) - w(i+1, j, k, ivy)
              du1(ivz) = w(i, j, k, ivz) - w(i-1, j, k, ivz)
              du2(ivz) = w(i+1, j, k, ivz) - w(i, j, k, ivz)
              du3(ivz) = w(i+2, j, k, ivz) - w(i+1, j, k, ivz)
              du1(irhoe) = p(i, j, k) - p(i-1, j, k)
              du2(irhoe) = p(i+1, j, k) - p(i, j, k)
              du3(irhoe) = p(i+2, j, k) - p(i+1, j, k)
              if (correctfork) then
                du1(itu1) = w(i, j, k, itu1) - w(i-1, j, k, itu1)
                du2(itu1) = w(i+1, j, k, itu1) - w(i, j, k, itu1)
                du3(itu1) = w(i+2, j, k, itu1) - w(i+1, j, k, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
! compute the differences from the first order scheme.
              call leftrightstate(du1, du2, du3, rotmatrixi, left, right&
&                          )
! add the first order part to the currently stored
! differences, such that the correct state vector
! is stored.
              left(irho) = left(irho) + w(i, j, k, irho)
              left(ivx) = left(ivx) + w(i, j, k, ivx)
              left(ivy) = left(ivy) + w(i, j, k, ivy)
              left(ivz) = left(ivz) + w(i, j, k, ivz)
              left(irhoe) = left(irhoe) + p(i, j, k)
              right(irho) = right(irho) + w(i+1, j, k, irho)
              right(ivx) = right(ivx) + w(i+1, j, k, ivx)
              right(ivy) = right(ivy) + w(i+1, j, k, ivy)
              right(ivz) = right(ivz) + w(i+1, j, k, ivz)
              right(irhoe) = right(irhoe) + p(i+1, j, k)
              if (correctfork) then
                left(itu1) = left(itu1) + w(i, j, k, itu1)
                right(itu1) = right(itu1) + w(i+1, j, k, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = si(i, j, k, 1)
              sy = si(i, j, k, 2)
              sz = si(i, j, k, 3)
              if (addgridvelocities) then
                sface = sfacei(i, j, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
            end do
          end do
        end do
! fluxes in the j-direction.
        do k=2,kl
          do j=1,jl
            do i=2,il
! store the three differences used in the interpolation
! in du1, du2, du3.
              du1(irho) = w(i, j, k, irho) - w(i, j-1, k, irho)
              du2(irho) = w(i, j+1, k, irho) - w(i, j, k, irho)
              du3(irho) = w(i, j+2, k, irho) - w(i, j+1, k, irho)
              du1(ivx) = w(i, j, k, ivx) - w(i, j-1, k, ivx)
              du2(ivx) = w(i, j+1, k, ivx) - w(i, j, k, ivx)
              du3(ivx) = w(i, j+2, k, ivx) - w(i, j+1, k, ivx)
              du1(ivy) = w(i, j, k, ivy) - w(i, j-1, k, ivy)
              du2(ivy) = w(i, j+1, k, ivy) - w(i, j, k, ivy)
              du3(ivy) = w(i, j+2, k, ivy) - w(i, j+1, k, ivy)
              du1(ivz) = w(i, j, k, ivz) - w(i, j-1, k, ivz)
              du2(ivz) = w(i, j+1, k, ivz) - w(i, j, k, ivz)
              du3(ivz) = w(i, j+2, k, ivz) - w(i, j+1, k, ivz)
              du1(irhoe) = p(i, j, k) - p(i, j-1, k)
              du2(irhoe) = p(i, j+1, k) - p(i, j, k)
              du3(irhoe) = p(i, j+2, k) - p(i, j+1, k)
              if (correctfork) then
                du1(itu1) = w(i, j, k, itu1) - w(i, j-1, k, itu1)
                du2(itu1) = w(i, j+1, k, itu1) - w(i, j, k, itu1)
                du3(itu1) = w(i, j+2, k, itu1) - w(i, j+1, k, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
! compute the differences from the first order scheme.
              call leftrightstate(du1, du2, du3, rotmatrixj, left, right&
&                          )
! add the first order part to the currently stored
! differences, such that the correct state vector
! is stored.
              left(irho) = left(irho) + w(i, j, k, irho)
              left(ivx) = left(ivx) + w(i, j, k, ivx)
              left(ivy) = left(ivy) + w(i, j, k, ivy)
              left(ivz) = left(ivz) + w(i, j, k, ivz)
              left(irhoe) = left(irhoe) + p(i, j, k)
              right(irho) = right(irho) + w(i, j+1, k, irho)
              right(ivx) = right(ivx) + w(i, j+1, k, ivx)
              right(ivy) = right(ivy) + w(i, j+1, k, ivy)
              right(ivz) = right(ivz) + w(i, j+1, k, ivz)
              right(irhoe) = right(irhoe) + p(i, j+1, k)
              if (correctfork) then
                left(itu1) = left(itu1) + w(i, j, k, itu1)
                right(itu1) = right(itu1) + w(i, j+1, k, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = sj(i, j, k, 1)
              sy = sj(i, j, k, 2)
              sz = sj(i, j, k, 3)
              if (addgridvelocities) then
                sface = sfacej(i, j, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
            end do
          end do
        end do
! fluxes in the k-direction.
        do k=1,kl
          do j=2,jl
            do i=2,il
! store the three differences used in the interpolation
! in du1, du2, du3.
              du1(irho) = w(i, j, k, irho) - w(i, j, k-1, irho)
              du2(irho) = w(i, j, k+1, irho) - w(i, j, k, irho)
              du3(irho) = w(i, j, k+2, irho) - w(i, j, k+1, irho)
              du1(ivx) = w(i, j, k, ivx) - w(i, j, k-1, ivx)
              du2(ivx) = w(i, j, k+1, ivx) - w(i, j, k, ivx)
              du3(ivx) = w(i, j, k+2, ivx) - w(i, j, k+1, ivx)
              du1(ivy) = w(i, j, k, ivy) - w(i, j, k-1, ivy)
              du2(ivy) = w(i, j, k+1, ivy) - w(i, j, k, ivy)
              du3(ivy) = w(i, j, k+2, ivy) - w(i, j, k+1, ivy)
              du1(ivz) = w(i, j, k, ivz) - w(i, j, k-1, ivz)
              du2(ivz) = w(i, j, k+1, ivz) - w(i, j, k, ivz)
              du3(ivz) = w(i, j, k+2, ivz) - w(i, j, k+1, ivz)
              du1(irhoe) = p(i, j, k) - p(i, j, k-1)
              du2(irhoe) = p(i, j, k+1) - p(i, j, k)
              du3(irhoe) = p(i, j, k+2) - p(i, j, k+1)
              if (correctfork) then
                du1(itu1) = w(i, j, k, itu1) - w(i, j, k-1, itu1)
                du2(itu1) = w(i, j, k+1, itu1) - w(i, j, k, itu1)
                du3(itu1) = w(i, j, k+2, itu1) - w(i, j, k+1, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
! compute the differences from the first order scheme.
              call leftrightstate(du1, du2, du3, rotmatrixk, left, right&
&                          )
! add the first order part to the currently stored
! differences, such that the correct state vector
! is stored.
              left(irho) = left(irho) + w(i, j, k, irho)
              left(ivx) = left(ivx) + w(i, j, k, ivx)
              left(ivy) = left(ivy) + w(i, j, k, ivy)
              left(ivz) = left(ivz) + w(i, j, k, ivz)
              left(irhoe) = left(irhoe) + p(i, j, k)
              right(irho) = right(irho) + w(i, j, k+1, irho)
              right(ivx) = right(ivx) + w(i, j, k+1, ivx)
              right(ivy) = right(ivy) + w(i, j, k+1, ivy)
              right(ivz) = right(ivz) + w(i, j, k+1, ivz)
              right(irhoe) = right(irhoe) + p(i, j, k+1)
              if (correctfork) then
                left(itu1) = left(itu1) + w(i, j, k, itu1)
                right(itu1) = right(itu1) + w(i, j, k+1, itu1)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = sk(i, j, k, 1)
              sy = sk(i, j, k, 2)
              sz = sk(i, j, k, 3)
              if (addgridvelocities) then
                sface = sfacek(i, j, k)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
              else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
              end if
            end do
          end do
        end do
        fluxd = 0.0_8
        leftd = 0.0_8
        rightd = 0.0_8
        du1d = 0.0_8
        du2d = 0.0_8
        du3d = 0.0_8
        do k=kl,1,-1
          do j=jl,2,-1
            do i=il,2,-1
              fluxd(irhoe) = fluxd(irhoe) - fwd(i, j, k+1, irhoe)
              fluxd(imz) = fluxd(imz) - fwd(i, j, k+1, imz)
              fluxd(imy) = fluxd(imy) - fwd(i, j, k+1, imy)
              fluxd(imx) = fluxd(imx) - fwd(i, j, k+1, imx)
              fluxd(irho) = fluxd(irho) - fwd(i, j, k+1, irho)
              fluxd(irhoe) = fluxd(irhoe) + fwd(i, j, k, irhoe)
              fluxd(imz) = fluxd(imz) + fwd(i, j, k, imz)
              fluxd(imy) = fluxd(imy) + fwd(i, j, k, imy)
              fluxd(imx) = fluxd(imx) + fwd(i, j, k, imx)
              fluxd(irho) = fluxd(irho) + fwd(i, j, k, irho)
              gammaface = half*(gamma(i, j, k)+gamma(i, j, k+1))
              por = pork(i, j, k)
              call riemannflux_fast_b(left, leftd, right, rightd, flux, &
&                               fluxd)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) call popreal8(sface)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i, j, k+1, itu1) = wd(i, j, k+1, itu1) + rightd(itu1)
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + leftd(itu1)
              end if
              pd(i, j, k+1) = pd(i, j, k+1) + rightd(irhoe)
              wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + rightd(ivz)
              wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + rightd(ivy)
              wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + rightd(ivx)
              wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + rightd(irho)
              pd(i, j, k) = pd(i, j, k) + leftd(irhoe)
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + leftd(ivz)
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + leftd(ivy)
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + leftd(ivx)
              wd(i, j, k, irho) = wd(i, j, k, irho) + leftd(irho)
              call leftrightstate_fast_b(du1, du1d, du2, du2d, du3, du3d&
&                                  , rotmatrixk, left, leftd, right, &
&                                  rightd)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i, j, k+2, itu1) = wd(i, j, k+2, itu1) + du3d(itu1)
                wd(i, j, k+1, itu1) = wd(i, j, k+1, itu1) + du2d(itu1) -&
&                 du3d(itu1)
                du3d(itu1) = 0.0_8
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + du1d(itu1) - &
&                 du2d(itu1)
                du2d(itu1) = 0.0_8
                wd(i, j, k-1, itu1) = wd(i, j, k-1, itu1) - du1d(itu1)
                du1d(itu1) = 0.0_8
              end if
              pd(i, j, k+2) = pd(i, j, k+2) + du3d(irhoe)
              pd(i, j, k+1) = pd(i, j, k+1) + du2d(irhoe) - du3d(irhoe)
              du3d(irhoe) = 0.0_8
              pd(i, j, k) = pd(i, j, k) + du1d(irhoe) - du2d(irhoe)
              du2d(irhoe) = 0.0_8
              pd(i, j, k-1) = pd(i, j, k-1) - du1d(irhoe)
              du1d(irhoe) = 0.0_8
              wd(i, j, k+2, ivz) = wd(i, j, k+2, ivz) + du3d(ivz)
              wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + du2d(ivz) - du3d&
&               (ivz)
              du3d(ivz) = 0.0_8
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + du1d(ivz) - du2d(ivz&
&               )
              du2d(ivz) = 0.0_8
              wd(i, j, k-1, ivz) = wd(i, j, k-1, ivz) - du1d(ivz)
              du1d(ivz) = 0.0_8
              wd(i, j, k+2, ivy) = wd(i, j, k+2, ivy) + du3d(ivy)
              wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + du2d(ivy) - du3d&
&               (ivy)
              du3d(ivy) = 0.0_8
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + du1d(ivy) - du2d(ivy&
&               )
              du2d(ivy) = 0.0_8
              wd(i, j, k-1, ivy) = wd(i, j, k-1, ivy) - du1d(ivy)
              du1d(ivy) = 0.0_8
              wd(i, j, k+2, ivx) = wd(i, j, k+2, ivx) + du3d(ivx)
              wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + du2d(ivx) - du3d&
&               (ivx)
              du3d(ivx) = 0.0_8
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + du1d(ivx) - du2d(ivx&
&               )
              du2d(ivx) = 0.0_8
              wd(i, j, k-1, ivx) = wd(i, j, k-1, ivx) - du1d(ivx)
              du1d(ivx) = 0.0_8
              wd(i, j, k+2, irho) = wd(i, j, k+2, irho) + du3d(irho)
              wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + du2d(irho) - &
&               du3d(irho)
              du3d(irho) = 0.0_8
              wd(i, j, k, irho) = wd(i, j, k, irho) + du1d(irho) - du2d(&
&               irho)
              du2d(irho) = 0.0_8
              wd(i, j, k-1, irho) = wd(i, j, k-1, irho) - du1d(irho)
              du1d(irho) = 0.0_8
            end do
          end do
        end do
        do k=kl,2,-1
          do j=jl,1,-1
            do i=il,2,-1
              fluxd(irhoe) = fluxd(irhoe) - fwd(i, j+1, k, irhoe)
              fluxd(imz) = fluxd(imz) - fwd(i, j+1, k, imz)
              fluxd(imy) = fluxd(imy) - fwd(i, j+1, k, imy)
              fluxd(imx) = fluxd(imx) - fwd(i, j+1, k, imx)
              fluxd(irho) = fluxd(irho) - fwd(i, j+1, k, irho)
              fluxd(irhoe) = fluxd(irhoe) + fwd(i, j, k, irhoe)
              fluxd(imz) = fluxd(imz) + fwd(i, j, k, imz)
              fluxd(imy) = fluxd(imy) + fwd(i, j, k, imy)
              fluxd(imx) = fluxd(imx) + fwd(i, j, k, imx)
              fluxd(irho) = fluxd(irho) + fwd(i, j, k, irho)
              gammaface = half*(gamma(i, j, k)+gamma(i, j+1, k))
              por = porj(i, j, k)
              call riemannflux_fast_b(left, leftd, right, rightd, flux, &
&                               fluxd)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) call popreal8(sface)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i, j+1, k, itu1) = wd(i, j+1, k, itu1) + rightd(itu1)
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + leftd(itu1)
              end if
              pd(i, j+1, k) = pd(i, j+1, k) + rightd(irhoe)
              wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + rightd(ivz)
              wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + rightd(ivy)
              wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + rightd(ivx)
              wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + rightd(irho)
              pd(i, j, k) = pd(i, j, k) + leftd(irhoe)
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + leftd(ivz)
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + leftd(ivy)
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + leftd(ivx)
              wd(i, j, k, irho) = wd(i, j, k, irho) + leftd(irho)
              call leftrightstate_fast_b(du1, du1d, du2, du2d, du3, du3d&
&                                  , rotmatrixj, left, leftd, right, &
&                                  rightd)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i, j+2, k, itu1) = wd(i, j+2, k, itu1) + du3d(itu1)
                wd(i, j+1, k, itu1) = wd(i, j+1, k, itu1) + du2d(itu1) -&
&                 du3d(itu1)
                du3d(itu1) = 0.0_8
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + du1d(itu1) - &
&                 du2d(itu1)
                du2d(itu1) = 0.0_8
                wd(i, j-1, k, itu1) = wd(i, j-1, k, itu1) - du1d(itu1)
                du1d(itu1) = 0.0_8
              end if
              pd(i, j+2, k) = pd(i, j+2, k) + du3d(irhoe)
              pd(i, j+1, k) = pd(i, j+1, k) + du2d(irhoe) - du3d(irhoe)
              du3d(irhoe) = 0.0_8
              pd(i, j, k) = pd(i, j, k) + du1d(irhoe) - du2d(irhoe)
              du2d(irhoe) = 0.0_8
              pd(i, j-1, k) = pd(i, j-1, k) - du1d(irhoe)
              du1d(irhoe) = 0.0_8
              wd(i, j+2, k, ivz) = wd(i, j+2, k, ivz) + du3d(ivz)
              wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + du2d(ivz) - du3d&
&               (ivz)
              du3d(ivz) = 0.0_8
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + du1d(ivz) - du2d(ivz&
&               )
              du2d(ivz) = 0.0_8
              wd(i, j-1, k, ivz) = wd(i, j-1, k, ivz) - du1d(ivz)
              du1d(ivz) = 0.0_8
              wd(i, j+2, k, ivy) = wd(i, j+2, k, ivy) + du3d(ivy)
              wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + du2d(ivy) - du3d&
&               (ivy)
              du3d(ivy) = 0.0_8
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + du1d(ivy) - du2d(ivy&
&               )
              du2d(ivy) = 0.0_8
              wd(i, j-1, k, ivy) = wd(i, j-1, k, ivy) - du1d(ivy)
              du1d(ivy) = 0.0_8
              wd(i, j+2, k, ivx) = wd(i, j+2, k, ivx) + du3d(ivx)
              wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + du2d(ivx) - du3d&
&               (ivx)
              du3d(ivx) = 0.0_8
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + du1d(ivx) - du2d(ivx&
&               )
              du2d(ivx) = 0.0_8
              wd(i, j-1, k, ivx) = wd(i, j-1, k, ivx) - du1d(ivx)
              du1d(ivx) = 0.0_8
              wd(i, j+2, k, irho) = wd(i, j+2, k, irho) + du3d(irho)
              wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + du2d(irho) - &
&               du3d(irho)
              du3d(irho) = 0.0_8
              wd(i, j, k, irho) = wd(i, j, k, irho) + du1d(irho) - du2d(&
&               irho)
              du2d(irho) = 0.0_8
              wd(i, j-1, k, irho) = wd(i, j-1, k, irho) - du1d(irho)
              du1d(irho) = 0.0_8
            end do
          end do
        end do
        do k=kl,2,-1
          do j=jl,2,-1
            do i=il,1,-1
              fluxd(irhoe) = fluxd(irhoe) - fwd(i+1, j, k, irhoe)
              fluxd(imz) = fluxd(imz) - fwd(i+1, j, k, imz)
              fluxd(imy) = fluxd(imy) - fwd(i+1, j, k, imy)
              fluxd(imx) = fluxd(imx) - fwd(i+1, j, k, imx)
              fluxd(irho) = fluxd(irho) - fwd(i+1, j, k, irho)
              fluxd(irhoe) = fluxd(irhoe) + fwd(i, j, k, irhoe)
              fluxd(imz) = fluxd(imz) + fwd(i, j, k, imz)
              fluxd(imy) = fluxd(imy) + fwd(i, j, k, imy)
              fluxd(imx) = fluxd(imx) + fwd(i, j, k, imx)
              fluxd(irho) = fluxd(irho) + fwd(i, j, k, irho)
              gammaface = half*(gamma(i, j, k)+gamma(i+1, j, k))
              por = pori(i, j, k)
              call riemannflux_fast_b(left, leftd, right, rightd, flux, &
&                               fluxd)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) call popreal8(sface)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i+1, j, k, itu1) = wd(i+1, j, k, itu1) + rightd(itu1)
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + leftd(itu1)
              end if
              pd(i+1, j, k) = pd(i+1, j, k) + rightd(irhoe)
              wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + rightd(ivz)
              wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + rightd(ivy)
              wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + rightd(ivx)
              wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + rightd(irho)
              pd(i, j, k) = pd(i, j, k) + leftd(irhoe)
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + leftd(ivz)
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + leftd(ivy)
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + leftd(ivx)
              wd(i, j, k, irho) = wd(i, j, k, irho) + leftd(irho)
              call leftrightstate_fast_b(du1, du1d, du2, du2d, du3, du3d&
&                                  , rotmatrixi, left, leftd, right, &
&                                  rightd)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
              if (branch .eq. 0) then
                wd(i+2, j, k, itu1) = wd(i+2, j, k, itu1) + du3d(itu1)
                wd(i+1, j, k, itu1) = wd(i+1, j, k, itu1) + du2d(itu1) -&
&                 du3d(itu1)
                du3d(itu1) = 0.0_8
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + du1d(itu1) - &
&                 du2d(itu1)
                du2d(itu1) = 0.0_8
                wd(i-1, j, k, itu1) = wd(i-1, j, k, itu1) - du1d(itu1)
                du1d(itu1) = 0.0_8
              end if
              pd(i+2, j, k) = pd(i+2, j, k) + du3d(irhoe)
              pd(i+1, j, k) = pd(i+1, j, k) + du2d(irhoe) - du3d(irhoe)
              du3d(irhoe) = 0.0_8
              pd(i, j, k) = pd(i, j, k) + du1d(irhoe) - du2d(irhoe)
              du2d(irhoe) = 0.0_8
              pd(i-1, j, k) = pd(i-1, j, k) - du1d(irhoe)
              du1d(irhoe) = 0.0_8
              wd(i+2, j, k, ivz) = wd(i+2, j, k, ivz) + du3d(ivz)
              wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + du2d(ivz) - du3d&
&               (ivz)
              du3d(ivz) = 0.0_8
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + du1d(ivz) - du2d(ivz&
&               )
              du2d(ivz) = 0.0_8
              wd(i-1, j, k, ivz) = wd(i-1, j, k, ivz) - du1d(ivz)
              du1d(ivz) = 0.0_8
              wd(i+2, j, k, ivy) = wd(i+2, j, k, ivy) + du3d(ivy)
              wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + du2d(ivy) - du3d&
&               (ivy)
              du3d(ivy) = 0.0_8
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + du1d(ivy) - du2d(ivy&
&               )
              du2d(ivy) = 0.0_8
              wd(i-1, j, k, ivy) = wd(i-1, j, k, ivy) - du1d(ivy)
              du1d(ivy) = 0.0_8
              wd(i+2, j, k, ivx) = wd(i+2, j, k, ivx) + du3d(ivx)
              wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + du2d(ivx) - du3d&
&               (ivx)
              du3d(ivx) = 0.0_8
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + du1d(ivx) - du2d(ivx&
&               )
              du2d(ivx) = 0.0_8
              wd(i-1, j, k, ivx) = wd(i-1, j, k, ivx) - du1d(ivx)
              du1d(ivx) = 0.0_8
              wd(i+2, j, k, irho) = wd(i+2, j, k, irho) + du3d(irho)
              wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + du2d(irho) - &
&               du3d(irho)
              du3d(irho) = 0.0_8
              wd(i, j, k, irho) = wd(i, j, k, irho) + du1d(irho) - du2d(&
&               irho)
              du2d(irho) = 0.0_8
              wd(i-1, j, k, irho) = wd(i-1, j, k, irho) - du1d(irho)
              du1d(irho) = 0.0_8
            end do
          end do
        end do
      end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
      do k=kl,2,-1
        do j=jl,2,-1
          do i=il,2,-1
            fwd(i, j, k, irhoe) = sfil*fwd(i, j, k, irhoe)
            fwd(i, j, k, imz) = sfil*fwd(i, j, k, imz)
            fwd(i, j, k, imy) = sfil*fwd(i, j, k, imy)
            fwd(i, j, k, imx) = sfil*fwd(i, j, k, imx)
            fwd(i, j, k, irho) = sfil*fwd(i, j, k, irho)
          end do
        end do
      end do
    end if
 
  contains
!  differentiation of leftrightstate in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: left right du1 du2 du3
!   with respect to varying inputs: left right du1 du2 du3
!      ==================================================================
    subroutine leftrightstate_fast_b(du1, du1d, du2, du2d, du3, du3d, &
&     rotmatrix, left, leftd, right, rightd)
      implicit none
!
!        local parameter.
!
      real(kind=realtype), parameter :: epslim=1.e-10_realtype
!
!        subroutine arguments.
!
      real(kind=realtype), dimension(:), intent(inout) :: du1, du2, du3
      real(kind=realtype), dimension(:), intent(inout) :: du1d, du2d, &
&     du3d
      real(kind=realtype), dimension(:) :: left, right
      real(kind=realtype), dimension(:) :: leftd, rightd
      real(kind=realtype), dimension(:, :, :, :, :), pointer :: &
&     rotmatrix
!
!        local variables.
!
      integer(kind=inttype) :: l
      real(kind=realtype) :: rl1, rl2, rr1, rr2, tmp, dvx, dvy, dvz
      real(kind=realtype) :: rl1d, rl2d, rr1d, rr2d, tmpd, dvxd, dvyd, &
&     dvzd
      real(kind=realtype), dimension(3, 3) :: rot
      intrinsic abs
      intrinsic max
      intrinsic sign
      intrinsic min
      real(kind=realtype) :: x1
      real(kind=realtype) :: x1d
      real(kind=realtype) :: y1
      real(kind=realtype) :: y1d
      real(kind=realtype) :: y2
      real(kind=realtype) :: y2d
      real(kind=realtype) :: x2
      real(kind=realtype) :: x2d
      real(kind=realtype) :: y3
      real(kind=realtype) :: y3d
      real(kind=realtype) :: y4
      real(kind=realtype) :: y4d
      real(kind=realtype) :: x3
      real(kind=realtype) :: x3d
      real(kind=realtype) :: x4
      real(kind=realtype) :: x4d
      real(kind=realtype) :: x5
      real(kind=realtype) :: x5d
      real(kind=realtype) :: x6
      real(kind=realtype) :: x6d
      real(kind=realtype) :: max2
      real(kind=realtype) :: max2d
      real(kind=realtype) :: max3
      real(kind=realtype) :: max3d
      real(kind=realtype) :: max4
      real(kind=realtype) :: max4d
      real(kind=realtype) :: max5
      real(kind=realtype) :: max5d
      real(kind=realtype) :: max6
      real(kind=realtype) :: max6d
      real(kind=realtype) :: max7
      real(kind=realtype) :: max7d
      real(kind=realtype) :: temp
      real(kind=realtype) :: tempd
      integer :: branch
! check if the velocity components should be transformed to
! the cylindrical frame.
      if (rotationalperiodic) then
! store the rotation matrix a bit easier. note that the i,j,k
! come from the main subroutine.
        rot(1, 1) = rotmatrix(i, j, k, 1, 1)
        rot(1, 2) = rotmatrix(i, j, k, 1, 2)
        rot(1, 3) = rotmatrix(i, j, k, 1, 3)
        rot(2, 1) = rotmatrix(i, j, k, 2, 1)
        rot(2, 2) = rotmatrix(i, j, k, 2, 2)
        rot(2, 3) = rotmatrix(i, j, k, 2, 3)
        rot(3, 1) = rotmatrix(i, j, k, 3, 1)
        rot(3, 2) = rotmatrix(i, j, k, 3, 2)
        rot(3, 3) = rotmatrix(i, j, k, 3, 3)
! apply the transformation to the velocity components
! of du1, du2 and du3.
        dvx = du1(ivx)
        dvy = du1(ivy)
        dvz = du1(ivz)
        du1(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du1(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du1(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
        dvx = du2(ivx)
        dvy = du2(ivy)
        dvz = du2(ivz)
        du2(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du2(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du2(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
        dvx = du3(ivx)
        dvy = du3(ivy)
        dvz = du3(ivz)
        du3(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du3(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du3(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
myintptr = myintptr + 1
 myintstack(myintptr) = 0
      else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
      end if
! determine the limiter used.
      select case  (limused) 
      case (nolimiter) 
        call pushcontrol2b(1)
      case (vanalbeda) 
!          ==============================================================
! nonlinear interpolation using the van albeda limiter.
! loop over the number of variables to be interpolated.
        do l=1,nwint
          if (du2(l) .ge. 0.) then
            x1 = du2(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            x1 = -du2(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (x1 .lt. epslim) then
            max2 = epslim
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            max2 = x1
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
! compute the limiter argument rl1, rl2, rr1 and rr2.
! note the cut off to 0.0.
          tmp = one/sign(max2, du2(l))
          if (du1(l) .ge. 0.) then
            x3 = du1(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            x3 = -du1(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (x3 .lt. epslim) then
            max4 = epslim
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            max4 = x3
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          y1 = du2(l)/sign(max4, du1(l))
          if (zero .lt. y1) then
            rl1 = y1
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rl1 = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (zero .lt. du1(l)*tmp) then
            rl2 = du1(l)*tmp
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rl2 = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (zero .lt. du3(l)*tmp) then
            rr1 = du3(l)*tmp
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rr1 = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (du3(l) .ge. 0.) then
            x4 = du3(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            x4 = -du3(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (x4 .lt. epslim) then
            max5 = epslim
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            max5 = x4
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          y2 = du2(l)/sign(max5, du3(l))
          if (zero .lt. y2) then
            rr2 = y2
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rr2 = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
! compute the corresponding limiter values.
          rl1 = rl1*(rl1+one)/(rl1*rl1+one)
          rl2 = rl2*(rl2+one)/(rl2*rl2+one)
          rr1 = rr1*(rr1+one)/(rr1*rr1+one)
          rr2 = rr2*(rr2+one)/(rr2*rr2+one)
! compute the nonlinear corrections to the first order
! scheme.
        end do
        call pushcontrol2b(2)
      case (minmod) 
!          ==============================================================
! nonlinear interpolation using the minmod limiter.
! loop over the number of variables to be interpolated.
        do l=1,nwint
          if (du2(l) .ge. 0.) then
            x2 = du2(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            x2 = -du2(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (x2 .lt. epslim) then
            max3 = epslim
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            max3 = x2
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
! compute the limiter argument rl1, rl2, rr1 and rr2.
! note the cut off to 0.0.
          tmp = one/sign(max3, du2(l))
          if (du1(l) .ge. 0.) then
            x5 = du1(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            x5 = -du1(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (x5 .lt. epslim) then
            max6 = epslim
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            max6 = x5
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          y3 = du2(l)/sign(max6, du1(l))
          if (zero .lt. y3) then
            rl1 = y3
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rl1 = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (zero .lt. du1(l)*tmp) then
            rl2 = du1(l)*tmp
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rl2 = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (zero .lt. du3(l)*tmp) then
            rr1 = du3(l)*tmp
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rr1 = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (du3(l) .ge. 0.) then
            x6 = du3(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            x6 = -du3(l)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (x6 .lt. epslim) then
            max7 = epslim
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            max7 = x6
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          y4 = du2(l)/sign(max7, du3(l))
          if (zero .lt. y4) then
            rr2 = y4
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rr2 = zero
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (one .gt. factminmod*rl1) then
            rl1 = factminmod*rl1
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rl1 = one
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (one .gt. factminmod*rl2) then
            rl2 = factminmod*rl2
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rl2 = one
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (one .gt. factminmod*rr1) then
            rr1 = factminmod*rr1
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rr1 = one
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (one .gt. factminmod*rr2) then
            rr2 = factminmod*rr2
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            rr2 = one
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
        end do
        call pushcontrol2b(3)
      case default
        call pushcontrol2b(0)
      end select
! in case only a first order scheme must be used for the
! turbulent transport equations, set the correction for the
! turbulent kinetic energy to 0.
      if (firstorderk) then
myintptr = myintptr + 1
 myintstack(myintptr) = 0
      else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
      end if
! for rotational periodic problems transform the velocity
! differences back to cartesian again. note that now the
! transpose of the rotation matrix must be used.
      if (rotationalperiodic) then
        dvxd = rot(1, 3)*rightd(ivz)
        dvyd = rot(2, 3)*rightd(ivz)
        dvzd = rot(3, 3)*rightd(ivz)
        rightd(ivz) = 0.0_8
        dvxd = dvxd + rot(1, 2)*rightd(ivy)
        dvyd = dvyd + rot(2, 2)*rightd(ivy)
        dvzd = dvzd + rot(3, 2)*rightd(ivy)
        rightd(ivy) = 0.0_8
        dvxd = dvxd + rot(1, 1)*rightd(ivx)
        dvyd = dvyd + rot(2, 1)*rightd(ivx)
        dvzd = dvzd + rot(3, 1)*rightd(ivx)
        rightd(ivx) = 0.0_8
        rightd(ivz) = rightd(ivz) + dvzd
        rightd(ivy) = rightd(ivy) + dvyd
        rightd(ivx) = rightd(ivx) + dvxd
        dvxd = rot(1, 3)*leftd(ivz)
        dvyd = rot(2, 3)*leftd(ivz)
        dvzd = rot(3, 3)*leftd(ivz)
        leftd(ivz) = 0.0_8
        dvxd = dvxd + rot(1, 2)*leftd(ivy)
        dvyd = dvyd + rot(2, 2)*leftd(ivy)
        dvzd = dvzd + rot(3, 2)*leftd(ivy)
        leftd(ivy) = 0.0_8
        dvxd = dvxd + rot(1, 1)*leftd(ivx)
        dvyd = dvyd + rot(2, 1)*leftd(ivx)
        dvzd = dvzd + rot(3, 1)*leftd(ivx)
        leftd(ivx) = 0.0_8
        leftd(ivz) = leftd(ivz) + dvzd
        leftd(ivy) = leftd(ivy) + dvyd
        leftd(ivx) = leftd(ivx) + dvxd
      end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
      if (branch .eq. 0) then
        rightd(itu1) = 0.0_8
        leftd(itu1) = 0.0_8
      end if
      call popcontrol2b(branch)
      if (branch .lt. 2) then
        if (branch .ne. 0) then
          do l=nwint,1,-1
            du3d(l) = du3d(l) - omk*rightd(l)
            du2d(l) = du2d(l) + opk*leftd(l) - opk*rightd(l)
            rightd(l) = 0.0_8
            du1d(l) = du1d(l) + omk*leftd(l)
            leftd(l) = 0.0_8
          end do
        end if
      else if (branch .eq. 2) then
        do l=nwint,1,-1
          rr1d = -(du2(l)*opk*rightd(l))
          du2d(l) = du2d(l) + rl2*opk*leftd(l) - rr1*opk*rightd(l)
          rr2d = -(du3(l)*omk*rightd(l))
          du3d(l) = du3d(l) - rr2*omk*rightd(l)
          rightd(l) = 0.0_8
          rl1d = du1(l)*omk*leftd(l)
          du1d(l) = du1d(l) + rl1*omk*leftd(l)
          rl2d = du2(l)*opk*leftd(l)
          leftd(l) = 0.0_8
          tempd = rr2d/(one+rr2**2)
          rr2d = (one+2*rr2-2*rr2**2*(one+rr2)/(one+rr2**2))*tempd
          tempd = rr1d/(one+rr1**2)
          rr1d = (one+2*rr1-2*rr1**2*(one+rr1)/(one+rr1**2))*tempd
          tempd = rl2d/(one+rl2**2)
          rl2d = (one+2*rl2-2*rl2**2*(one+rl2)/(one+rl2**2))*tempd
          tempd = rl1d/(one+rl1**2)
          rl1d = (one+2*rl1-2*rl1**2*(one+rl1)/(one+rl1**2))*tempd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            y2d = rr2d
          else
            y2d = 0.0_8
          end if
          temp = sign(max5, du3(l))
          du2d(l) = du2d(l) + y2d/temp
          tempd = -(du2(l)*y2d/temp**2)
          max5d = sign(1.d0, max5*du3(l))*tempd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            x4d = 0.0_8
          else
            x4d = max5d
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            du3d(l) = du3d(l) + x4d
          else
            du3d(l) = du3d(l) - x4d
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            du3d(l) = du3d(l) + tmp*rr1d
            tmpd = du3(l)*rr1d
          else
            tmpd = 0.0_8
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            du1d(l) = du1d(l) + tmp*rl2d
            tmpd = tmpd + du1(l)*rl2d
          else
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            y1d = rl1d
          else
            y1d = 0.0_8
          end if
          temp = sign(max4, du1(l))
          du2d(l) = du2d(l) + y1d/temp
          tempd = -(du2(l)*y1d/temp**2)
          max4d = sign(1.d0, max4*du1(l))*tempd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            x3d = 0.0_8
          else
            x3d = max4d
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            du1d(l) = du1d(l) + x3d
          else
            du1d(l) = du1d(l) - x3d
          end if
          temp = sign(max2, du2(l))
          tempd = -(one*tmpd/temp**2)
          max2d = sign(1.d0, max2*du2(l))*tempd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            x1d = 0.0_8
          else
            x1d = max2d
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            du2d(l) = du2d(l) + x1d
          else
            du2d(l) = du2d(l) - x1d
          end if
        end do
      else
        do l=nwint,1,-1
          rr1d = -(du2(l)*opk*rightd(l))
          du2d(l) = du2d(l) + rl2*opk*leftd(l) - rr1*opk*rightd(l)
          rr2d = -(du3(l)*omk*rightd(l))
          du3d(l) = du3d(l) - rr2*omk*rightd(l)
          rightd(l) = 0.0_8
          rl1d = du1(l)*omk*leftd(l)
          du1d(l) = du1d(l) + rl1*omk*leftd(l)
          rl2d = du2(l)*opk*leftd(l)
          leftd(l) = 0.0_8
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            rr2d = factminmod*rr2d
          else
            rr2d = 0.0_8
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            rr1d = factminmod*rr1d
          else
            rr1d = 0.0_8
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            rl2d = factminmod*rl2d
          else
            rl2d = 0.0_8
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            rl1d = factminmod*rl1d
          else
            rl1d = 0.0_8
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            y4d = rr2d
          else
            y4d = 0.0_8
          end if
          temp = sign(max7, du3(l))
          du2d(l) = du2d(l) + y4d/temp
          tempd = -(du2(l)*y4d/temp**2)
          max7d = sign(1.d0, max7*du3(l))*tempd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            x6d = 0.0_8
          else
            x6d = max7d
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            du3d(l) = du3d(l) + x6d
          else
            du3d(l) = du3d(l) - x6d
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            du3d(l) = du3d(l) + tmp*rr1d
            tmpd = du3(l)*rr1d
          else
            tmpd = 0.0_8
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            du1d(l) = du1d(l) + tmp*rl2d
            tmpd = tmpd + du1(l)*rl2d
          else
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            y3d = rl1d
          else
            y3d = 0.0_8
          end if
          temp = sign(max6, du1(l))
          du2d(l) = du2d(l) + y3d/temp
          tempd = -(du2(l)*y3d/temp**2)
          max6d = sign(1.d0, max6*du1(l))*tempd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            x5d = 0.0_8
          else
            x5d = max6d
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            du1d(l) = du1d(l) + x5d
          else
            du1d(l) = du1d(l) - x5d
          end if
          temp = sign(max3, du2(l))
          tempd = -(one*tmpd/temp**2)
          max3d = sign(1.d0, max3*du2(l))*tempd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            x2d = 0.0_8
          else
            x2d = max3d
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            du2d(l) = du2d(l) + x2d
          else
            du2d(l) = du2d(l) - x2d
          end if
        end do
      end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
      if (branch .eq. 0) then
        dvxd = rot(3, 1)*du3d(ivz)
        dvyd = rot(3, 2)*du3d(ivz)
        dvzd = rot(3, 3)*du3d(ivz)
        du3d(ivz) = 0.0_8
        dvxd = dvxd + rot(2, 1)*du3d(ivy)
        dvyd = dvyd + rot(2, 2)*du3d(ivy)
        dvzd = dvzd + rot(2, 3)*du3d(ivy)
        du3d(ivy) = 0.0_8
        dvxd = dvxd + rot(1, 1)*du3d(ivx)
        dvyd = dvyd + rot(1, 2)*du3d(ivx)
        dvzd = dvzd + rot(1, 3)*du3d(ivx)
        du3d(ivx) = 0.0_8
        du3d(ivz) = du3d(ivz) + dvzd
        du3d(ivy) = du3d(ivy) + dvyd
        du3d(ivx) = du3d(ivx) + dvxd
        dvxd = rot(3, 1)*du2d(ivz)
        dvyd = rot(3, 2)*du2d(ivz)
        dvzd = rot(3, 3)*du2d(ivz)
        du2d(ivz) = 0.0_8
        dvxd = dvxd + rot(2, 1)*du2d(ivy)
        dvyd = dvyd + rot(2, 2)*du2d(ivy)
        dvzd = dvzd + rot(2, 3)*du2d(ivy)
        du2d(ivy) = 0.0_8
        dvxd = dvxd + rot(1, 1)*du2d(ivx)
        dvyd = dvyd + rot(1, 2)*du2d(ivx)
        dvzd = dvzd + rot(1, 3)*du2d(ivx)
        du2d(ivx) = 0.0_8
        du2d(ivz) = du2d(ivz) + dvzd
        du2d(ivy) = du2d(ivy) + dvyd
        du2d(ivx) = du2d(ivx) + dvxd
        dvxd = rot(3, 1)*du1d(ivz)
        dvyd = rot(3, 2)*du1d(ivz)
        dvzd = rot(3, 3)*du1d(ivz)
        du1d(ivz) = 0.0_8
        dvxd = dvxd + rot(2, 1)*du1d(ivy)
        dvyd = dvyd + rot(2, 2)*du1d(ivy)
        dvzd = dvzd + rot(2, 3)*du1d(ivy)
        du1d(ivy) = 0.0_8
        dvxd = dvxd + rot(1, 1)*du1d(ivx)
        dvyd = dvyd + rot(1, 2)*du1d(ivx)
        dvzd = dvzd + rot(1, 3)*du1d(ivx)
        du1d(ivx) = 0.0_8
        du1d(ivz) = du1d(ivz) + dvzd
        du1d(ivy) = du1d(ivy) + dvyd
        du1d(ivx) = du1d(ivx) + dvxd
      end if
    end subroutine leftrightstate_fast_b
 
!      ==================================================================
    subroutine leftrightstate(du1, du2, du3, rotmatrix, left, right)
      implicit none
!
!        local parameter.
!
      real(kind=realtype), parameter :: epslim=1.e-10_realtype
!
!        subroutine arguments.
!
      real(kind=realtype), dimension(:), intent(inout) :: du1, du2, du3
      real(kind=realtype), dimension(:), intent(out) :: left, right
      real(kind=realtype), dimension(:, :, :, :, :), pointer :: &
&     rotmatrix
!
!        local variables.
!
      integer(kind=inttype) :: l
      real(kind=realtype) :: rl1, rl2, rr1, rr2, tmp, dvx, dvy, dvz
      real(kind=realtype), dimension(3, 3) :: rot
      intrinsic abs
      intrinsic max
      intrinsic sign
      intrinsic min
      real(kind=realtype) :: x1
      real(kind=realtype) :: y1
      real(kind=realtype) :: y2
      real(kind=realtype) :: x2
      real(kind=realtype) :: y3
      real(kind=realtype) :: y4
      real(kind=realtype) :: x3
      real(kind=realtype) :: x4
      real(kind=realtype) :: x5
      real(kind=realtype) :: x6
      real(kind=realtype) :: max2
      real(kind=realtype) :: max3
      real(kind=realtype) :: max4
      real(kind=realtype) :: max5
      real(kind=realtype) :: max6
      real(kind=realtype) :: max7
! check if the velocity components should be transformed to
! the cylindrical frame.
      if (rotationalperiodic) then
! store the rotation matrix a bit easier. note that the i,j,k
! come from the main subroutine.
        rot(1, 1) = rotmatrix(i, j, k, 1, 1)
        rot(1, 2) = rotmatrix(i, j, k, 1, 2)
        rot(1, 3) = rotmatrix(i, j, k, 1, 3)
        rot(2, 1) = rotmatrix(i, j, k, 2, 1)
        rot(2, 2) = rotmatrix(i, j, k, 2, 2)
        rot(2, 3) = rotmatrix(i, j, k, 2, 3)
        rot(3, 1) = rotmatrix(i, j, k, 3, 1)
        rot(3, 2) = rotmatrix(i, j, k, 3, 2)
        rot(3, 3) = rotmatrix(i, j, k, 3, 3)
! apply the transformation to the velocity components
! of du1, du2 and du3.
        dvx = du1(ivx)
        dvy = du1(ivy)
        dvz = du1(ivz)
        du1(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du1(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du1(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
        dvx = du2(ivx)
        dvy = du2(ivy)
        dvz = du2(ivz)
        du2(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du2(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du2(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
        dvx = du3(ivx)
        dvy = du3(ivy)
        dvz = du3(ivz)
        du3(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du3(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du3(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
      end if
! determine the limiter used.
      select case  (limused) 
      case (nolimiter) 
! linear interpolation; no limiter.
! loop over the number of variables to be interpolated.
        do l=1,nwint
          left(l) = omk*du1(l) + opk*du2(l)
          right(l) = -(omk*du3(l)) - opk*du2(l)
        end do
      case (vanalbeda) 
!          ==============================================================
! nonlinear interpolation using the van albeda limiter.
! loop over the number of variables to be interpolated.
        do l=1,nwint
          if (du2(l) .ge. 0.) then
            x1 = du2(l)
          else
            x1 = -du2(l)
          end if
          if (x1 .lt. epslim) then
            max2 = epslim
          else
            max2 = x1
          end if
! compute the limiter argument rl1, rl2, rr1 and rr2.
! note the cut off to 0.0.
          tmp = one/sign(max2, du2(l))
          if (du1(l) .ge. 0.) then
            x3 = du1(l)
          else
            x3 = -du1(l)
          end if
          if (x3 .lt. epslim) then
            max4 = epslim
          else
            max4 = x3
          end if
          y1 = du2(l)/sign(max4, du1(l))
          if (zero .lt. y1) then
            rl1 = y1
          else
            rl1 = zero
          end if
          if (zero .lt. du1(l)*tmp) then
            rl2 = du1(l)*tmp
          else
            rl2 = zero
          end if
          if (zero .lt. du3(l)*tmp) then
            rr1 = du3(l)*tmp
          else
            rr1 = zero
          end if
          if (du3(l) .ge. 0.) then
            x4 = du3(l)
          else
            x4 = -du3(l)
          end if
          if (x4 .lt. epslim) then
            max5 = epslim
          else
            max5 = x4
          end if
          y2 = du2(l)/sign(max5, du3(l))
          if (zero .lt. y2) then
            rr2 = y2
          else
            rr2 = zero
          end if
! compute the corresponding limiter values.
          rl1 = rl1*(rl1+one)/(rl1*rl1+one)
          rl2 = rl2*(rl2+one)/(rl2*rl2+one)
          rr1 = rr1*(rr1+one)/(rr1*rr1+one)
          rr2 = rr2*(rr2+one)/(rr2*rr2+one)
! compute the nonlinear corrections to the first order
! scheme.
          left(l) = omk*rl1*du1(l) + opk*rl2*du2(l)
          right(l) = -(opk*rr1*du2(l)) - omk*rr2*du3(l)
        end do
      case (minmod) 
!          ==============================================================
! nonlinear interpolation using the minmod limiter.
! loop over the number of variables to be interpolated.
        do l=1,nwint
          if (du2(l) .ge. 0.) then
            x2 = du2(l)
          else
            x2 = -du2(l)
          end if
          if (x2 .lt. epslim) then
            max3 = epslim
          else
            max3 = x2
          end if
! compute the limiter argument rl1, rl2, rr1 and rr2.
! note the cut off to 0.0.
          tmp = one/sign(max3, du2(l))
          if (du1(l) .ge. 0.) then
            x5 = du1(l)
          else
            x5 = -du1(l)
          end if
          if (x5 .lt. epslim) then
            max6 = epslim
          else
            max6 = x5
          end if
          y3 = du2(l)/sign(max6, du1(l))
          if (zero .lt. y3) then
            rl1 = y3
          else
            rl1 = zero
          end if
          if (zero .lt. du1(l)*tmp) then
            rl2 = du1(l)*tmp
          else
            rl2 = zero
          end if
          if (zero .lt. du3(l)*tmp) then
            rr1 = du3(l)*tmp
          else
            rr1 = zero
          end if
          if (du3(l) .ge. 0.) then
            x6 = du3(l)
          else
            x6 = -du3(l)
          end if
          if (x6 .lt. epslim) then
            max7 = epslim
          else
            max7 = x6
          end if
          y4 = du2(l)/sign(max7, du3(l))
          if (zero .lt. y4) then
            rr2 = y4
          else
            rr2 = zero
          end if
          if (one .gt. factminmod*rl1) then
            rl1 = factminmod*rl1
          else
            rl1 = one
          end if
          if (one .gt. factminmod*rl2) then
            rl2 = factminmod*rl2
          else
            rl2 = one
          end if
          if (one .gt. factminmod*rr1) then
            rr1 = factminmod*rr1
          else
            rr1 = one
          end if
          if (one .gt. factminmod*rr2) then
            rr2 = factminmod*rr2
          else
            rr2 = one
          end if
! compute the nonlinear corrections to the first order
! scheme.
          left(l) = omk*rl1*du1(l) + opk*rl2*du2(l)
          right(l) = -(opk*rr1*du2(l)) - omk*rr2*du3(l)
        end do
      end select
! in case only a first order scheme must be used for the
! turbulent transport equations, set the correction for the
! turbulent kinetic energy to 0.
      if (firstorderk) then
        left(itu1) = zero
        right(itu1) = zero
      end if
! for rotational periodic problems transform the velocity
! differences back to cartesian again. note that now the
! transpose of the rotation matrix must be used.
      if (rotationalperiodic) then
! left state.
        dvx = left(ivx)
        dvy = left(ivy)
        dvz = left(ivz)
        left(ivx) = rot(1, 1)*dvx + rot(2, 1)*dvy + rot(3, 1)*dvz
        left(ivy) = rot(1, 2)*dvx + rot(2, 2)*dvy + rot(3, 2)*dvz
        left(ivz) = rot(1, 3)*dvx + rot(2, 3)*dvy + rot(3, 3)*dvz
! right state.
        dvx = right(ivx)
        dvy = right(ivy)
        dvz = right(ivz)
        right(ivx) = rot(1, 1)*dvx + rot(2, 1)*dvy + rot(3, 1)*dvz
        right(ivy) = rot(1, 2)*dvx + rot(2, 2)*dvy + rot(3, 2)*dvz
        right(ivz) = rot(1, 3)*dvx + rot(2, 3)*dvy + rot(3, 3)*dvz
      end if
    end subroutine leftrightstate
 
!  differentiation of riemannflux in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: flux left right
!   with respect to varying inputs: flux left right
!        ================================================================
    subroutine riemannflux_fast_b(left, leftd, right, rightd, flux, &
&     fluxd)
      implicit none
!
!        subroutine arguments.
!
      real(kind=realtype), dimension(*), intent(in) :: left, right
      real(kind=realtype), dimension(*) :: leftd, rightd
      real(kind=realtype), dimension(*) :: flux
      real(kind=realtype), dimension(*) :: fluxd
!
!        local variables.
!
      real(kind=realtype) :: porflux, rface
      real(kind=realtype) :: etl, etr, z1l, z1r, tmp
      real(kind=realtype) :: etld, etrd, z1ld, z1rd, tmpd
      real(kind=realtype) :: dr, dru, drv, drw, dre, drk
      real(kind=realtype) :: drd, drud, drvd, drwd, dred, drkd
      real(kind=realtype) :: ravg, uavg, vavg, wavg, havg, kavg
      real(kind=realtype) :: uavgd, vavgd, wavgd, havgd, kavgd
      real(kind=realtype) :: alphaavg, a2avg, aavg, unavg
      real(kind=realtype) :: alphaavgd, a2avgd, aavgd, unavgd
      real(kind=realtype) :: ovaavg, ova2avg, area, eta
      real(kind=realtype) :: ovaavgd, ova2avgd, etad
      real(kind=realtype) :: gm1, gm53
      real(kind=realtype) :: lam1, lam2, lam3
      real(kind=realtype) :: lam1d, lam2d, lam3d
      real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
      real(kind=realtype) :: abv1d, abv2d, abv3d, abv4d, abv5d, abv6d, &
&     abv7d
      real(kind=realtype), dimension(2) :: ktmp
      real(kind=realtype), dimension(2) :: ktmpd
      intrinsic sqrt
      intrinsic max
      intrinsic abs
      real(kind=realtype) :: x1
      real(kind=realtype) :: x1d
      real(kind=realtype) :: x2
      real(kind=realtype) :: x2d
      real(realtype) :: max2
      real(kind=realtype) :: abs1
      real(kind=realtype) :: abs1d
      real(kind=realtype) :: abs2
      real(kind=realtype) :: abs2d
      real(kind=realtype) :: temp
      real(kind=realtype) :: tempd
      real(kind=realtype) :: temp0
      real(kind=realtype) :: temp1
      real(kind=realtype) :: tempd0
      real(kind=realtype) :: tempd1
      integer :: branch
! set the porosity for the flux. the default value, 0.5*rfil, is
! a scaling factor where an rfil != 1 is taken into account.
      porflux = half*rfil
      if (por .eq. noflux .or. por .eq. boundflux) porflux = zero
! abbreviate some expressions in which gamma occurs.
      gm1 = gammaface - one
      gm53 = gammaface - five*third
! determine which riemann solver must be solved.
      select case  (riemannused) 
      case (roe) 
! determine the preconditioner used.
        select case  (precond) 
        case (noprecond) 
! no preconditioner used. use the roe scheme of the
! standard equations.
! compute the square root of the left and right densities
! and the inverse of the sum.
          z1l = sqrt(left(irho))
          z1r = sqrt(right(irho))
          tmp = one/(z1l+z1r)
! compute some variables depending whether or not a
! k-equation is present.
          if (correctfork) then
! store the left and right kinetic energy in ktmp,
! which is needed to compute the total energy.
            ktmp(1) = left(itu1)
            ktmp(2) = right(itu1)
! store the difference of the turbulent kinetic energy
! per unit volume, i.e. the conserved variable.
            drk = right(irho)*right(itu1) - left(irho)*left(itu1)
! compute the average turbulent energy per unit mass
! using roe averages.
            kavg = tmp*(z1l*left(itu1)+z1r*right(itu1))
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          else
myintptr = myintptr + 1
 myintstack(myintptr) = 0
! set the difference of the turbulent kinetic energy
! per unit volume and the averaged kinetic energy per
! unit mass to zero.
            drk = 0.0
            kavg = 0.0
          end if
! compute the total energy of the left and right state.
          call etot(left(irho), left(ivx), left(ivy), left(ivz), left(&
&             irhoe), ktmp(1), etl, correctfork)
          call etot(right(irho), right(ivx), right(ivy), right(ivz), &
&             right(irhoe), ktmp(2), etr, correctfork)
! compute the difference of the conservative mean
! flow variables.
          dr = right(irho) - left(irho)
          dru = right(irho)*right(ivx) - left(irho)*left(ivx)
          drv = right(irho)*right(ivy) - left(irho)*left(ivy)
          drw = right(irho)*right(ivz) - left(irho)*left(ivz)
          dre = etr - etl
! compute the roe average variables, which can be
! computed directly from the average roe vector.
          uavg = tmp*(z1l*left(ivx)+z1r*right(ivx))
          vavg = tmp*(z1l*left(ivy)+z1r*right(ivy))
          wavg = tmp*(z1l*left(ivz)+z1r*right(ivz))
          havg = tmp*((etl+left(irhoe))/z1l+(etr+right(irhoe))/z1r)
! compute the unit vector and store the area of the
! normal. also compute the unit normal velocity of the face.
          area = sqrt(sx**2 + sy**2 + sz**2)
          if (1.e-25_realtype .lt. area) then
            max2 = area
          else
            max2 = 1.e-25_realtype
          end if
          tmp = one/max2
          sx = sx*tmp
          sy = sy*tmp
          sz = sz*tmp
          rface = sface*tmp
! compute some dependent variables at the roe
! average state.
          alphaavg = half*(uavg**2+vavg**2+wavg**2)
          if (gm1*(havg-alphaavg) - gm53*kavg .ge. 0.) then
            a2avg = gm1*(havg-alphaavg) - gm53*kavg
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            a2avg = -(gm1*(havg-alphaavg)-gm53*kavg)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          aavg = sqrt(a2avg)
          unavg = uavg*sx + vavg*sy + wavg*sz
          ovaavg = one/aavg
          ova2avg = one/a2avg
! set for a boundary the normal velocity to rface, the
! normal velocity of the boundary.
          if (por .eq. boundflux) then
            unavg = rface
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          else
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          end if
          x1 = (left(ivx)-right(ivx))*sx + (left(ivy)-right(ivy))*sy + (&
&           left(ivz)-right(ivz))*sz
          if (x1 .ge. 0.) then
            abs1 = x1
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          else
            abs1 = -x1
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          end if
          x2 = sqrt(gammaface*left(irhoe)/left(irho)) - sqrt(gammaface*&
&           right(irhoe)/right(irho))
          if (x2 .ge. 0.) then
            abs2 = x2
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            abs2 = -x2
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
! compute the coefficient eta for the entropy correction.
! at the moment a 1d entropy correction is used, which
! removes expansion shocks. although it also reduces the
! carbuncle phenomenon, it does not remove it completely.
! in other to do that a multi-dimensional entropy fix is
! needed, see sanders et. al, jcp, vol. 145, 1998,
! pp. 511 - 537. although relatively easy to implement,
! an efficient implementation requires the storage of
! all the left and right states, which is rather
! expensive in terms of memory.
          eta = half*(abs1+abs2)
          if (unavg - rface + aavg .ge. 0.) then
            lam1 = unavg - rface + aavg
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            lam1 = -(unavg-rface+aavg)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (unavg - rface - aavg .ge. 0.) then
            lam2 = unavg - rface - aavg
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            lam2 = -(unavg-rface-aavg)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (unavg - rface .ge. 0.) then
            lam3 = unavg - rface
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
            lam3 = -(unavg-rface)
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
! apply the entropy correction to the eigenvalues.
          tmp = two*eta
          if (lam1 .lt. tmp) then
            lam1 = eta + fourth*lam1*lam1/eta
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (lam2 .lt. tmp) then
            lam2 = eta + fourth*lam2*lam2/eta
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
          if (lam3 .lt. tmp) then
            lam3 = eta + fourth*lam3*lam3/eta
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
          end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
          lam1 = lam1*area
          lam2 = lam2*area
          lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
          abv1 = half*(lam1+lam2)
          abv2 = half*(lam1-lam2)
          abv3 = abv1 - lam3
          abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53&
&           *drk
          abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
          abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
          abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute the dissipation term, -|a| (wr - wl), which is
! multiplied by porflux. note that porflux is either
! 0.0 or 0.5*rfil.
!          tmp = max(lam1,lam2,lam3)
!          flux(irho)  = -porflux*(tmp*dr)
!          flux(imx)   = -porflux*(tmp*dru)
!          flux(imy)   = -porflux*(tmp*drv)
!          flux(imz)   = -porflux*(tmp*drw)
!          flux(irhoe) = -porflux*(tmp*dre)
          tempd0 = -(porflux*fluxd(irhoe))
          fluxd(irhoe) = 0.0_8
          lam3d = dre*tempd0
          dred = lam3*tempd0
          havgd = abv6*tempd0
          abv6d = havg*tempd0
          unavgd = abv7*tempd0
          abv7d = unavg*tempd0
          tempd0 = -(porflux*fluxd(imz))
          fluxd(imz) = 0.0_8
          lam3d = lam3d + drw*tempd0
          drwd = lam3*tempd0
          wavgd = abv6*tempd0
          abv6d = abv6d + wavg*tempd0
          abv7d = abv7d + sz*tempd0
          tempd0 = -(porflux*fluxd(imy))
          fluxd(imy) = 0.0_8
          lam3d = lam3d + drv*tempd0
          drvd = lam3*tempd0
          vavgd = abv6*tempd0
          abv6d = abv6d + vavg*tempd0
          abv7d = abv7d + sy*tempd0
          tempd0 = -(porflux*fluxd(imx))
          fluxd(imx) = 0.0_8
          lam3d = lam3d + dru*tempd0
          drud = lam3*tempd0
          uavgd = abv6*tempd0
          abv6d = abv6d + uavg*tempd0
          abv7d = abv7d + sx*tempd0
          tempd0 = -(porflux*fluxd(irho))
          fluxd(irho) = 0.0_8
          drd = lam3*tempd0
          abv6d = abv6d + tempd0
          abv2d = abv4*ovaavg*abv7d + abv5*ovaavg*abv6d
          abv4d = abv2*ovaavg*abv7d + abv3*ova2avg*abv6d
          ovaavgd = abv2*abv4*abv7d + abv2*abv5*abv6d
          abv3d = abv5*abv7d + abv4*ova2avg*abv6d
          lam3d = lam3d + dr*tempd0 - abv3d
          abv5d = abv3*abv7d + abv2*ovaavg*abv6d
          ova2avgd = abv3*abv4*abv6d
          unavgd = unavgd - dr*abv5d
          tempd0 = gm1*abv4d
          drud = drud + sx*abv5d - uavg*tempd0
          drvd = drvd + sy*abv5d - vavg*tempd0
          drwd = drwd + sz*abv5d - wavg*tempd0
          drd = drd + alphaavg*tempd0 - unavg*abv5d
          drkd = -(gm53*abv4d)
          alphaavgd = dr*tempd0
          uavgd = uavgd - dru*tempd0
          vavgd = vavgd - drv*tempd0
          dred = dred + tempd0
          wavgd = wavgd - drw*tempd0
          abv1d = abv3d
          lam1d = half*abv2d + half*abv1d
          lam2d = half*abv1d - half*abv2d
          lam3d = area*lam3d
          lam2d = area*lam2d
          lam1d = area*lam1d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            tempd0 = fourth*lam3d/eta
            etad = lam3d - lam3**2*tempd0/eta
            lam3d = 2*lam3*tempd0
          else
            etad = 0.0_8
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            tempd0 = fourth*lam2d/eta
            etad = etad + lam2d - lam2**2*tempd0/eta
            lam2d = 2*lam2*tempd0
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            tempd0 = fourth*lam1d/eta
            etad = etad + lam1d - lam1**2*tempd0/eta
            lam1d = 2*lam1*tempd0
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            unavgd = unavgd + lam3d
          else
            unavgd = unavgd - lam3d
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            unavgd = unavgd + lam2d
            aavgd = -lam2d
          else
            aavgd = lam2d
            unavgd = unavgd - lam2d
          end if
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            unavgd = unavgd + lam1d
            aavgd = aavgd + lam1d
          else
            unavgd = unavgd - lam1d
            aavgd = aavgd - lam1d
          end if
          abs1d = half*etad
          abs2d = half*etad
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            x2d = abs2d
          else
            x2d = -abs2d
          end if
          temp1 = left(irhoe)/left(irho)
          temp0 = right(irhoe)/right(irho)
          if (gammaface*temp1 .eq. 0.0_8) then
            tempd0 = 0.0_8
          else
            tempd0 = gammaface*x2d/(left(irho)*2.0*sqrt(gammaface*temp1)&
&             )
          end if
          if (gammaface*temp0 .eq. 0.0_8) then
            tempd1 = 0.0_8
          else
            tempd1 = -(gammaface*x2d/(right(irho)*2.0*sqrt(gammaface*&
&             temp0)))
          end if
          rightd(irhoe) = rightd(irhoe) + tempd1
          rightd(irho) = rightd(irho) - temp0*tempd1
          leftd(irhoe) = leftd(irhoe) + tempd0
          leftd(irho) = leftd(irho) - temp1*tempd0
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            x1d = -abs1d
          else
            x1d = abs1d
          end if
          leftd(ivx) = leftd(ivx) + sx*x1d
          rightd(ivx) = rightd(ivx) - sx*x1d
          leftd(ivy) = leftd(ivy) + sy*x1d
          rightd(ivy) = rightd(ivy) - sy*x1d
          leftd(ivz) = leftd(ivz) + sz*x1d
          rightd(ivz) = rightd(ivz) - sz*x1d
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .ne. 0) unavgd = 0.0_8
          aavgd = aavgd - one*ovaavgd/aavg**2
          if (a2avg .eq. 0.0_8) then
            a2avgd = -(one*ova2avgd/a2avg**2)
          else
            a2avgd = aavgd/(2.0*sqrt(a2avg)) - one*ova2avgd/a2avg**2
          end if
          uavgd = uavgd + sx*unavgd
          vavgd = vavgd + sy*unavgd
          wavgd = wavgd + sz*unavgd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) then
            havgd = havgd + gm1*a2avgd
            alphaavgd = alphaavgd - gm1*a2avgd
            kavgd = -(gm53*a2avgd)
          else
            kavgd = gm53*a2avgd
            havgd = havgd - gm1*a2avgd
            alphaavgd = alphaavgd + gm1*a2avgd
          end if
          tempd0 = half*alphaavgd
          uavgd = uavgd + 2*uavg*tempd0
          vavgd = vavgd + 2*vavg*tempd0
          wavgd = wavgd + 2*wavg*tempd0
          tmp = one/(z1l+z1r)
          temp = (etr+right(irhoe))/z1r
          temp0 = (etl+left(irhoe))/z1l
          tmpd = (temp0+temp)*havgd + (z1l*left(ivz)+z1r*right(ivz))*&
&           wavgd + (z1l*left(ivy)+z1r*right(ivy))*vavgd + (z1l*left(ivx&
&           )+z1r*right(ivx))*uavgd
          tempd0 = tmp*havgd
          tempd1 = tempd0/z1l
          tempd = tempd0/z1r
          etrd = tempd + dred
          rightd(irhoe) = rightd(irhoe) + tempd
          z1rd = -(temp*tempd)
          etld = tempd1 - dred
          leftd(irhoe) = leftd(irhoe) + tempd1
          tempd = tmp*wavgd
          z1ld = left(ivz)*tempd - temp0*tempd1
          leftd(ivz) = leftd(ivz) + z1l*tempd
          z1rd = z1rd + right(ivz)*tempd
          rightd(ivz) = rightd(ivz) + z1r*tempd
          tempd = tmp*vavgd
          z1ld = z1ld + left(ivy)*tempd
          leftd(ivy) = leftd(ivy) + z1l*tempd
          z1rd = z1rd + right(ivy)*tempd
          rightd(ivy) = rightd(ivy) + z1r*tempd
          tempd = tmp*uavgd
          z1ld = z1ld + left(ivx)*tempd
          leftd(ivx) = leftd(ivx) + z1l*tempd
          z1rd = z1rd + right(ivx)*tempd
          rightd(ivx) = rightd(ivx) + z1r*tempd
          rightd(irho) = rightd(irho) + right(ivz)*drwd
          rightd(ivz) = rightd(ivz) + right(irho)*drwd
          leftd(irho) = leftd(irho) - left(ivz)*drwd
          leftd(ivz) = leftd(ivz) - left(irho)*drwd
          rightd(irho) = rightd(irho) + right(ivy)*drvd
          rightd(ivy) = rightd(ivy) + right(irho)*drvd
          leftd(irho) = leftd(irho) - left(ivy)*drvd
          leftd(ivy) = leftd(ivy) - left(irho)*drvd
          rightd(irho) = rightd(irho) + right(ivx)*drud
          rightd(ivx) = rightd(ivx) + right(irho)*drud
          leftd(irho) = leftd(irho) - left(ivx)*drud
          leftd(ivx) = leftd(ivx) - left(irho)*drud
          rightd(irho) = rightd(irho) + drd
          leftd(irho) = leftd(irho) - drd
          ktmpd = 0.0_8
          call etot_fast_b(right(irho), rightd(irho), right(ivx), rightd&
&                    (ivx), right(ivy), rightd(ivy), right(ivz), rightd(&
&                    ivz), right(irhoe), rightd(irhoe), ktmp(2), ktmpd(2&
&                    ), etr, etrd, correctfork)
          call etot_fast_b(left(irho), leftd(irho), left(ivx), leftd(ivx&
&                    ), left(ivy), leftd(ivy), left(ivz), leftd(ivz), &
&                    left(irhoe), leftd(irhoe), ktmp(1), ktmpd(1), etl, &
&                    etld, correctfork)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .ne. 0) then
            tmpd = tmpd + (z1l*left(itu1)+z1r*right(itu1))*kavgd
            tempd = tmp*kavgd
            z1ld = z1ld + left(itu1)*tempd
            leftd(itu1) = leftd(itu1) + z1l*tempd
            z1rd = z1rd + right(itu1)*tempd
            rightd(itu1) = rightd(itu1) + z1r*tempd
            rightd(irho) = rightd(irho) + right(itu1)*drkd
            rightd(itu1) = rightd(itu1) + right(irho)*drkd + ktmpd(2)
            leftd(irho) = leftd(irho) - left(itu1)*drkd
            leftd(itu1) = leftd(itu1) + ktmpd(1) - left(irho)*drkd
            ktmpd(2) = 0.0_8
          end if
          tempd = -(one*tmpd/(z1l+z1r)**2)
          z1ld = z1ld + tempd
          z1rd = z1rd + tempd
          if (.not.right(irho) .eq. 0.0_8) rightd(irho) = rightd(irho) +&
&             z1rd/(2.0*sqrt(right(irho)))
          if (.not.left(irho) .eq. 0.0_8) leftd(irho) = leftd(irho) + &
&             z1ld/(2.0*sqrt(left(irho)))
        end select
      end select
    end subroutine riemannflux_fast_b
 
!        ================================================================
    subroutine riemannflux(left, right, flux)
      implicit none
!
!        subroutine arguments.
!
      real(kind=realtype), dimension(*), intent(in) :: left, right
      real(kind=realtype), dimension(*), intent(out) :: flux
!
!        local variables.
!
      real(kind=realtype) :: porflux, rface
      real(kind=realtype) :: etl, etr, z1l, z1r, tmp
      real(kind=realtype) :: dr, dru, drv, drw, dre, drk
      real(kind=realtype) :: ravg, uavg, vavg, wavg, havg, kavg
      real(kind=realtype) :: alphaavg, a2avg, aavg, unavg
      real(kind=realtype) :: ovaavg, ova2avg, area, eta
      real(kind=realtype) :: gm1, gm53
      real(kind=realtype) :: lam1, lam2, lam3
      real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
      real(kind=realtype), dimension(2) :: ktmp
      intrinsic sqrt
      intrinsic max
      intrinsic abs
      real(kind=realtype) :: x1
      real(kind=realtype) :: x2
      real(realtype) :: max2
      real(kind=realtype) :: abs1
      real(kind=realtype) :: abs2
! set the porosity for the flux. the default value, 0.5*rfil, is
! a scaling factor where an rfil != 1 is taken into account.
      porflux = half*rfil
      if (por .eq. noflux .or. por .eq. boundflux) porflux = zero
! abbreviate some expressions in which gamma occurs.
      gm1 = gammaface - one
      gm53 = gammaface - five*third
! determine which riemann solver must be solved.
      select case  (riemannused) 
      case (roe) 
! determine the preconditioner used.
        select case  (precond) 
        case (noprecond) 
! no preconditioner used. use the roe scheme of the
! standard equations.
! compute the square root of the left and right densities
! and the inverse of the sum.
          z1l = sqrt(left(irho))
          z1r = sqrt(right(irho))
          tmp = one/(z1l+z1r)
! compute some variables depending whether or not a
! k-equation is present.
          if (correctfork) then
! store the left and right kinetic energy in ktmp,
! which is needed to compute the total energy.
            ktmp(1) = left(itu1)
            ktmp(2) = right(itu1)
! store the difference of the turbulent kinetic energy
! per unit volume, i.e. the conserved variable.
            drk = right(irho)*right(itu1) - left(irho)*left(itu1)
! compute the average turbulent energy per unit mass
! using roe averages.
            kavg = tmp*(z1l*left(itu1)+z1r*right(itu1))
          else
! set the difference of the turbulent kinetic energy
! per unit volume and the averaged kinetic energy per
! unit mass to zero.
            drk = 0.0
            kavg = 0.0
          end if
! compute the total energy of the left and right state.
          call etot(left(irho), left(ivx), left(ivy), left(ivz), left(&
&             irhoe), ktmp(1), etl, correctfork)
          call etot(right(irho), right(ivx), right(ivy), right(ivz), &
&             right(irhoe), ktmp(2), etr, correctfork)
! compute the difference of the conservative mean
! flow variables.
          dr = right(irho) - left(irho)
          dru = right(irho)*right(ivx) - left(irho)*left(ivx)
          drv = right(irho)*right(ivy) - left(irho)*left(ivy)
          drw = right(irho)*right(ivz) - left(irho)*left(ivz)
          dre = etr - etl
! compute the roe average variables, which can be
! computed directly from the average roe vector.
          ravg = fourth*(z1r+z1l)**2
          uavg = tmp*(z1l*left(ivx)+z1r*right(ivx))
          vavg = tmp*(z1l*left(ivy)+z1r*right(ivy))
          wavg = tmp*(z1l*left(ivz)+z1r*right(ivz))
          havg = tmp*((etl+left(irhoe))/z1l+(etr+right(irhoe))/z1r)
! compute the unit vector and store the area of the
! normal. also compute the unit normal velocity of the face.
          area = sqrt(sx**2 + sy**2 + sz**2)
          if (1.e-25_realtype .lt. area) then
            max2 = area
          else
            max2 = 1.e-25_realtype
          end if
          tmp = one/max2
          sx = sx*tmp
          sy = sy*tmp
          sz = sz*tmp
          rface = sface*tmp
! compute some dependent variables at the roe
! average state.
          alphaavg = half*(uavg**2+vavg**2+wavg**2)
          if (gm1*(havg-alphaavg) - gm53*kavg .ge. 0.) then
            a2avg = gm1*(havg-alphaavg) - gm53*kavg
          else
            a2avg = -(gm1*(havg-alphaavg)-gm53*kavg)
          end if
          aavg = sqrt(a2avg)
          unavg = uavg*sx + vavg*sy + wavg*sz
          ovaavg = one/aavg
          ova2avg = one/a2avg
! set for a boundary the normal velocity to rface, the
! normal velocity of the boundary.
          if (por .eq. boundflux) unavg = rface
          x1 = (left(ivx)-right(ivx))*sx + (left(ivy)-right(ivy))*sy + (&
&           left(ivz)-right(ivz))*sz
          if (x1 .ge. 0.) then
            abs1 = x1
          else
            abs1 = -x1
          end if
          x2 = sqrt(gammaface*left(irhoe)/left(irho)) - sqrt(gammaface*&
&           right(irhoe)/right(irho))
          if (x2 .ge. 0.) then
            abs2 = x2
          else
            abs2 = -x2
          end if
! compute the coefficient eta for the entropy correction.
! at the moment a 1d entropy correction is used, which
! removes expansion shocks. although it also reduces the
! carbuncle phenomenon, it does not remove it completely.
! in other to do that a multi-dimensional entropy fix is
! needed, see sanders et. al, jcp, vol. 145, 1998,
! pp. 511 - 537. although relatively easy to implement,
! an efficient implementation requires the storage of
! all the left and right states, which is rather
! expensive in terms of memory.
          eta = half*(abs1+abs2)
          if (unavg - rface + aavg .ge. 0.) then
            lam1 = unavg - rface + aavg
          else
            lam1 = -(unavg-rface+aavg)
          end if
          if (unavg - rface - aavg .ge. 0.) then
            lam2 = unavg - rface - aavg
          else
            lam2 = -(unavg-rface-aavg)
          end if
          if (unavg - rface .ge. 0.) then
            lam3 = unavg - rface
          else
            lam3 = -(unavg-rface)
          end if
! apply the entropy correction to the eigenvalues.
          tmp = two*eta
          if (lam1 .lt. tmp) lam1 = eta + fourth*lam1*lam1/eta
          if (lam2 .lt. tmp) lam2 = eta + fourth*lam2*lam2/eta
          if (lam3 .lt. tmp) lam3 = eta + fourth*lam3*lam3/eta
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
          lam1 = lam1*area
          lam2 = lam2*area
          lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
          abv1 = half*(lam1+lam2)
          abv2 = half*(lam1-lam2)
          abv3 = abv1 - lam3
          abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53&
&           *drk
          abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
          abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
          abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute the dissipation term, -|a| (wr - wl), which is
! multiplied by porflux. note that porflux is either
! 0.0 or 0.5*rfil.
          flux(irho) = -(porflux*(lam3*dr+abv6))
          flux(imx) = -(porflux*(lam3*dru+uavg*abv6+sx*abv7))
          flux(imy) = -(porflux*(lam3*drv+vavg*abv6+sy*abv7))
          flux(imz) = -(porflux*(lam3*drw+wavg*abv6+sz*abv7))
          flux(irhoe) = -(porflux*(lam3*dre+havg*abv6+unavg*abv7))
!          tmp = max(lam1,lam2,lam3)
!          flux(irho)  = -porflux*(tmp*dr)
!          flux(imx)   = -porflux*(tmp*dru)
!          flux(imy)   = -porflux*(tmp*drv)
!          flux(imz)   = -porflux*(tmp*drw)
!          flux(irhoe) = -porflux*(tmp*dre)
        case (turkel) 
          call terminate('riemannflux', &
&                  'turkel preconditioner not implemented yet')
        case (choimerkle) 
          call terminate('riemannflux', &
&                  'choi merkle preconditioner not implemented yet')
        end select
      case (vanleer) 
        call terminate('riemannflux', 'van leer fvs not implemented yet'&
&               )
      case (ausmdv) 
        call terminate('riemannflux', 'ausmdv fvs not implemented yet')
      end select
    end subroutine riemannflux
 
  end subroutine inviscidupwindflux_fast_b
 
  subroutine inviscidupwindflux(finegrid)
!
!       inviscidupwindflux computes the artificial dissipation part of
!       the euler fluxes by means of an approximate solution of the 1d
!       riemann problem on the face. for first order schemes,
!       finegrid == .false., the states in the cells are assumed to
!       be constant; for the second order schemes on the fine grid a
!       nonlinear reconstruction of the left and right state is done
!       for which several options exist.
!       it is assumed that the pointers in blockpointers already
!       point to the correct block.
!
    use constants
    use blockpointers, only : il, jl, kl, ie, je, ke, ib, jb, kb,&
&   w, p, pori, porj, pork, fw, gamma, si, sj, sk, indfamilyi, &
&   indfamilyj, indfamilyk, spectralsol, addgridvelocities, sfacei, &
&   sfacej, sfacek, rotmatrixi, rotmatrixj, rotmatrixk, factfamilyi, &
&   factfamilyj, factfamilyk
    use flowvarrefstate, only : kpresent, nw, nwf, rgas, tref
    use inputdiscretization, only : limiter, lumpeddiss, precond, &
&   riemann, riemanncoarse, orderturb, kappacoef
    use inputphysics, only : equations
    use iteration, only : rfil, currentlevel, groundlevel
    use cgnsgrid, only : massflowfamilydiss
    use utils_fast_b, only : getcorrectfork, terminate
    use flowutils_fast_b, only : etot
    implicit none
!
!      subroutine arguments.
!
    logical, intent(in) :: finegrid
!
!      local variables.
!
    integer(kind=portype) :: por
    integer(kind=inttype) :: nwint
    integer(kind=inttype) :: i, j, k, ind
    integer(kind=inttype) :: limused, riemannused
    real(kind=realtype) :: sx, sy, sz, omk, opk, sfil, gammaface
    real(kind=realtype) :: factminmod, sface
    real(kind=realtype), dimension(nw) :: left, right
    real(kind=realtype), dimension(nw) :: du1, du2, du3
    real(kind=realtype), dimension(nwf) :: flux
    logical :: firstorderk, correctfork, rotationalperiodic
    intrinsic abs
    intrinsic associated
    intrinsic max
    real(kind=realtype) :: abs0
    real(realtype) :: max1
    if (rfil .ge. 0.) then
      abs0 = rfil
    else
      abs0 = -rfil
    end if
!
! check if rfil == 0. if so, the dissipative flux needs not to
! be computed.
    if (abs0 .lt. thresholdreal) then
      return
    else
! check if the formulation for rotational periodic problems
! must be used.
      if (associated(rotmatrixi)) then
        rotationalperiodic = .true.
      else
        rotationalperiodic = .false.
      end if
! initialize the dissipative residual to a certain times,
! possibly zero, the previously stored value. owned cells
! only, because the halo values do not matter.
      sfil = one - rfil
      do k=2,kl
        do j=2,jl
          do i=2,il
            fw(i, j, k, irho) = sfil*fw(i, j, k, irho)
            fw(i, j, k, imx) = sfil*fw(i, j, k, imx)
            fw(i, j, k, imy) = sfil*fw(i, j, k, imy)
            fw(i, j, k, imz) = sfil*fw(i, j, k, imz)
            fw(i, j, k, irhoe) = sfil*fw(i, j, k, irhoe)
          end do
        end do
      end do
! determine whether or not the total energy must be corrected
! for the presence of the turbulent kinetic energy.
      correctfork = getcorrectfork()
      if (1.e-10_realtype .lt. one - kappacoef) then
        max1 = one - kappacoef
      else
        max1 = 1.e-10_realtype
      end if
! compute the factor used in the minmod limiter.
      factminmod = (three-kappacoef)/max1
! determine the limiter scheme to be used. on the fine grid the
! user specified scheme is used; on the coarse grid a first order
! scheme is computed.
      limused = firstorder
      if (finegrid) limused = limiter
! lumped diss is true for doing approx pc
      if (lumpeddiss) limused = firstorder
! determine the riemann solver which must be used.
      riemannused = riemanncoarse
      if (finegrid) riemannused = riemann
! store 1-kappa and 1+kappa a bit easier and multiply it by 0.25.
      omk = fourth*(one-kappacoef)
      opk = fourth*(one+kappacoef)
! initialize sface to zero. this value will be used if the
! block is not moving.
      sface = zero
! set the number of variables to be interpolated depending
! whether or not a k-equation is present. if a k-equation is
! present also set the logical firstorderk. this indicates
! whether or not only a first order approximation is to be used
! for the turbulent kinetic energy.
      if (correctfork) then
        if (orderturb .eq. firstorder) then
          nwint = nwf
          firstorderk = .true.
        else
          nwint = itu1
          firstorderk = .false.
        end if
      else
        nwint = nwf
        firstorderk = .false.
      end if
!
!       flux computation. a distinction is made between first and
!       second order schemes to avoid the overhead for the first order
!       scheme.
!
      if (limused .eq. firstorder) then
!
!         first order reconstruction. the states in the cells are
!         constant. the left and right states are constructed easily.
!
! fluxes in the i-direction.
        do k=2,kl
          do j=2,jl
            do i=1,il
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = si(i, j, k, 1)
              sy = si(i, j, k, 2)
              sz = si(i, j, k, 3)
              por = pori(i, j, k)
              if (addgridvelocities) sface = sfacei(i, j, k)
! determine the left and right state.
              left(irho) = w(i, j, k, irho)
              left(ivx) = w(i, j, k, ivx)
              left(ivy) = w(i, j, k, ivy)
              left(ivz) = w(i, j, k, ivz)
              left(irhoe) = p(i, j, k)
              if (correctfork) left(itu1) = w(i, j, k, itu1)
              right(irho) = w(i+1, j, k, irho)
              right(ivx) = w(i+1, j, k, ivx)
              right(ivy) = w(i+1, j, k, ivy)
              right(ivz) = w(i+1, j, k, ivz)
              right(irhoe) = p(i+1, j, k)
              if (correctfork) right(itu1) = w(i+1, j, k, itu1)
! compute the value of gamma on the face. take an
! arithmetic average of the two states.
              gammaface = half*(gamma(i, j, k)+gamma(i+1, j, k))
! compute the dissipative flux across the interface.
              call riemannflux(left, right, flux)
! and scatter it to the left and right.
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fw(i+1, j, k, irho) = fw(i+1, j, k, irho) - flux(irho)
              fw(i+1, j, k, imx) = fw(i+1, j, k, imx) - flux(imx)
              fw(i+1, j, k, imy) = fw(i+1, j, k, imy) - flux(imy)
              fw(i+1, j, k, imz) = fw(i+1, j, k, imz) - flux(imz)
              fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) - flux(irhoe)
! store the density flux in the mass flow of the
! appropriate sliding mesh interface.
            end do
          end do
        end do
! fluxes in j-direction.
        do k=2,kl
          do j=1,jl
            do i=2,il
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = sj(i, j, k, 1)
              sy = sj(i, j, k, 2)
              sz = sj(i, j, k, 3)
              por = porj(i, j, k)
              if (addgridvelocities) sface = sfacej(i, j, k)
! determine the left and right state.
              left(irho) = w(i, j, k, irho)
              left(ivx) = w(i, j, k, ivx)
              left(ivy) = w(i, j, k, ivy)
              left(ivz) = w(i, j, k, ivz)
              left(irhoe) = p(i, j, k)
              if (correctfork) left(itu1) = w(i, j, k, itu1)
              right(irho) = w(i, j+1, k, irho)
              right(ivx) = w(i, j+1, k, ivx)
              right(ivy) = w(i, j+1, k, ivy)
              right(ivz) = w(i, j+1, k, ivz)
              right(irhoe) = p(i, j+1, k)
              if (correctfork) right(itu1) = w(i, j+1, k, itu1)
! compute the value of gamma on the face. take an
! arithmetic average of the two states.
              gammaface = half*(gamma(i, j, k)+gamma(i, j+1, k))
! compute the dissipative flux across the interface.
              call riemannflux(left, right, flux)
! and scatter it to the left and right.
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fw(i, j+1, k, irho) = fw(i, j+1, k, irho) - flux(irho)
              fw(i, j+1, k, imx) = fw(i, j+1, k, imx) - flux(imx)
              fw(i, j+1, k, imy) = fw(i, j+1, k, imy) - flux(imy)
              fw(i, j+1, k, imz) = fw(i, j+1, k, imz) - flux(imz)
              fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) - flux(irhoe)
! store the density flux in the mass flow of the
! appropriate sliding mesh interface.
            end do
          end do
        end do
! fluxes in k-direction.
        do k=1,kl
          do j=2,jl
            do i=2,il
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = sk(i, j, k, 1)
              sy = sk(i, j, k, 2)
              sz = sk(i, j, k, 3)
              por = pork(i, j, k)
              if (addgridvelocities) sface = sfacek(i, j, k)
! determine the left and right state.
              left(irho) = w(i, j, k, irho)
              left(ivx) = w(i, j, k, ivx)
              left(ivy) = w(i, j, k, ivy)
              left(ivz) = w(i, j, k, ivz)
              left(irhoe) = p(i, j, k)
              if (correctfork) left(itu1) = w(i, j, k, itu1)
              right(irho) = w(i, j, k+1, irho)
              right(ivx) = w(i, j, k+1, ivx)
              right(ivy) = w(i, j, k+1, ivy)
              right(ivz) = w(i, j, k+1, ivz)
              right(irhoe) = p(i, j, k+1)
              if (correctfork) right(itu1) = w(i, j, k+1, itu1)
! compute the value of gamma on the face. take an
! arithmetic average of the two states.
              gammaface = half*(gamma(i, j, k)+gamma(i, j, k+1))
! compute the dissipative flux across the interface.
              call riemannflux(left, right, flux)
! and scatter it the left and right.
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fw(i, j, k+1, irho) = fw(i, j, k+1, irho) - flux(irho)
              fw(i, j, k+1, imx) = fw(i, j, k+1, imx) - flux(imx)
              fw(i, j, k+1, imy) = fw(i, j, k+1, imy) - flux(imy)
              fw(i, j, k+1, imz) = fw(i, j, k+1, imz) - flux(imz)
              fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) - flux(irhoe)
! store the density flux in the mass flow of the
! appropriate sliding mesh interface.
            end do
          end do
        end do
      else
!      ==================================================================
!      ==================================================================
!
!         second order reconstruction of the left and right state.
!         the three differences used in the, possibly nonlinear,
!         interpolation are constructed here; the actual left and
!         right states, or at least the differences from the first
!         order interpolation, are computed in the subroutine
!         leftrightstate.
!
! fluxes in the i-direction.
        do k=2,kl
          do j=2,jl
            do i=1,il
! store the three differences used in the interpolation
! in du1, du2, du3.
              du1(irho) = w(i, j, k, irho) - w(i-1, j, k, irho)
              du2(irho) = w(i+1, j, k, irho) - w(i, j, k, irho)
              du3(irho) = w(i+2, j, k, irho) - w(i+1, j, k, irho)
              du1(ivx) = w(i, j, k, ivx) - w(i-1, j, k, ivx)
              du2(ivx) = w(i+1, j, k, ivx) - w(i, j, k, ivx)
              du3(ivx) = w(i+2, j, k, ivx) - w(i+1, j, k, ivx)
              du1(ivy) = w(i, j, k, ivy) - w(i-1, j, k, ivy)
              du2(ivy) = w(i+1, j, k, ivy) - w(i, j, k, ivy)
              du3(ivy) = w(i+2, j, k, ivy) - w(i+1, j, k, ivy)
              du1(ivz) = w(i, j, k, ivz) - w(i-1, j, k, ivz)
              du2(ivz) = w(i+1, j, k, ivz) - w(i, j, k, ivz)
              du3(ivz) = w(i+2, j, k, ivz) - w(i+1, j, k, ivz)
              du1(irhoe) = p(i, j, k) - p(i-1, j, k)
              du2(irhoe) = p(i+1, j, k) - p(i, j, k)
              du3(irhoe) = p(i+2, j, k) - p(i+1, j, k)
              if (correctfork) then
                du1(itu1) = w(i, j, k, itu1) - w(i-1, j, k, itu1)
                du2(itu1) = w(i+1, j, k, itu1) - w(i, j, k, itu1)
                du3(itu1) = w(i+2, j, k, itu1) - w(i+1, j, k, itu1)
              end if
! compute the differences from the first order scheme.
              call leftrightstate(du1, du2, du3, rotmatrixi, left, right&
&                          )
! add the first order part to the currently stored
! differences, such that the correct state vector
! is stored.
              left(irho) = left(irho) + w(i, j, k, irho)
              left(ivx) = left(ivx) + w(i, j, k, ivx)
              left(ivy) = left(ivy) + w(i, j, k, ivy)
              left(ivz) = left(ivz) + w(i, j, k, ivz)
              left(irhoe) = left(irhoe) + p(i, j, k)
              right(irho) = right(irho) + w(i+1, j, k, irho)
              right(ivx) = right(ivx) + w(i+1, j, k, ivx)
              right(ivy) = right(ivy) + w(i+1, j, k, ivy)
              right(ivz) = right(ivz) + w(i+1, j, k, ivz)
              right(irhoe) = right(irhoe) + p(i+1, j, k)
              if (correctfork) then
                left(itu1) = left(itu1) + w(i, j, k, itu1)
                right(itu1) = right(itu1) + w(i+1, j, k, itu1)
              end if
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = si(i, j, k, 1)
              sy = si(i, j, k, 2)
              sz = si(i, j, k, 3)
              por = pori(i, j, k)
              if (addgridvelocities) sface = sfacei(i, j, k)
! compute the value of gamma on the face. take an
! arithmetic average of the two states.
              gammaface = half*(gamma(i, j, k)+gamma(i+1, j, k))
! compute the dissipative flux across the interface.
              call riemannflux(left, right, flux)
! and scatter it to the left and right.
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fw(i+1, j, k, irho) = fw(i+1, j, k, irho) - flux(irho)
              fw(i+1, j, k, imx) = fw(i+1, j, k, imx) - flux(imx)
              fw(i+1, j, k, imy) = fw(i+1, j, k, imy) - flux(imy)
              fw(i+1, j, k, imz) = fw(i+1, j, k, imz) - flux(imz)
              fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) - flux(irhoe)
! store the density flux in the mass flow of the
! appropriate sliding mesh interface.
            end do
          end do
        end do
! fluxes in the j-direction.
        do k=2,kl
          do j=1,jl
            do i=2,il
! store the three differences used in the interpolation
! in du1, du2, du3.
              du1(irho) = w(i, j, k, irho) - w(i, j-1, k, irho)
              du2(irho) = w(i, j+1, k, irho) - w(i, j, k, irho)
              du3(irho) = w(i, j+2, k, irho) - w(i, j+1, k, irho)
              du1(ivx) = w(i, j, k, ivx) - w(i, j-1, k, ivx)
              du2(ivx) = w(i, j+1, k, ivx) - w(i, j, k, ivx)
              du3(ivx) = w(i, j+2, k, ivx) - w(i, j+1, k, ivx)
              du1(ivy) = w(i, j, k, ivy) - w(i, j-1, k, ivy)
              du2(ivy) = w(i, j+1, k, ivy) - w(i, j, k, ivy)
              du3(ivy) = w(i, j+2, k, ivy) - w(i, j+1, k, ivy)
              du1(ivz) = w(i, j, k, ivz) - w(i, j-1, k, ivz)
              du2(ivz) = w(i, j+1, k, ivz) - w(i, j, k, ivz)
              du3(ivz) = w(i, j+2, k, ivz) - w(i, j+1, k, ivz)
              du1(irhoe) = p(i, j, k) - p(i, j-1, k)
              du2(irhoe) = p(i, j+1, k) - p(i, j, k)
              du3(irhoe) = p(i, j+2, k) - p(i, j+1, k)
              if (correctfork) then
                du1(itu1) = w(i, j, k, itu1) - w(i, j-1, k, itu1)
                du2(itu1) = w(i, j+1, k, itu1) - w(i, j, k, itu1)
                du3(itu1) = w(i, j+2, k, itu1) - w(i, j+1, k, itu1)
              end if
! compute the differences from the first order scheme.
              call leftrightstate(du1, du2, du3, rotmatrixj, left, right&
&                          )
! add the first order part to the currently stored
! differences, such that the correct state vector
! is stored.
              left(irho) = left(irho) + w(i, j, k, irho)
              left(ivx) = left(ivx) + w(i, j, k, ivx)
              left(ivy) = left(ivy) + w(i, j, k, ivy)
              left(ivz) = left(ivz) + w(i, j, k, ivz)
              left(irhoe) = left(irhoe) + p(i, j, k)
              right(irho) = right(irho) + w(i, j+1, k, irho)
              right(ivx) = right(ivx) + w(i, j+1, k, ivx)
              right(ivy) = right(ivy) + w(i, j+1, k, ivy)
              right(ivz) = right(ivz) + w(i, j+1, k, ivz)
              right(irhoe) = right(irhoe) + p(i, j+1, k)
              if (correctfork) then
                left(itu1) = left(itu1) + w(i, j, k, itu1)
                right(itu1) = right(itu1) + w(i, j+1, k, itu1)
              end if
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = sj(i, j, k, 1)
              sy = sj(i, j, k, 2)
              sz = sj(i, j, k, 3)
              por = porj(i, j, k)
              if (addgridvelocities) sface = sfacej(i, j, k)
! compute the value of gamma on the face. take an
! arithmetic average of the two states.
              gammaface = half*(gamma(i, j, k)+gamma(i, j+1, k))
! compute the dissipative flux across the interface.
              call riemannflux(left, right, flux)
! and scatter it to the left and right.
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fw(i, j+1, k, irho) = fw(i, j+1, k, irho) - flux(irho)
              fw(i, j+1, k, imx) = fw(i, j+1, k, imx) - flux(imx)
              fw(i, j+1, k, imy) = fw(i, j+1, k, imy) - flux(imy)
              fw(i, j+1, k, imz) = fw(i, j+1, k, imz) - flux(imz)
              fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) - flux(irhoe)
! store the density flux in the mass flow of the
! appropriate sliding mesh interface.
            end do
          end do
        end do
! fluxes in the k-direction.
        do k=1,kl
          do j=2,jl
            do i=2,il
! store the three differences used in the interpolation
! in du1, du2, du3.
              du1(irho) = w(i, j, k, irho) - w(i, j, k-1, irho)
              du2(irho) = w(i, j, k+1, irho) - w(i, j, k, irho)
              du3(irho) = w(i, j, k+2, irho) - w(i, j, k+1, irho)
              du1(ivx) = w(i, j, k, ivx) - w(i, j, k-1, ivx)
              du2(ivx) = w(i, j, k+1, ivx) - w(i, j, k, ivx)
              du3(ivx) = w(i, j, k+2, ivx) - w(i, j, k+1, ivx)
              du1(ivy) = w(i, j, k, ivy) - w(i, j, k-1, ivy)
              du2(ivy) = w(i, j, k+1, ivy) - w(i, j, k, ivy)
              du3(ivy) = w(i, j, k+2, ivy) - w(i, j, k+1, ivy)
              du1(ivz) = w(i, j, k, ivz) - w(i, j, k-1, ivz)
              du2(ivz) = w(i, j, k+1, ivz) - w(i, j, k, ivz)
              du3(ivz) = w(i, j, k+2, ivz) - w(i, j, k+1, ivz)
              du1(irhoe) = p(i, j, k) - p(i, j, k-1)
              du2(irhoe) = p(i, j, k+1) - p(i, j, k)
              du3(irhoe) = p(i, j, k+2) - p(i, j, k+1)
              if (correctfork) then
                du1(itu1) = w(i, j, k, itu1) - w(i, j, k-1, itu1)
                du2(itu1) = w(i, j, k+1, itu1) - w(i, j, k, itu1)
                du3(itu1) = w(i, j, k+2, itu1) - w(i, j, k+1, itu1)
              end if
! compute the differences from the first order scheme.
              call leftrightstate(du1, du2, du3, rotmatrixk, left, right&
&                          )
! add the first order part to the currently stored
! differences, such that the correct state vector
! is stored.
              left(irho) = left(irho) + w(i, j, k, irho)
              left(ivx) = left(ivx) + w(i, j, k, ivx)
              left(ivy) = left(ivy) + w(i, j, k, ivy)
              left(ivz) = left(ivz) + w(i, j, k, ivz)
              left(irhoe) = left(irhoe) + p(i, j, k)
              right(irho) = right(irho) + w(i, j, k+1, irho)
              right(ivx) = right(ivx) + w(i, j, k+1, ivx)
              right(ivy) = right(ivy) + w(i, j, k+1, ivy)
              right(ivz) = right(ivz) + w(i, j, k+1, ivz)
              right(irhoe) = right(irhoe) + p(i, j, k+1)
              if (correctfork) then
                left(itu1) = left(itu1) + w(i, j, k, itu1)
                right(itu1) = right(itu1) + w(i, j, k+1, itu1)
              end if
! store the normal vector, the porosity and the
! mesh velocity if present.
              sx = sk(i, j, k, 1)
              sy = sk(i, j, k, 2)
              sz = sk(i, j, k, 3)
              por = pork(i, j, k)
              if (addgridvelocities) sface = sfacek(i, j, k)
! compute the value of gamma on the face. take an
! arithmetic average of the two states.
              gammaface = half*(gamma(i, j, k)+gamma(i, j, k+1))
! compute the dissipative flux across the interface.
              call riemannflux(left, right, flux)
! and scatter it to the left and right.
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fw(i, j, k+1, irho) = fw(i, j, k+1, irho) - flux(irho)
              fw(i, j, k+1, imx) = fw(i, j, k+1, imx) - flux(imx)
              fw(i, j, k+1, imy) = fw(i, j, k+1, imy) - flux(imy)
              fw(i, j, k+1, imz) = fw(i, j, k+1, imz) - flux(imz)
              fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) - flux(irhoe)
! store the density flux in the mass flow of the
! appropriate sliding mesh interface.
            end do
          end do
        end do
      end if
    end if
 
  contains
!      ==================================================================
    subroutine leftrightstate(du1, du2, du3, rotmatrix, left, right)
      implicit none
!
!        local parameter.
!
      real(kind=realtype), parameter :: epslim=1.e-10_realtype
!
!        subroutine arguments.
!
      real(kind=realtype), dimension(:), intent(inout) :: du1, du2, du3
      real(kind=realtype), dimension(:), intent(out) :: left, right
      real(kind=realtype), dimension(:, :, :, :, :), pointer :: &
&     rotmatrix
!
!        local variables.
!
      integer(kind=inttype) :: l
      real(kind=realtype) :: rl1, rl2, rr1, rr2, tmp, dvx, dvy, dvz
      real(kind=realtype), dimension(3, 3) :: rot
      intrinsic abs
      intrinsic max
      intrinsic sign
      intrinsic min
      real(kind=realtype) :: x1
      real(kind=realtype) :: y1
      real(kind=realtype) :: y2
      real(kind=realtype) :: x2
      real(kind=realtype) :: y3
      real(kind=realtype) :: y4
      real(kind=realtype) :: x3
      real(kind=realtype) :: x4
      real(kind=realtype) :: x5
      real(kind=realtype) :: x6
      real(kind=realtype) :: max2
      real(kind=realtype) :: max3
      real(kind=realtype) :: max4
      real(kind=realtype) :: max5
      real(kind=realtype) :: max6
      real(kind=realtype) :: max7
! check if the velocity components should be transformed to
! the cylindrical frame.
      if (rotationalperiodic) then
! store the rotation matrix a bit easier. note that the i,j,k
! come from the main subroutine.
        rot(1, 1) = rotmatrix(i, j, k, 1, 1)
        rot(1, 2) = rotmatrix(i, j, k, 1, 2)
        rot(1, 3) = rotmatrix(i, j, k, 1, 3)
        rot(2, 1) = rotmatrix(i, j, k, 2, 1)
        rot(2, 2) = rotmatrix(i, j, k, 2, 2)
        rot(2, 3) = rotmatrix(i, j, k, 2, 3)
        rot(3, 1) = rotmatrix(i, j, k, 3, 1)
        rot(3, 2) = rotmatrix(i, j, k, 3, 2)
        rot(3, 3) = rotmatrix(i, j, k, 3, 3)
! apply the transformation to the velocity components
! of du1, du2 and du3.
        dvx = du1(ivx)
        dvy = du1(ivy)
        dvz = du1(ivz)
        du1(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du1(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du1(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
        dvx = du2(ivx)
        dvy = du2(ivy)
        dvz = du2(ivz)
        du2(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du2(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du2(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
        dvx = du3(ivx)
        dvy = du3(ivy)
        dvz = du3(ivz)
        du3(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du3(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du3(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
      end if
! determine the limiter used.
      select case  (limused) 
      case (nolimiter) 
! linear interpolation; no limiter.
! loop over the number of variables to be interpolated.
        do l=1,nwint
          left(l) = omk*du1(l) + opk*du2(l)
          right(l) = -(omk*du3(l)) - opk*du2(l)
        end do
      case (vanalbeda) 
!          ==============================================================
! nonlinear interpolation using the van albeda limiter.
! loop over the number of variables to be interpolated.
        do l=1,nwint
          if (du2(l) .ge. 0.) then
            x1 = du2(l)
          else
            x1 = -du2(l)
          end if
          if (x1 .lt. epslim) then
            max2 = epslim
          else
            max2 = x1
          end if
! compute the limiter argument rl1, rl2, rr1 and rr2.
! note the cut off to 0.0.
          tmp = one/sign(max2, du2(l))
          if (du1(l) .ge. 0.) then
            x3 = du1(l)
          else
            x3 = -du1(l)
          end if
          if (x3 .lt. epslim) then
            max4 = epslim
          else
            max4 = x3
          end if
          y1 = du2(l)/sign(max4, du1(l))
          if (zero .lt. y1) then
            rl1 = y1
          else
            rl1 = zero
          end if
          if (zero .lt. du1(l)*tmp) then
            rl2 = du1(l)*tmp
          else
            rl2 = zero
          end if
          if (zero .lt. du3(l)*tmp) then
            rr1 = du3(l)*tmp
          else
            rr1 = zero
          end if
          if (du3(l) .ge. 0.) then
            x4 = du3(l)
          else
            x4 = -du3(l)
          end if
          if (x4 .lt. epslim) then
            max5 = epslim
          else
            max5 = x4
          end if
          y2 = du2(l)/sign(max5, du3(l))
          if (zero .lt. y2) then
            rr2 = y2
          else
            rr2 = zero
          end if
! compute the corresponding limiter values.
          rl1 = rl1*(rl1+one)/(rl1*rl1+one)
          rl2 = rl2*(rl2+one)/(rl2*rl2+one)
          rr1 = rr1*(rr1+one)/(rr1*rr1+one)
          rr2 = rr2*(rr2+one)/(rr2*rr2+one)
! compute the nonlinear corrections to the first order
! scheme.
          left(l) = omk*rl1*du1(l) + opk*rl2*du2(l)
          right(l) = -(opk*rr1*du2(l)) - omk*rr2*du3(l)
        end do
      case (minmod) 
!          ==============================================================
! nonlinear interpolation using the minmod limiter.
! loop over the number of variables to be interpolated.
        do l=1,nwint
          if (du2(l) .ge. 0.) then
            x2 = du2(l)
          else
            x2 = -du2(l)
          end if
          if (x2 .lt. epslim) then
            max3 = epslim
          else
            max3 = x2
          end if
! compute the limiter argument rl1, rl2, rr1 and rr2.
! note the cut off to 0.0.
          tmp = one/sign(max3, du2(l))
          if (du1(l) .ge. 0.) then
            x5 = du1(l)
          else
            x5 = -du1(l)
          end if
          if (x5 .lt. epslim) then
            max6 = epslim
          else
            max6 = x5
          end if
          y3 = du2(l)/sign(max6, du1(l))
          if (zero .lt. y3) then
            rl1 = y3
          else
            rl1 = zero
          end if
          if (zero .lt. du1(l)*tmp) then
            rl2 = du1(l)*tmp
          else
            rl2 = zero
          end if
          if (zero .lt. du3(l)*tmp) then
            rr1 = du3(l)*tmp
          else
            rr1 = zero
          end if
          if (du3(l) .ge. 0.) then
            x6 = du3(l)
          else
            x6 = -du3(l)
          end if
          if (x6 .lt. epslim) then
            max7 = epslim
          else
            max7 = x6
          end if
          y4 = du2(l)/sign(max7, du3(l))
          if (zero .lt. y4) then
            rr2 = y4
          else
            rr2 = zero
          end if
          if (one .gt. factminmod*rl1) then
            rl1 = factminmod*rl1
          else
            rl1 = one
          end if
          if (one .gt. factminmod*rl2) then
            rl2 = factminmod*rl2
          else
            rl2 = one
          end if
          if (one .gt. factminmod*rr1) then
            rr1 = factminmod*rr1
          else
            rr1 = one
          end if
          if (one .gt. factminmod*rr2) then
            rr2 = factminmod*rr2
          else
            rr2 = one
          end if
! compute the nonlinear corrections to the first order
! scheme.
          left(l) = omk*rl1*du1(l) + opk*rl2*du2(l)
          right(l) = -(opk*rr1*du2(l)) - omk*rr2*du3(l)
        end do
      end select
! in case only a first order scheme must be used for the
! turbulent transport equations, set the correction for the
! turbulent kinetic energy to 0.
      if (firstorderk) then
        left(itu1) = zero
        right(itu1) = zero
      end if
! for rotational periodic problems transform the velocity
! differences back to cartesian again. note that now the
! transpose of the rotation matrix must be used.
      if (rotationalperiodic) then
! left state.
        dvx = left(ivx)
        dvy = left(ivy)
        dvz = left(ivz)
        left(ivx) = rot(1, 1)*dvx + rot(2, 1)*dvy + rot(3, 1)*dvz
        left(ivy) = rot(1, 2)*dvx + rot(2, 2)*dvy + rot(3, 2)*dvz
        left(ivz) = rot(1, 3)*dvx + rot(2, 3)*dvy + rot(3, 3)*dvz
! right state.
        dvx = right(ivx)
        dvy = right(ivy)
        dvz = right(ivz)
        right(ivx) = rot(1, 1)*dvx + rot(2, 1)*dvy + rot(3, 1)*dvz
        right(ivy) = rot(1, 2)*dvx + rot(2, 2)*dvy + rot(3, 2)*dvz
        right(ivz) = rot(1, 3)*dvx + rot(2, 3)*dvy + rot(3, 3)*dvz
      end if
    end subroutine leftrightstate
 
!        ================================================================
    subroutine riemannflux(left, right, flux)
      implicit none
!
!        subroutine arguments.
!
      real(kind=realtype), dimension(*), intent(in) :: left, right
      real(kind=realtype), dimension(*), intent(out) :: flux
!
!        local variables.
!
      real(kind=realtype) :: porflux, rface
      real(kind=realtype) :: etl, etr, z1l, z1r, tmp
      real(kind=realtype) :: dr, dru, drv, drw, dre, drk
      real(kind=realtype) :: ravg, uavg, vavg, wavg, havg, kavg
      real(kind=realtype) :: alphaavg, a2avg, aavg, unavg
      real(kind=realtype) :: ovaavg, ova2avg, area, eta
      real(kind=realtype) :: gm1, gm53
      real(kind=realtype) :: lam1, lam2, lam3
      real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
      real(kind=realtype), dimension(2) :: ktmp
      intrinsic sqrt
      intrinsic max
      intrinsic abs
      real(kind=realtype) :: x1
      real(kind=realtype) :: x2
      real(realtype) :: max2
      real(kind=realtype) :: abs1
      real(kind=realtype) :: abs2
! set the porosity for the flux. the default value, 0.5*rfil, is
! a scaling factor where an rfil != 1 is taken into account.
      porflux = half*rfil
      if (por .eq. noflux .or. por .eq. boundflux) porflux = zero
! abbreviate some expressions in which gamma occurs.
      gm1 = gammaface - one
      gm53 = gammaface - five*third
! determine which riemann solver must be solved.
      select case  (riemannused) 
      case (roe) 
! determine the preconditioner used.
        select case  (precond) 
        case (noprecond) 
! no preconditioner used. use the roe scheme of the
! standard equations.
! compute the square root of the left and right densities
! and the inverse of the sum.
          z1l = sqrt(left(irho))
          z1r = sqrt(right(irho))
          tmp = one/(z1l+z1r)
! compute some variables depending whether or not a
! k-equation is present.
          if (correctfork) then
! store the left and right kinetic energy in ktmp,
! which is needed to compute the total energy.
            ktmp(1) = left(itu1)
            ktmp(2) = right(itu1)
! store the difference of the turbulent kinetic energy
! per unit volume, i.e. the conserved variable.
            drk = right(irho)*right(itu1) - left(irho)*left(itu1)
! compute the average turbulent energy per unit mass
! using roe averages.
            kavg = tmp*(z1l*left(itu1)+z1r*right(itu1))
          else
! set the difference of the turbulent kinetic energy
! per unit volume and the averaged kinetic energy per
! unit mass to zero.
            drk = 0.0
            kavg = 0.0
          end if
! compute the total energy of the left and right state.
          call etot(left(irho), left(ivx), left(ivy), left(ivz), left(&
&             irhoe), ktmp(1), etl, correctfork)
          call etot(right(irho), right(ivx), right(ivy), right(ivz), &
&             right(irhoe), ktmp(2), etr, correctfork)
! compute the difference of the conservative mean
! flow variables.
          dr = right(irho) - left(irho)
          dru = right(irho)*right(ivx) - left(irho)*left(ivx)
          drv = right(irho)*right(ivy) - left(irho)*left(ivy)
          drw = right(irho)*right(ivz) - left(irho)*left(ivz)
          dre = etr - etl
! compute the roe average variables, which can be
! computed directly from the average roe vector.
          ravg = fourth*(z1r+z1l)**2
          uavg = tmp*(z1l*left(ivx)+z1r*right(ivx))
          vavg = tmp*(z1l*left(ivy)+z1r*right(ivy))
          wavg = tmp*(z1l*left(ivz)+z1r*right(ivz))
          havg = tmp*((etl+left(irhoe))/z1l+(etr+right(irhoe))/z1r)
! compute the unit vector and store the area of the
! normal. also compute the unit normal velocity of the face.
          area = sqrt(sx**2 + sy**2 + sz**2)
          if (1.e-25_realtype .lt. area) then
            max2 = area
          else
            max2 = 1.e-25_realtype
          end if
          tmp = one/max2
          sx = sx*tmp
          sy = sy*tmp
          sz = sz*tmp
          rface = sface*tmp
! compute some dependent variables at the roe
! average state.
          alphaavg = half*(uavg**2+vavg**2+wavg**2)
          if (gm1*(havg-alphaavg) - gm53*kavg .ge. 0.) then
            a2avg = gm1*(havg-alphaavg) - gm53*kavg
          else
            a2avg = -(gm1*(havg-alphaavg)-gm53*kavg)
          end if
          aavg = sqrt(a2avg)
          unavg = uavg*sx + vavg*sy + wavg*sz
          ovaavg = one/aavg
          ova2avg = one/a2avg
! set for a boundary the normal velocity to rface, the
! normal velocity of the boundary.
          if (por .eq. boundflux) unavg = rface
          x1 = (left(ivx)-right(ivx))*sx + (left(ivy)-right(ivy))*sy + (&
&           left(ivz)-right(ivz))*sz
          if (x1 .ge. 0.) then
            abs1 = x1
          else
            abs1 = -x1
          end if
          x2 = sqrt(gammaface*left(irhoe)/left(irho)) - sqrt(gammaface*&
&           right(irhoe)/right(irho))
          if (x2 .ge. 0.) then
            abs2 = x2
          else
            abs2 = -x2
          end if
! compute the coefficient eta for the entropy correction.
! at the moment a 1d entropy correction is used, which
! removes expansion shocks. although it also reduces the
! carbuncle phenomenon, it does not remove it completely.
! in other to do that a multi-dimensional entropy fix is
! needed, see sanders et. al, jcp, vol. 145, 1998,
! pp. 511 - 537. although relatively easy to implement,
! an efficient implementation requires the storage of
! all the left and right states, which is rather
! expensive in terms of memory.
          eta = half*(abs1+abs2)
          if (unavg - rface + aavg .ge. 0.) then
            lam1 = unavg - rface + aavg
          else
            lam1 = -(unavg-rface+aavg)
          end if
          if (unavg - rface - aavg .ge. 0.) then
            lam2 = unavg - rface - aavg
          else
            lam2 = -(unavg-rface-aavg)
          end if
          if (unavg - rface .ge. 0.) then
            lam3 = unavg - rface
          else
            lam3 = -(unavg-rface)
          end if
! apply the entropy correction to the eigenvalues.
          tmp = two*eta
          if (lam1 .lt. tmp) lam1 = eta + fourth*lam1*lam1/eta
          if (lam2 .lt. tmp) lam2 = eta + fourth*lam2*lam2/eta
          if (lam3 .lt. tmp) lam3 = eta + fourth*lam3*lam3/eta
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
          lam1 = lam1*area
          lam2 = lam2*area
          lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
          abv1 = half*(lam1+lam2)
          abv2 = half*(lam1-lam2)
          abv3 = abv1 - lam3
          abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53&
&           *drk
          abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
          abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
          abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute the dissipation term, -|a| (wr - wl), which is
! multiplied by porflux. note that porflux is either
! 0.0 or 0.5*rfil.
          flux(irho) = -(porflux*(lam3*dr+abv6))
          flux(imx) = -(porflux*(lam3*dru+uavg*abv6+sx*abv7))
          flux(imy) = -(porflux*(lam3*drv+vavg*abv6+sy*abv7))
          flux(imz) = -(porflux*(lam3*drw+wavg*abv6+sz*abv7))
          flux(irhoe) = -(porflux*(lam3*dre+havg*abv6+unavg*abv7))
!          tmp = max(lam1,lam2,lam3)
!          flux(irho)  = -porflux*(tmp*dr)
!          flux(imx)   = -porflux*(tmp*dru)
!          flux(imy)   = -porflux*(tmp*drv)
!          flux(imz)   = -porflux*(tmp*drw)
!          flux(irhoe) = -porflux*(tmp*dre)
        case (turkel) 
          call terminate('riemannflux', &
&                  'turkel preconditioner not implemented yet')
        case (choimerkle) 
          call terminate('riemannflux', &
&                  'choi merkle preconditioner not implemented yet')
        end select
      case (vanleer) 
        call terminate('riemannflux', 'van leer fvs not implemented yet'&
&               )
      case (ausmdv) 
        call terminate('riemannflux', 'ausmdv fvs not implemented yet')
      end select
    end subroutine riemannflux
 
  end subroutine inviscidupwindflux
 
!  differentiation of viscousflux in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: *aa *w *fw
!   with respect to varying inputs: *rev *aa *wx *wy *wz *w *rlv
!                *qx *qy *qz *ux *uy *uz *vx *vy *vz *fw
!   rw status of diff variables: *rev:out *aa:incr *wx:out *wy:out
!                *wz:out *w:incr *rlv:out *qx:out *qy:out *qz:out
!                *ux:out *uy:out *uz:out *vx:out *vy:out *vz:out
!                *fw:in-out
!   plus diff mem management of: rev:in aa:in wx:in wy:in wz:in
!                w:in rlv:in qx:in qy:in qz:in ux:in uy:in uz:in
!                vx:in vy:in vz:in fw:in
  subroutine viscousflux_fast_b()
!
!       viscousflux computes the viscous fluxes using a central
!       difference scheme for a block.
!       it is assumed that the pointers in block pointer already point
!       to the correct block.
!
    use constants
    use blockpointers
    use flowvarrefstate
    use inputphysics
    use iteration
    implicit none
!
!      local parameter.
!
    real(kind=realtype), parameter :: twothird=two*third
    real(kind=realtype), parameter :: xminn=1.e-14_realtype
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k, ii
    real(kind=realtype) :: rfilv, por, mul, mue, mut, heatcoef
    real(kind=realtype) :: muld, mued, mutd, heatcoefd
    real(kind=realtype) :: gm1, factlamheat, factturbheat
    real(kind=realtype) :: u_x, u_y, u_z, v_x, v_y, v_z, w_x, w_y, w_z
    real(kind=realtype) :: u_xd, u_yd, u_zd, v_xd, v_yd, v_zd, w_xd, &
&   w_yd, w_zd
    real(kind=realtype) :: q_x, q_y, q_z, ubar, vbar, wbar
    real(kind=realtype) :: q_xd, q_yd, q_zd, ubard, vbard, wbard
    real(kind=realtype) :: corr, ssx, ssy, ssz, ss, fracdiv
    real(kind=realtype) :: corrd, fracdivd
    real(kind=realtype) :: tauxx, tauyy, tauzz
    real(kind=realtype) :: tauxxd, tauyyd, tauzzd
    real(kind=realtype) :: tauxy, tauxz, tauyz
    real(kind=realtype) :: tauxyd, tauxzd, tauyzd
    real(kind=realtype) :: tauxxs, tauyys, tauzzs
    real(kind=realtype) :: tauxxsd, tauyysd, tauzzsd
    real(kind=realtype) :: tauxys, tauxzs, tauyzs
    real(kind=realtype) :: tauxysd, tauxzsd, tauyzsd
    real(kind=realtype) :: exx, eyy, ezz
    real(kind=realtype) :: exxd, eyyd, ezzd
    real(kind=realtype) :: exy, exz, eyz
    real(kind=realtype) :: exyd, exzd, eyzd
    real(kind=realtype) :: wxy, wxz, wyz, wyx, wzx, wzy
    real(kind=realtype) :: wxyd, wxzd, wyzd, wyxd, wzxd, wzyd
    real(kind=realtype) :: den, ccr1, fact
    real(kind=realtype) :: dend, factd
    real(kind=realtype) :: fmx, fmy, fmz, frhoe
    real(kind=realtype) :: fmxd, fmyd, fmzd, frhoed
    logical :: correctfork, storewalltensor
    intrinsic abs
    intrinsic mod
    intrinsic sqrt
    intrinsic max
    real(kind=realtype) :: abs0
    real(kind=realtype) :: tempd
    integer :: branch
    real(kind=realtype) :: tempd0
    real(kind=realtype) :: tempd1
! set qcr parameters
    ccr1 = 0.3_realtype
! set rfilv to rfil to indicate that this is the viscous part.
! if rfilv == 0 the viscous residuals need not to be computed
! and a return can be made.
    rfilv = rfil
    if (rfilv .ge. 0.) then
      abs0 = rfilv
    else
      abs0 = -rfilv
    end if
    if (abs0 .lt. thresholdreal) then
      if (associated(revd)) revd = 0.0_8
      if (associated(wxd)) wxd = 0.0_8
      if (associated(wyd)) wyd = 0.0_8
      if (associated(wzd)) wzd = 0.0_8
      if (associated(rlvd)) rlvd = 0.0_8
      if (associated(qxd)) qxd = 0.0_8
      if (associated(qyd)) qyd = 0.0_8
      if (associated(qzd)) qzd = 0.0_8
      if (associated(uxd)) uxd = 0.0_8
      if (associated(uyd)) uyd = 0.0_8
      if (associated(uzd)) uzd = 0.0_8
      if (associated(vxd)) vxd = 0.0_8
      if (associated(vyd)) vyd = 0.0_8
      if (associated(vzd)) vzd = 0.0_8
    else
      if (associated(revd)) revd = 0.0_8
      if (associated(wxd)) wxd = 0.0_8
      if (associated(wyd)) wyd = 0.0_8
      if (associated(wzd)) wzd = 0.0_8
      if (associated(rlvd)) rlvd = 0.0_8
      if (associated(qxd)) qxd = 0.0_8
      if (associated(qyd)) qyd = 0.0_8
      if (associated(qzd)) qzd = 0.0_8
      if (associated(uxd)) uxd = 0.0_8
      if (associated(uyd)) uyd = 0.0_8
      if (associated(uzd)) uzd = 0.0_8
      if (associated(vxd)) vxd = 0.0_8
      if (associated(vyd)) vyd = 0.0_8
      if (associated(vzd)) vzd = 0.0_8
      mued = 0.0_8
      mue = zero
      if (associated(revd)) revd = 0.0_8
      if (associated(wxd)) wxd = 0.0_8
      if (associated(wyd)) wyd = 0.0_8
      if (associated(wzd)) wzd = 0.0_8
      if (associated(rlvd)) rlvd = 0.0_8
      if (associated(qxd)) qxd = 0.0_8
      if (associated(qyd)) qyd = 0.0_8
      if (associated(qzd)) qzd = 0.0_8
      if (associated(uxd)) uxd = 0.0_8
      if (associated(uyd)) uyd = 0.0_8
      if (associated(uzd)) uzd = 0.0_8
      if (associated(vxd)) vxd = 0.0_8
      if (associated(vyd)) vyd = 0.0_8
      if (associated(vzd)) vzd = 0.0_8
      mued = 0.0_8
!$bwd-of ii-loop 
      do ii=0,il*ny*nz-1
        i = mod(ii, il) + 1
        j = mod(ii/il, ny) + 2
        k = ii/(il*ny) + 2
! set the value of the porosity. if not zero, it is set
! to average the eddy-viscosity and to take the factor
! rfilv into account.
        por = half*rfilv
        if (pori(i, j, k) .eq. noflux) por = zero
! compute the laminar and (if present) the eddy viscosities
! multiplied the porosity. compute the factor in front of
! the gradients of the speed of sound squared for the heat
! flux.
        mul = por*(rlv(i, j, k)+rlv(i+1, j, k))
        if (eddymodel) then
          mue = por*(rev(i, j, k)+rev(i+1, j, k))
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        mut = mul + mue
        gm1 = half*(gamma(i, j, k)+gamma(i+1, j, k)) - one
        factlamheat = one/(prandtl*gm1)
        factturbheat = one/(prandtlturb*gm1)
        heatcoef = mul*factlamheat + mue*factturbheat
! compute the gradients at the face by averaging the four
! nodal values.
        u_x = fourth*(ux(i, j-1, k-1)+ux(i, j, k-1)+ux(i, j-1, k)+ux(i, &
&         j, k))
        u_y = fourth*(uy(i, j-1, k-1)+uy(i, j, k-1)+uy(i, j-1, k)+uy(i, &
&         j, k))
        u_z = fourth*(uz(i, j-1, k-1)+uz(i, j, k-1)+uz(i, j-1, k)+uz(i, &
&         j, k))
        v_x = fourth*(vx(i, j-1, k-1)+vx(i, j, k-1)+vx(i, j-1, k)+vx(i, &
&         j, k))
        v_y = fourth*(vy(i, j-1, k-1)+vy(i, j, k-1)+vy(i, j-1, k)+vy(i, &
&         j, k))
        v_z = fourth*(vz(i, j-1, k-1)+vz(i, j, k-1)+vz(i, j-1, k)+vz(i, &
&         j, k))
        w_x = fourth*(wx(i, j-1, k-1)+wx(i, j, k-1)+wx(i, j-1, k)+wx(i, &
&         j, k))
        w_y = fourth*(wy(i, j-1, k-1)+wy(i, j, k-1)+wy(i, j-1, k)+wy(i, &
&         j, k))
        w_z = fourth*(wz(i, j-1, k-1)+wz(i, j, k-1)+wz(i, j-1, k)+wz(i, &
&         j, k))
        q_x = fourth*(qx(i, j-1, k-1)+qx(i, j, k-1)+qx(i, j-1, k)+qx(i, &
&         j, k))
        q_y = fourth*(qy(i, j-1, k-1)+qy(i, j, k-1)+qy(i, j-1, k)+qy(i, &
&         j, k))
        q_z = fourth*(qz(i, j-1, k-1)+qz(i, j, k-1)+qz(i, j-1, k)+qz(i, &
&         j, k))
! the gradients in the normal direction are corrected, such
! that no averaging takes places here.
! first determine the vector in the direction from the
! cell center i to cell center i+1.
        ssx = eighth*(x(i+1, j-1, k-1, 1)-x(i-1, j-1, k-1, 1)+x(i+1, j-1&
&         , k, 1)-x(i-1, j-1, k, 1)+x(i+1, j, k-1, 1)-x(i-1, j, k-1, 1)+&
&         x(i+1, j, k, 1)-x(i-1, j, k, 1))
        ssy = eighth*(x(i+1, j-1, k-1, 2)-x(i-1, j-1, k-1, 2)+x(i+1, j-1&
&         , k, 2)-x(i-1, j-1, k, 2)+x(i+1, j, k-1, 2)-x(i-1, j, k-1, 2)+&
&         x(i+1, j, k, 2)-x(i-1, j, k, 2))
        ssz = eighth*(x(i+1, j-1, k-1, 3)-x(i-1, j-1, k-1, 3)+x(i+1, j-1&
&         , k, 3)-x(i-1, j-1, k, 3)+x(i+1, j, k-1, 3)-x(i-1, j, k-1, 3)+&
&         x(i+1, j, k, 3)-x(i-1, j, k, 3))
! determine the length of this vector and create the
! unit normal.
        ss = one/sqrt(ssx*ssx+ssy*ssy+ssz*ssz)
        ssx = ss*ssx
        ssy = ss*ssy
        ssz = ss*ssz
! correct the gradients.
        corr = u_x*ssx + u_y*ssy + u_z*ssz - (w(i+1, j, k, ivx)-w(i, j, &
&         k, ivx))*ss
        u_x = u_x - corr*ssx
        u_y = u_y - corr*ssy
        u_z = u_z - corr*ssz
        corr = v_x*ssx + v_y*ssy + v_z*ssz - (w(i+1, j, k, ivy)-w(i, j, &
&         k, ivy))*ss
        v_x = v_x - corr*ssx
        v_y = v_y - corr*ssy
        v_z = v_z - corr*ssz
        corr = w_x*ssx + w_y*ssy + w_z*ssz - (w(i+1, j, k, ivz)-w(i, j, &
&         k, ivz))*ss
        w_x = w_x - corr*ssx
        w_y = w_y - corr*ssy
        w_z = w_z - corr*ssz
        corr = q_x*ssx + q_y*ssy + q_z*ssz + (aa(i+1, j, k)-aa(i, j, k))&
&         *ss
        q_x = q_x - corr*ssx
        q_y = q_y - corr*ssy
        q_z = q_z - corr*ssz
! compute the stress tensor and the heat flux vector.
! we remove the viscosity from the stress tensor (tau)
! to define taus since we still need to separate between
! laminar and turbulent stress for qcr.
! therefore, laminar tau = mue*taus, turbulent
! tau = mue*taus, and total tau = mut*taus.
        fracdiv = twothird*(u_x+v_y+w_z)
        tauxxs = two*u_x - fracdiv
        tauyys = two*v_y - fracdiv
        tauzzs = two*w_z - fracdiv
        tauxys = u_y + v_x
        tauxzs = u_z + w_x
        tauyzs = v_z + w_y
! add qcr corrections if necessary
        if (useqcr) then
! in the qcr formulation, we add an extra term to the turbulent stress tensor:
!
! tau_ij,qcr = tau_ij - e_ij
!
! where, according to tmr website (http://turbmodels.larc.nasa.gov/spalart.html):
!
! e_ij = ccr1*(o_ik*tau_jk + o_jk*tau_ik)
!
! we are computing o_ik as follows:
!
! o_ik = 2*w_ik/den
!
! remember that the tau_ij in e_ij should use only the eddy viscosity!
! compute denominator
          den = sqrt(u_x*u_x + u_y*u_y + u_z*u_z + v_x*v_x + v_y*v_y + &
&           v_z*v_z + w_x*w_x + w_y*w_y + w_z*w_z)
          if (den .lt. xminn) then
            den = xminn
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
            den = den
          end if
! compute factor that will multiply all tensor components.
! here we add the eddy viscosity that should multiply the stress tensor (tau)
! components as well.
          fact = mue*ccr1/den
! compute off-diagonal terms of vorticity tensor (we will ommit the 1/2)
! the diagonals of the vorticity tensor components are always zero
          wxy = u_y - v_x
          wxz = u_z - w_x
          wyz = v_z - w_y
          wyx = -wxy
          wzx = -wxz
          wzy = -wyz
! compute the extra terms of the boussinesq relation
          exx = fact*(wxy*tauxys+wxz*tauxzs)*two
          eyy = fact*(wyx*tauxys+wyz*tauyzs)*two
          ezz = fact*(wzx*tauxzs+wzy*tauyzs)*two
          exy = fact*(wxy*tauyys+wxz*tauyzs+wyx*tauxxs+wyz*tauxzs)
          exz = fact*(wxy*tauyzs+wxz*tauzzs+wzx*tauxxs+wzy*tauxys)
          eyz = fact*(wyx*tauxzs+wyz*tauzzs+wzx*tauxys+wzy*tauyys)
! apply the total viscosity to the stress tensor and add extra terms
          tauxx = mut*tauxxs - exx
          tauyy = mut*tauyys - eyy
          tauzz = mut*tauzzs - ezz
          tauxy = mut*tauxys - exy
          tauxz = mut*tauxzs - exz
          tauyz = mut*tauyzs - eyz
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
! just apply the total viscosity to the stress tensor
          tauxx = mut*tauxxs
          tauyy = mut*tauyys
          tauzz = mut*tauzzs
          tauxy = mut*tauxys
          tauxz = mut*tauxzs
          tauyz = mut*tauyzs
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
        ubar = half*(w(i, j, k, ivx)+w(i+1, j, k, ivx))
        vbar = half*(w(i, j, k, ivy)+w(i+1, j, k, ivy))
        wbar = half*(w(i, j, k, ivz)+w(i+1, j, k, ivz))
! compute the viscous fluxes for this i-face.
! update the residuals of cell i and i+1.
! store the stress tensor and the heat flux vector if this
! face is part of a viscous subface. both the cases i == 1
! and i == il must be tested.
        frhoed = fwd(i+1, j, k, irhoe) - fwd(i, j, k, irhoe)
        fmzd = fwd(i+1, j, k, imz) - fwd(i, j, k, imz)
        fmyd = fwd(i+1, j, k, imy) - fwd(i, j, k, imy)
        fmxd = fwd(i+1, j, k, imx) - fwd(i, j, k, imx)
        tempd1 = si(i, j, k, 1)*frhoed
        tempd0 = si(i, j, k, 2)*frhoed
        tempd = si(i, j, k, 3)*frhoed
        q_xd = -(si(i, j, k, 1)*frhoed)
        q_yd = -(si(i, j, k, 2)*frhoed)
        q_zd = -(si(i, j, k, 3)*frhoed)
        ubard = tauxz*tempd + tauxy*tempd0 + tauxx*tempd1
        tauxzd = ubar*tempd + wbar*tempd1 + si(i, j, k, 1)*fmzd + si(i, &
&         j, k, 3)*fmxd
        vbard = tauyz*tempd + tauyy*tempd0 + tauxy*tempd1
        tauyzd = vbar*tempd + wbar*tempd0 + si(i, j, k, 2)*fmzd + si(i, &
&         j, k, 3)*fmyd
        wbard = tauzz*tempd + tauyz*tempd0 + tauxz*tempd1
        tauzzd = wbar*tempd + si(i, j, k, 3)*fmzd
        tauxyd = ubar*tempd0 + vbar*tempd1 + si(i, j, k, 1)*fmyd + si(i&
&         , j, k, 2)*fmxd
        tauyyd = vbar*tempd0 + si(i, j, k, 2)*fmyd
        tauxxd = ubar*tempd1 + si(i, j, k, 1)*fmxd
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + half*wbard
        wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + half*wbard
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + half*vbard
        wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + half*vbard
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + half*ubard
        wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + half*ubard
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          eyzd = -tauyzd
          exzd = -tauxzd
          tempd1 = fact*eyzd
          tauxzsd = mut*tauxzd + wyx*tempd1
          tauxysd = mut*tauxyd + wzx*tempd1
          tauzzsd = mut*tauzzd + wyz*tempd1
          tauyysd = mut*tauyyd + wzy*tempd1
          wyxd = tauxzs*tempd1
          wyzd = tauzzs*tempd1
          wzxd = tauxys*tempd1
          wzyd = tauyys*tempd1
          tempd1 = fact*exzd
          mutd = tauyzs*tauyzd + tauxzs*tauxzd + tauxys*tauxyd + tauzzs*&
&           tauzzd + tauyys*tauyyd + tauxxs*tauxxd
          tauyzsd = mut*tauyzd + wxy*tempd1
          exyd = -tauxyd
          ezzd = -tauzzd
          eyyd = -tauyyd
          tauxxsd = mut*tauxxd + wzx*tempd1
          exxd = -tauxxd
          factd = (wyx*tauxzs+wyz*tauzzs+wzx*tauxys+wzy*tauyys)*eyzd + (&
&           wxy*tauyzs+wxz*tauzzs+wzx*tauxxs+wzy*tauxys)*exzd + (wxy*&
&           tauyys+wxz*tauyzs+wyx*tauxxs+wyz*tauxzs)*exyd + (wzx*tauxzs+&
&           wzy*tauyzs)*two*ezzd + (wyx*tauxys+wyz*tauyzs)*two*eyyd + (&
&           wxy*tauxys+wxz*tauxzs)*two*exxd
          wxyd = tauyzs*tempd1
          wxzd = tauzzs*tempd1
          tauzzsd = tauzzsd + wxz*tempd1
          wzxd = wzxd + tauxxs*tempd1
          wzyd = wzyd + tauxys*tempd1
          tauxysd = tauxysd + wzy*tempd1
          tempd1 = fact*exyd
          wxyd = wxyd + tauyys*tempd1
          tauyysd = tauyysd + wxy*tempd1
          wxzd = wxzd + tauyzs*tempd1
          tauyzsd = tauyzsd + wxz*tempd1
          wyxd = wyxd + tauxxs*tempd1
          tauxxsd = tauxxsd + wyx*tempd1
          wyzd = wyzd + tauxzs*tempd1
          tauxzsd = tauxzsd + wyz*tempd1
          tempd1 = fact*two*ezzd
          wzxd = wzxd + tauxzs*tempd1
          tauxzsd = tauxzsd + wzx*tempd1
          wzyd = wzyd + tauyzs*tempd1
          tauyzsd = tauyzsd + wzy*tempd1
          tempd1 = fact*two*eyyd
          wyxd = wyxd + tauxys*tempd1
          tauxysd = tauxysd + wyx*tempd1
          wyzd = wyzd + tauyzs*tempd1 - wzyd
          tauyzsd = tauyzsd + wyz*tempd1
          tempd1 = fact*two*exxd
          wxyd = wxyd + tauxys*tempd1 - wyxd
          tauxysd = tauxysd + wxy*tempd1
          wxzd = wxzd + tauxzs*tempd1 - wzxd
          tauxzsd = tauxzsd + wxz*tempd1
          v_zd = wyzd
          w_yd = -wyzd
          u_zd = wxzd
          w_xd = -wxzd
          u_yd = wxyd
          v_xd = -wxyd
          tempd1 = ccr1*factd/den
          mued = mued + tempd1
          dend = -(mue*tempd1/den)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) dend = 0.0_8
          if (u_x**2 + u_y**2 + u_z**2 + v_x**2 + v_y**2 + v_z**2 + w_x&
&             **2 + w_y**2 + w_z**2 .eq. 0.0_8) then
            tempd1 = 0.0_8
          else
            tempd1 = dend/(2.0*sqrt(u_x**2+u_y**2+u_z**2+v_x**2+v_y**2+&
&             v_z**2+w_x**2+w_y**2+w_z**2))
          end if
          u_xd = 2*u_x*tempd1
          u_yd = u_yd + 2*u_y*tempd1
          u_zd = u_zd + 2*u_z*tempd1
          v_xd = v_xd + 2*v_x*tempd1
          v_yd = 2*v_y*tempd1
          v_zd = v_zd + 2*v_z*tempd1
          w_xd = w_xd + 2*w_x*tempd1
          w_yd = w_yd + 2*w_y*tempd1
          w_zd = 2*w_z*tempd1
        else
          mutd = tauyzs*tauyzd + tauxzs*tauxzd + tauxys*tauxyd + tauzzs*&
&           tauzzd + tauyys*tauyyd + tauxxs*tauxxd
          tauyzsd = mut*tauyzd
          tauxzsd = mut*tauxzd
          tauxysd = mut*tauxyd
          tauzzsd = mut*tauzzd
          tauyysd = mut*tauyyd
          tauxxsd = mut*tauxxd
          u_xd = 0.0_8
          u_yd = 0.0_8
          u_zd = 0.0_8
          w_xd = 0.0_8
          w_yd = 0.0_8
          w_zd = 0.0_8
          v_xd = 0.0_8
          v_yd = 0.0_8
          v_zd = 0.0_8
        end if
        fracdivd = -tauzzsd - tauyysd - tauxxsd
        tempd1 = twothird*fracdivd
        heatcoefd = q_z*q_zd + q_y*q_yd + q_x*q_xd
        q_zd = heatcoef*q_zd
        q_yd = heatcoef*q_yd
        q_xd = heatcoef*q_xd
        v_zd = v_zd + tauyzsd
        w_yd = w_yd + tauyzsd
        u_zd = u_zd + tauxzsd
        w_xd = w_xd + tauxzsd
        u_yd = u_yd + tauxysd
        v_xd = v_xd + tauxysd
        w_zd = w_zd + two*tauzzsd + tempd1
        v_yd = v_yd + two*tauyysd + tempd1
        u_xd = u_xd + two*tauxxsd + tempd1
        corrd = -(ssz*q_zd) - ssy*q_yd - ssx*q_xd
        q_xd = q_xd + ssx*corrd
        q_yd = q_yd + ssy*corrd
        q_zd = q_zd + ssz*corrd
        aad(i+1, j, k) = aad(i+1, j, k) + ss*corrd
        aad(i, j, k) = aad(i, j, k) - ss*corrd
        corrd = -(ssz*w_zd) - ssy*w_yd - ssx*w_xd
        w_xd = w_xd + ssx*corrd
        w_yd = w_yd + ssy*corrd
        w_zd = w_zd + ssz*corrd
        wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) - ss*corrd
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + ss*corrd
        corrd = -(ssz*v_zd) - ssy*v_yd - ssx*v_xd
        v_xd = v_xd + ssx*corrd
        v_yd = v_yd + ssy*corrd
        v_zd = v_zd + ssz*corrd
        wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) - ss*corrd
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + ss*corrd
        corrd = -(ssz*u_zd) - ssy*u_yd - ssx*u_xd
        u_xd = u_xd + ssx*corrd
        u_yd = u_yd + ssy*corrd
        u_zd = u_zd + ssz*corrd
        wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) - ss*corrd
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + ss*corrd
        tempd1 = fourth*q_zd
        qzd(i, j-1, k-1) = qzd(i, j-1, k-1) + tempd1
        qzd(i, j, k-1) = qzd(i, j, k-1) + tempd1
        qzd(i, j-1, k) = qzd(i, j-1, k) + tempd1
        qzd(i, j, k) = qzd(i, j, k) + tempd1
        tempd1 = fourth*q_yd
        qyd(i, j-1, k-1) = qyd(i, j-1, k-1) + tempd1
        qyd(i, j, k-1) = qyd(i, j, k-1) + tempd1
        qyd(i, j-1, k) = qyd(i, j-1, k) + tempd1
        qyd(i, j, k) = qyd(i, j, k) + tempd1
        tempd1 = fourth*q_xd
        qxd(i, j-1, k-1) = qxd(i, j-1, k-1) + tempd1
        qxd(i, j, k-1) = qxd(i, j, k-1) + tempd1
        qxd(i, j-1, k) = qxd(i, j-1, k) + tempd1
        qxd(i, j, k) = qxd(i, j, k) + tempd1
        tempd1 = fourth*w_zd
        wzd(i, j-1, k-1) = wzd(i, j-1, k-1) + tempd1
        wzd(i, j, k-1) = wzd(i, j, k-1) + tempd1
        wzd(i, j-1, k) = wzd(i, j-1, k) + tempd1
        wzd(i, j, k) = wzd(i, j, k) + tempd1
        tempd1 = fourth*w_yd
        wyd(i, j-1, k-1) = wyd(i, j-1, k-1) + tempd1
        wyd(i, j, k-1) = wyd(i, j, k-1) + tempd1
        wyd(i, j-1, k) = wyd(i, j-1, k) + tempd1
        wyd(i, j, k) = wyd(i, j, k) + tempd1
        tempd1 = fourth*w_xd
        wxd(i, j-1, k-1) = wxd(i, j-1, k-1) + tempd1
        wxd(i, j, k-1) = wxd(i, j, k-1) + tempd1
        wxd(i, j-1, k) = wxd(i, j-1, k) + tempd1
        wxd(i, j, k) = wxd(i, j, k) + tempd1
        tempd1 = fourth*v_zd
        vzd(i, j-1, k-1) = vzd(i, j-1, k-1) + tempd1
        vzd(i, j, k-1) = vzd(i, j, k-1) + tempd1
        vzd(i, j-1, k) = vzd(i, j-1, k) + tempd1
        vzd(i, j, k) = vzd(i, j, k) + tempd1
        tempd1 = fourth*v_yd
        vyd(i, j-1, k-1) = vyd(i, j-1, k-1) + tempd1
        vyd(i, j, k-1) = vyd(i, j, k-1) + tempd1
        vyd(i, j-1, k) = vyd(i, j-1, k) + tempd1
        vyd(i, j, k) = vyd(i, j, k) + tempd1
        tempd1 = fourth*v_xd
        vxd(i, j-1, k-1) = vxd(i, j-1, k-1) + tempd1
        vxd(i, j, k-1) = vxd(i, j, k-1) + tempd1
        vxd(i, j-1, k) = vxd(i, j-1, k) + tempd1
        vxd(i, j, k) = vxd(i, j, k) + tempd1
        tempd1 = fourth*u_zd
        uzd(i, j-1, k-1) = uzd(i, j-1, k-1) + tempd1
        uzd(i, j, k-1) = uzd(i, j, k-1) + tempd1
        uzd(i, j-1, k) = uzd(i, j-1, k) + tempd1
        uzd(i, j, k) = uzd(i, j, k) + tempd1
        tempd1 = fourth*u_yd
        uyd(i, j-1, k-1) = uyd(i, j-1, k-1) + tempd1
        uyd(i, j, k-1) = uyd(i, j, k-1) + tempd1
        uyd(i, j-1, k) = uyd(i, j-1, k) + tempd1
        uyd(i, j, k) = uyd(i, j, k) + tempd1
        tempd1 = fourth*u_xd
        uxd(i, j-1, k-1) = uxd(i, j-1, k-1) + tempd1
        uxd(i, j, k-1) = uxd(i, j, k-1) + tempd1
        uxd(i, j-1, k) = uxd(i, j-1, k) + tempd1
        uxd(i, j, k) = uxd(i, j, k) + tempd1
        muld = factlamheat*heatcoefd + mutd
        mued = mued + factturbheat*heatcoefd + mutd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          revd(i, j, k) = revd(i, j, k) + por*mued
          revd(i+1, j, k) = revd(i+1, j, k) + por*mued
          mued = 0.0_8
        end if
        rlvd(i, j, k) = rlvd(i, j, k) + por*muld
        rlvd(i+1, j, k) = rlvd(i+1, j, k) + por*muld
      end do
      mued = 0.0_8
      mue = zero
      mued = 0.0_8
!$bwd-of ii-loop 
      do ii=0,nx*jl*nz-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, jl) + 1
        k = ii/(nx*jl) + 2
! set the value of the porosity. if not zero, it is set
! to average the eddy-viscosity and to take the factor
! rfilv into account.
        por = half*rfilv
        if (porj(i, j, k) .eq. noflux) por = zero
! compute the laminar and (if present) the eddy viscosities
! multiplied by the porosity. compute the factor in front of
! the gradients of the speed of sound squared for the heat
! flux.
        mul = por*(rlv(i, j, k)+rlv(i, j+1, k))
        if (eddymodel) then
          mue = por*(rev(i, j, k)+rev(i, j+1, k))
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        mut = mul + mue
        gm1 = half*(gamma(i, j, k)+gamma(i, j+1, k)) - one
        factlamheat = one/(prandtl*gm1)
        factturbheat = one/(prandtlturb*gm1)
        heatcoef = mul*factlamheat + mue*factturbheat
! compute the gradients at the face by averaging the four
! nodal values.
        u_x = fourth*(ux(i-1, j, k-1)+ux(i, j, k-1)+ux(i-1, j, k)+ux(i, &
&         j, k))
        u_y = fourth*(uy(i-1, j, k-1)+uy(i, j, k-1)+uy(i-1, j, k)+uy(i, &
&         j, k))
        u_z = fourth*(uz(i-1, j, k-1)+uz(i, j, k-1)+uz(i-1, j, k)+uz(i, &
&         j, k))
        v_x = fourth*(vx(i-1, j, k-1)+vx(i, j, k-1)+vx(i-1, j, k)+vx(i, &
&         j, k))
        v_y = fourth*(vy(i-1, j, k-1)+vy(i, j, k-1)+vy(i-1, j, k)+vy(i, &
&         j, k))
        v_z = fourth*(vz(i-1, j, k-1)+vz(i, j, k-1)+vz(i-1, j, k)+vz(i, &
&         j, k))
        w_x = fourth*(wx(i-1, j, k-1)+wx(i, j, k-1)+wx(i-1, j, k)+wx(i, &
&         j, k))
        w_y = fourth*(wy(i-1, j, k-1)+wy(i, j, k-1)+wy(i-1, j, k)+wy(i, &
&         j, k))
        w_z = fourth*(wz(i-1, j, k-1)+wz(i, j, k-1)+wz(i-1, j, k)+wz(i, &
&         j, k))
        q_x = fourth*(qx(i-1, j, k-1)+qx(i, j, k-1)+qx(i-1, j, k)+qx(i, &
&         j, k))
        q_y = fourth*(qy(i-1, j, k-1)+qy(i, j, k-1)+qy(i-1, j, k)+qy(i, &
&         j, k))
        q_z = fourth*(qz(i-1, j, k-1)+qz(i, j, k-1)+qz(i-1, j, k)+qz(i, &
&         j, k))
! the gradients in the normal direction are corrected, such
! that no averaging takes places here.
! first determine the vector in the direction from the
! cell center j to cell center j+1.
        ssx = eighth*(x(i-1, j+1, k-1, 1)-x(i-1, j-1, k-1, 1)+x(i-1, j+1&
&         , k, 1)-x(i-1, j-1, k, 1)+x(i, j+1, k-1, 1)-x(i, j-1, k-1, 1)+&
&         x(i, j+1, k, 1)-x(i, j-1, k, 1))
        ssy = eighth*(x(i-1, j+1, k-1, 2)-x(i-1, j-1, k-1, 2)+x(i-1, j+1&
&         , k, 2)-x(i-1, j-1, k, 2)+x(i, j+1, k-1, 2)-x(i, j-1, k-1, 2)+&
&         x(i, j+1, k, 2)-x(i, j-1, k, 2))
        ssz = eighth*(x(i-1, j+1, k-1, 3)-x(i-1, j-1, k-1, 3)+x(i-1, j+1&
&         , k, 3)-x(i-1, j-1, k, 3)+x(i, j+1, k-1, 3)-x(i, j-1, k-1, 3)+&
&         x(i, j+1, k, 3)-x(i, j-1, k, 3))
! determine the length of this vector and create the
! unit normal.
        ss = one/sqrt(ssx*ssx+ssy*ssy+ssz*ssz)
        ssx = ss*ssx
        ssy = ss*ssy
        ssz = ss*ssz
! correct the gradients.
        corr = u_x*ssx + u_y*ssy + u_z*ssz - (w(i, j+1, k, ivx)-w(i, j, &
&         k, ivx))*ss
        u_x = u_x - corr*ssx
        u_y = u_y - corr*ssy
        u_z = u_z - corr*ssz
        corr = v_x*ssx + v_y*ssy + v_z*ssz - (w(i, j+1, k, ivy)-w(i, j, &
&         k, ivy))*ss
        v_x = v_x - corr*ssx
        v_y = v_y - corr*ssy
        v_z = v_z - corr*ssz
        corr = w_x*ssx + w_y*ssy + w_z*ssz - (w(i, j+1, k, ivz)-w(i, j, &
&         k, ivz))*ss
        w_x = w_x - corr*ssx
        w_y = w_y - corr*ssy
        w_z = w_z - corr*ssz
        corr = q_x*ssx + q_y*ssy + q_z*ssz + (aa(i, j+1, k)-aa(i, j, k))&
&         *ss
        q_x = q_x - corr*ssx
        q_y = q_y - corr*ssy
        q_z = q_z - corr*ssz
! compute the stress tensor and the heat flux vector.
! we remove the viscosity from the stress tensor (tau)
! to define taus since we still need to separate between
! laminar and turbulent stress for qcr.
! therefore, laminar tau = mue*taus, turbulent
! tau = mue*taus, and total tau = mut*taus.
        fracdiv = twothird*(u_x+v_y+w_z)
        tauxxs = two*u_x - fracdiv
        tauyys = two*v_y - fracdiv
        tauzzs = two*w_z - fracdiv
        tauxys = u_y + v_x
        tauxzs = u_z + w_x
        tauyzs = v_z + w_y
! add qcr corrections if necessary
        if (useqcr) then
! in the qcr formulation, we add an extra term to the turbulent stress tensor:
!
! tau_ij,qcr = tau_ij - e_ij
!
! where, according to tmr website (http://turbmodels.larc.nasa.gov/spalart.html):
!
! e_ij = ccr1*(o_ik*tau_jk + o_jk*tau_ik)
!
! we are computing o_ik as follows:
!
! o_ik = 2*w_ik/den
!
! remember that the tau_ij in e_ij should use only the eddy viscosity!
! compute denominator
          den = sqrt(u_x*u_x + u_y*u_y + u_z*u_z + v_x*v_x + v_y*v_y + &
&           v_z*v_z + w_x*w_x + w_y*w_y + w_z*w_z)
          if (den .lt. xminn) then
            den = xminn
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
            den = den
          end if
! compute factor that will multiply all tensor components.
! here we add the eddy viscosity that should multiply the stress tensor (tau)
! components as well.
          fact = mue*ccr1/den
! compute off-diagonal terms of vorticity tensor (we will ommit the 1/2)
! the diagonals of the vorticity tensor components are always zero
          wxy = u_y - v_x
          wxz = u_z - w_x
          wyz = v_z - w_y
          wyx = -wxy
          wzx = -wxz
          wzy = -wyz
! compute the extra terms of the boussinesq relation
          exx = fact*(wxy*tauxys+wxz*tauxzs)*two
          eyy = fact*(wyx*tauxys+wyz*tauyzs)*two
          ezz = fact*(wzx*tauxzs+wzy*tauyzs)*two
          exy = fact*(wxy*tauyys+wxz*tauyzs+wyx*tauxxs+wyz*tauxzs)
          exz = fact*(wxy*tauyzs+wxz*tauzzs+wzx*tauxxs+wzy*tauxys)
          eyz = fact*(wyx*tauxzs+wyz*tauzzs+wzx*tauxys+wzy*tauyys)
! apply the total viscosity to the stress tensor and add extra terms
          tauxx = mut*tauxxs - exx
          tauyy = mut*tauyys - eyy
          tauzz = mut*tauzzs - ezz
          tauxy = mut*tauxys - exy
          tauxz = mut*tauxzs - exz
          tauyz = mut*tauyzs - eyz
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
! just apply the total viscosity to the stress tensor
          tauxx = mut*tauxxs
          tauyy = mut*tauyys
          tauzz = mut*tauzzs
          tauxy = mut*tauxys
          tauxz = mut*tauxzs
          tauyz = mut*tauyzs
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
        ubar = half*(w(i, j, k, ivx)+w(i, j+1, k, ivx))
        vbar = half*(w(i, j, k, ivy)+w(i, j+1, k, ivy))
        wbar = half*(w(i, j, k, ivz)+w(i, j+1, k, ivz))
! compute the viscous fluxes for this j-face.
! update the residuals of cell j and j+1.
! store the stress tensor and the heat flux vector if this
! face is part of a viscous subface. both the cases j == 1
! and j == jl must be tested.
        frhoed = fwd(i, j+1, k, irhoe) - fwd(i, j, k, irhoe)
        fmzd = fwd(i, j+1, k, imz) - fwd(i, j, k, imz)
        fmyd = fwd(i, j+1, k, imy) - fwd(i, j, k, imy)
        fmxd = fwd(i, j+1, k, imx) - fwd(i, j, k, imx)
        tempd = sj(i, j, k, 1)*frhoed
        tempd0 = sj(i, j, k, 2)*frhoed
        tempd1 = sj(i, j, k, 3)*frhoed
        q_xd = -(sj(i, j, k, 1)*frhoed)
        q_yd = -(sj(i, j, k, 2)*frhoed)
        q_zd = -(sj(i, j, k, 3)*frhoed)
        ubard = tauxz*tempd1 + tauxy*tempd0 + tauxx*tempd
        tauxzd = ubar*tempd1 + wbar*tempd + sj(i, j, k, 1)*fmzd + sj(i, &
&         j, k, 3)*fmxd
        vbard = tauyz*tempd1 + tauyy*tempd0 + tauxy*tempd
        tauyzd = vbar*tempd1 + wbar*tempd0 + sj(i, j, k, 2)*fmzd + sj(i&
&         , j, k, 3)*fmyd
        wbard = tauzz*tempd1 + tauyz*tempd0 + tauxz*tempd
        tauzzd = wbar*tempd1 + sj(i, j, k, 3)*fmzd
        tauxyd = ubar*tempd0 + vbar*tempd + sj(i, j, k, 1)*fmyd + sj(i, &
&         j, k, 2)*fmxd
        tauyyd = vbar*tempd0 + sj(i, j, k, 2)*fmyd
        tauxxd = ubar*tempd + sj(i, j, k, 1)*fmxd
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + half*wbard
        wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + half*wbard
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + half*vbard
        wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + half*vbard
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + half*ubard
        wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + half*ubard
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          eyzd = -tauyzd
          exzd = -tauxzd
          tempd = fact*eyzd
          tauxzsd = mut*tauxzd + wyx*tempd
          tauxysd = mut*tauxyd + wzx*tempd
          tauzzsd = mut*tauzzd + wyz*tempd
          tauyysd = mut*tauyyd + wzy*tempd
          wyxd = tauxzs*tempd
          wyzd = tauzzs*tempd
          wzxd = tauxys*tempd
          wzyd = tauyys*tempd
          tempd = fact*exzd
          mutd = tauyzs*tauyzd + tauxzs*tauxzd + tauxys*tauxyd + tauzzs*&
&           tauzzd + tauyys*tauyyd + tauxxs*tauxxd
          tauyzsd = mut*tauyzd + wxy*tempd
          exyd = -tauxyd
          ezzd = -tauzzd
          eyyd = -tauyyd
          tauxxsd = mut*tauxxd + wzx*tempd
          exxd = -tauxxd
          factd = (wyx*tauxzs+wyz*tauzzs+wzx*tauxys+wzy*tauyys)*eyzd + (&
&           wxy*tauyzs+wxz*tauzzs+wzx*tauxxs+wzy*tauxys)*exzd + (wxy*&
&           tauyys+wxz*tauyzs+wyx*tauxxs+wyz*tauxzs)*exyd + (wzx*tauxzs+&
&           wzy*tauyzs)*two*ezzd + (wyx*tauxys+wyz*tauyzs)*two*eyyd + (&
&           wxy*tauxys+wxz*tauxzs)*two*exxd
          wxyd = tauyzs*tempd
          wxzd = tauzzs*tempd
          tauzzsd = tauzzsd + wxz*tempd
          wzxd = wzxd + tauxxs*tempd
          wzyd = wzyd + tauxys*tempd
          tauxysd = tauxysd + wzy*tempd
          tempd = fact*exyd
          wxyd = wxyd + tauyys*tempd
          tauyysd = tauyysd + wxy*tempd
          wxzd = wxzd + tauyzs*tempd
          tauyzsd = tauyzsd + wxz*tempd
          wyxd = wyxd + tauxxs*tempd
          tauxxsd = tauxxsd + wyx*tempd
          wyzd = wyzd + tauxzs*tempd
          tauxzsd = tauxzsd + wyz*tempd
          tempd = fact*two*ezzd
          wzxd = wzxd + tauxzs*tempd
          tauxzsd = tauxzsd + wzx*tempd
          wzyd = wzyd + tauyzs*tempd
          tauyzsd = tauyzsd + wzy*tempd
          tempd = fact*two*eyyd
          wyxd = wyxd + tauxys*tempd
          tauxysd = tauxysd + wyx*tempd
          wyzd = wyzd + tauyzs*tempd - wzyd
          tauyzsd = tauyzsd + wyz*tempd
          tempd = fact*two*exxd
          wxyd = wxyd + tauxys*tempd - wyxd
          tauxysd = tauxysd + wxy*tempd
          wxzd = wxzd + tauxzs*tempd - wzxd
          tauxzsd = tauxzsd + wxz*tempd
          v_zd = wyzd
          w_yd = -wyzd
          u_zd = wxzd
          w_xd = -wxzd
          u_yd = wxyd
          v_xd = -wxyd
          tempd = ccr1*factd/den
          mued = mued + tempd
          dend = -(mue*tempd/den)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) dend = 0.0_8
          if (u_x**2 + u_y**2 + u_z**2 + v_x**2 + v_y**2 + v_z**2 + w_x&
&             **2 + w_y**2 + w_z**2 .eq. 0.0_8) then
            tempd = 0.0_8
          else
            tempd = dend/(2.0*sqrt(u_x**2+u_y**2+u_z**2+v_x**2+v_y**2+&
&             v_z**2+w_x**2+w_y**2+w_z**2))
          end if
          u_xd = 2*u_x*tempd
          u_yd = u_yd + 2*u_y*tempd
          u_zd = u_zd + 2*u_z*tempd
          v_xd = v_xd + 2*v_x*tempd
          v_yd = 2*v_y*tempd
          v_zd = v_zd + 2*v_z*tempd
          w_xd = w_xd + 2*w_x*tempd
          w_yd = w_yd + 2*w_y*tempd
          w_zd = 2*w_z*tempd
        else
          mutd = tauyzs*tauyzd + tauxzs*tauxzd + tauxys*tauxyd + tauzzs*&
&           tauzzd + tauyys*tauyyd + tauxxs*tauxxd
          tauyzsd = mut*tauyzd
          tauxzsd = mut*tauxzd
          tauxysd = mut*tauxyd
          tauzzsd = mut*tauzzd
          tauyysd = mut*tauyyd
          tauxxsd = mut*tauxxd
          u_xd = 0.0_8
          u_yd = 0.0_8
          u_zd = 0.0_8
          w_xd = 0.0_8
          w_yd = 0.0_8
          w_zd = 0.0_8
          v_xd = 0.0_8
          v_yd = 0.0_8
          v_zd = 0.0_8
        end if
        fracdivd = -tauzzsd - tauyysd - tauxxsd
        tempd = twothird*fracdivd
        heatcoefd = q_z*q_zd + q_y*q_yd + q_x*q_xd
        q_zd = heatcoef*q_zd
        q_yd = heatcoef*q_yd
        q_xd = heatcoef*q_xd
        v_zd = v_zd + tauyzsd
        w_yd = w_yd + tauyzsd
        u_zd = u_zd + tauxzsd
        w_xd = w_xd + tauxzsd
        u_yd = u_yd + tauxysd
        v_xd = v_xd + tauxysd
        w_zd = w_zd + two*tauzzsd + tempd
        v_yd = v_yd + two*tauyysd + tempd
        u_xd = u_xd + two*tauxxsd + tempd
        corrd = -(ssz*q_zd) - ssy*q_yd - ssx*q_xd
        q_xd = q_xd + ssx*corrd
        q_yd = q_yd + ssy*corrd
        q_zd = q_zd + ssz*corrd
        aad(i, j+1, k) = aad(i, j+1, k) + ss*corrd
        aad(i, j, k) = aad(i, j, k) - ss*corrd
        corrd = -(ssz*w_zd) - ssy*w_yd - ssx*w_xd
        w_xd = w_xd + ssx*corrd
        w_yd = w_yd + ssy*corrd
        w_zd = w_zd + ssz*corrd
        wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) - ss*corrd
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + ss*corrd
        corrd = -(ssz*v_zd) - ssy*v_yd - ssx*v_xd
        v_xd = v_xd + ssx*corrd
        v_yd = v_yd + ssy*corrd
        v_zd = v_zd + ssz*corrd
        wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) - ss*corrd
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + ss*corrd
        corrd = -(ssz*u_zd) - ssy*u_yd - ssx*u_xd
        u_xd = u_xd + ssx*corrd
        u_yd = u_yd + ssy*corrd
        u_zd = u_zd + ssz*corrd
        wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) - ss*corrd
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + ss*corrd
        tempd = fourth*q_zd
        qzd(i-1, j, k-1) = qzd(i-1, j, k-1) + tempd
        qzd(i, j, k-1) = qzd(i, j, k-1) + tempd
        qzd(i-1, j, k) = qzd(i-1, j, k) + tempd
        qzd(i, j, k) = qzd(i, j, k) + tempd
        tempd = fourth*q_yd
        qyd(i-1, j, k-1) = qyd(i-1, j, k-1) + tempd
        qyd(i, j, k-1) = qyd(i, j, k-1) + tempd
        qyd(i-1, j, k) = qyd(i-1, j, k) + tempd
        qyd(i, j, k) = qyd(i, j, k) + tempd
        tempd = fourth*q_xd
        qxd(i-1, j, k-1) = qxd(i-1, j, k-1) + tempd
        qxd(i, j, k-1) = qxd(i, j, k-1) + tempd
        qxd(i-1, j, k) = qxd(i-1, j, k) + tempd
        qxd(i, j, k) = qxd(i, j, k) + tempd
        tempd = fourth*w_zd
        wzd(i-1, j, k-1) = wzd(i-1, j, k-1) + tempd
        wzd(i, j, k-1) = wzd(i, j, k-1) + tempd
        wzd(i-1, j, k) = wzd(i-1, j, k) + tempd
        wzd(i, j, k) = wzd(i, j, k) + tempd
        tempd = fourth*w_yd
        wyd(i-1, j, k-1) = wyd(i-1, j, k-1) + tempd
        wyd(i, j, k-1) = wyd(i, j, k-1) + tempd
        wyd(i-1, j, k) = wyd(i-1, j, k) + tempd
        wyd(i, j, k) = wyd(i, j, k) + tempd
        tempd = fourth*w_xd
        wxd(i-1, j, k-1) = wxd(i-1, j, k-1) + tempd
        wxd(i, j, k-1) = wxd(i, j, k-1) + tempd
        wxd(i-1, j, k) = wxd(i-1, j, k) + tempd
        wxd(i, j, k) = wxd(i, j, k) + tempd
        tempd = fourth*v_zd
        vzd(i-1, j, k-1) = vzd(i-1, j, k-1) + tempd
        vzd(i, j, k-1) = vzd(i, j, k-1) + tempd
        vzd(i-1, j, k) = vzd(i-1, j, k) + tempd
        vzd(i, j, k) = vzd(i, j, k) + tempd
        tempd = fourth*v_yd
        vyd(i-1, j, k-1) = vyd(i-1, j, k-1) + tempd
        vyd(i, j, k-1) = vyd(i, j, k-1) + tempd
        vyd(i-1, j, k) = vyd(i-1, j, k) + tempd
        vyd(i, j, k) = vyd(i, j, k) + tempd
        tempd = fourth*v_xd
        vxd(i-1, j, k-1) = vxd(i-1, j, k-1) + tempd
        vxd(i, j, k-1) = vxd(i, j, k-1) + tempd
        vxd(i-1, j, k) = vxd(i-1, j, k) + tempd
        vxd(i, j, k) = vxd(i, j, k) + tempd
        tempd = fourth*u_zd
        uzd(i-1, j, k-1) = uzd(i-1, j, k-1) + tempd
        uzd(i, j, k-1) = uzd(i, j, k-1) + tempd
        uzd(i-1, j, k) = uzd(i-1, j, k) + tempd
        uzd(i, j, k) = uzd(i, j, k) + tempd
        tempd = fourth*u_yd
        uyd(i-1, j, k-1) = uyd(i-1, j, k-1) + tempd
        uyd(i, j, k-1) = uyd(i, j, k-1) + tempd
        uyd(i-1, j, k) = uyd(i-1, j, k) + tempd
        uyd(i, j, k) = uyd(i, j, k) + tempd
        tempd = fourth*u_xd
        uxd(i-1, j, k-1) = uxd(i-1, j, k-1) + tempd
        uxd(i, j, k-1) = uxd(i, j, k-1) + tempd
        uxd(i-1, j, k) = uxd(i-1, j, k) + tempd
        uxd(i, j, k) = uxd(i, j, k) + tempd
        muld = factlamheat*heatcoefd + mutd
        mued = mued + factturbheat*heatcoefd + mutd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          revd(i, j, k) = revd(i, j, k) + por*mued
          revd(i, j+1, k) = revd(i, j+1, k) + por*mued
          mued = 0.0_8
        end if
        rlvd(i, j, k) = rlvd(i, j, k) + por*muld
        rlvd(i, j+1, k) = rlvd(i, j+1, k) + por*muld
      end do
      mued = 0.0_8
!
!         viscous fluxes in the k-direction.
!
      mue = zero
      mued = 0.0_8
!$bwd-of ii-loop 
      do ii=0,nx*ny*kl-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, ny) + 2
        k = ii/(nx*ny) + 1
! set the value of the porosity. if not zero, it is set
! to average the eddy-viscosity and to take the factor
! rfilv into account.
        por = half*rfilv
        if (pork(i, j, k) .eq. noflux) por = zero
! compute the laminar and (if present) the eddy viscosities
! multiplied by the porosity. compute the factor in front of
! the gradients of the speed of sound squared for the heat
! flux.
        mul = por*(rlv(i, j, k)+rlv(i, j, k+1))
        if (eddymodel) then
          mue = por*(rev(i, j, k)+rev(i, j, k+1))
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
        mut = mul + mue
        gm1 = half*(gamma(i, j, k)+gamma(i, j, k+1)) - one
        factlamheat = one/(prandtl*gm1)
        factturbheat = one/(prandtlturb*gm1)
        heatcoef = mul*factlamheat + mue*factturbheat
! compute the gradients at the face by averaging the four
! nodal values.
        u_x = fourth*(ux(i-1, j-1, k)+ux(i, j-1, k)+ux(i-1, j, k)+ux(i, &
&         j, k))
        u_y = fourth*(uy(i-1, j-1, k)+uy(i, j-1, k)+uy(i-1, j, k)+uy(i, &
&         j, k))
        u_z = fourth*(uz(i-1, j-1, k)+uz(i, j-1, k)+uz(i-1, j, k)+uz(i, &
&         j, k))
        v_x = fourth*(vx(i-1, j-1, k)+vx(i, j-1, k)+vx(i-1, j, k)+vx(i, &
&         j, k))
        v_y = fourth*(vy(i-1, j-1, k)+vy(i, j-1, k)+vy(i-1, j, k)+vy(i, &
&         j, k))
        v_z = fourth*(vz(i-1, j-1, k)+vz(i, j-1, k)+vz(i-1, j, k)+vz(i, &
&         j, k))
        w_x = fourth*(wx(i-1, j-1, k)+wx(i, j-1, k)+wx(i-1, j, k)+wx(i, &
&         j, k))
        w_y = fourth*(wy(i-1, j-1, k)+wy(i, j-1, k)+wy(i-1, j, k)+wy(i, &
&         j, k))
        w_z = fourth*(wz(i-1, j-1, k)+wz(i, j-1, k)+wz(i-1, j, k)+wz(i, &
&         j, k))
        q_x = fourth*(qx(i-1, j-1, k)+qx(i, j-1, k)+qx(i-1, j, k)+qx(i, &
&         j, k))
        q_y = fourth*(qy(i-1, j-1, k)+qy(i, j-1, k)+qy(i-1, j, k)+qy(i, &
&         j, k))
        q_z = fourth*(qz(i-1, j-1, k)+qz(i, j-1, k)+qz(i-1, j, k)+qz(i, &
&         j, k))
! the gradients in the normal direction are corrected, such
! that no averaging takes places here.
! first determine the vector in the direction from the
! cell center k to cell center k+1.
        ssx = eighth*(x(i-1, j-1, k+1, 1)-x(i-1, j-1, k-1, 1)+x(i-1, j, &
&         k+1, 1)-x(i-1, j, k-1, 1)+x(i, j-1, k+1, 1)-x(i, j-1, k-1, 1)+&
&         x(i, j, k+1, 1)-x(i, j, k-1, 1))
        ssy = eighth*(x(i-1, j-1, k+1, 2)-x(i-1, j-1, k-1, 2)+x(i-1, j, &
&         k+1, 2)-x(i-1, j, k-1, 2)+x(i, j-1, k+1, 2)-x(i, j-1, k-1, 2)+&
&         x(i, j, k+1, 2)-x(i, j, k-1, 2))
        ssz = eighth*(x(i-1, j-1, k+1, 3)-x(i-1, j-1, k-1, 3)+x(i-1, j, &
&         k+1, 3)-x(i-1, j, k-1, 3)+x(i, j-1, k+1, 3)-x(i, j-1, k-1, 3)+&
&         x(i, j, k+1, 3)-x(i, j, k-1, 3))
! determine the length of this vector and create the
! unit normal.
        ss = one/sqrt(ssx*ssx+ssy*ssy+ssz*ssz)
        ssx = ss*ssx
        ssy = ss*ssy
        ssz = ss*ssz
! correct the gradients.
        corr = u_x*ssx + u_y*ssy + u_z*ssz - (w(i, j, k+1, ivx)-w(i, j, &
&         k, ivx))*ss
        u_x = u_x - corr*ssx
        u_y = u_y - corr*ssy
        u_z = u_z - corr*ssz
        corr = v_x*ssx + v_y*ssy + v_z*ssz - (w(i, j, k+1, ivy)-w(i, j, &
&         k, ivy))*ss
        v_x = v_x - corr*ssx
        v_y = v_y - corr*ssy
        v_z = v_z - corr*ssz
        corr = w_x*ssx + w_y*ssy + w_z*ssz - (w(i, j, k+1, ivz)-w(i, j, &
&         k, ivz))*ss
        w_x = w_x - corr*ssx
        w_y = w_y - corr*ssy
        w_z = w_z - corr*ssz
        corr = q_x*ssx + q_y*ssy + q_z*ssz + (aa(i, j, k+1)-aa(i, j, k))&
&         *ss
        q_x = q_x - corr*ssx
        q_y = q_y - corr*ssy
        q_z = q_z - corr*ssz
! compute the stress tensor and the heat flux vector.
! we remove the viscosity from the stress tensor (tau)
! to define taus since we still need to separate between
! laminar and turbulent stress for qcr.
! therefore, laminar tau = mue*taus, turbulent
! tau = mue*taus, and total tau = mut*taus.
        fracdiv = twothird*(u_x+v_y+w_z)
        tauxxs = two*u_x - fracdiv
        tauyys = two*v_y - fracdiv
        tauzzs = two*w_z - fracdiv
        tauxys = u_y + v_x
        tauxzs = u_z + w_x
        tauyzs = v_z + w_y
! add qcr corrections if necessary
        if (useqcr) then
! in the qcr formulation, we add an extra term to the turbulent stress tensor:
!
! tau_ij,qcr = tau_ij - e_ij
!
! where, according to tmr website (http://turbmodels.larc.nasa.gov/spalart.html):
!
! e_ij = ccr1*(o_ik*tau_jk + o_jk*tau_ik)
!
! we are computing o_ik as follows:
!
! o_ik = 2*w_ik/den
!
! remember that the tau_ij in e_ij should use only the eddy viscosity!
! compute denominator
          den = sqrt(u_x*u_x + u_y*u_y + u_z*u_z + v_x*v_x + v_y*v_y + &
&           v_z*v_z + w_x*w_x + w_y*w_y + w_z*w_z)
          if (den .lt. xminn) then
            den = xminn
myintptr = myintptr + 1
 myintstack(myintptr) = 0
          else
myintptr = myintptr + 1
 myintstack(myintptr) = 1
            den = den
          end if
! compute factor that will multiply all tensor components.
! here we add the eddy viscosity that should multiply the stress tensor (tau)
! components as well.
          fact = mue*ccr1/den
! compute off-diagonal terms of vorticity tensor (we will ommit the 1/2)
! the diagonals of the vorticity tensor components are always zero
          wxy = u_y - v_x
          wxz = u_z - w_x
          wyz = v_z - w_y
          wyx = -wxy
          wzx = -wxz
          wzy = -wyz
! compute the extra terms of the boussinesq relation
          exx = fact*(wxy*tauxys+wxz*tauxzs)*two
          eyy = fact*(wyx*tauxys+wyz*tauyzs)*two
          ezz = fact*(wzx*tauxzs+wzy*tauyzs)*two
          exy = fact*(wxy*tauyys+wxz*tauyzs+wyx*tauxxs+wyz*tauxzs)
          exz = fact*(wxy*tauyzs+wxz*tauzzs+wzx*tauxxs+wzy*tauxys)
          eyz = fact*(wyx*tauxzs+wyz*tauzzs+wzx*tauxys+wzy*tauyys)
! apply the total viscosity to the stress tensor and add extra terms
          tauxx = mut*tauxxs - exx
          tauyy = mut*tauyys - eyy
          tauzz = mut*tauzzs - ezz
          tauxy = mut*tauxys - exy
          tauxz = mut*tauxzs - exz
          tauyz = mut*tauyzs - eyz
myintptr = myintptr + 1
 myintstack(myintptr) = 0
        else
! just apply the total viscosity to the stress tensor
          tauxx = mut*tauxxs
          tauyy = mut*tauyys
          tauzz = mut*tauzzs
          tauxy = mut*tauxys
          tauxz = mut*tauxzs
          tauyz = mut*tauyzs
myintptr = myintptr + 1
 myintstack(myintptr) = 1
        end if
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
        ubar = half*(w(i, j, k, ivx)+w(i, j, k+1, ivx))
        vbar = half*(w(i, j, k, ivy)+w(i, j, k+1, ivy))
        wbar = half*(w(i, j, k, ivz)+w(i, j, k+1, ivz))
! compute the viscous fluxes for this k-face.
! update the residuals of cell k and k+1.
! store the stress tensor and the heat flux vector if this
! face is part of a viscous subface. both the cases k == 1
! and k == kl must be tested.
        frhoed = fwd(i, j, k+1, irhoe) - fwd(i, j, k, irhoe)
        fmzd = fwd(i, j, k+1, imz) - fwd(i, j, k, imz)
        fmyd = fwd(i, j, k+1, imy) - fwd(i, j, k, imy)
        fmxd = fwd(i, j, k+1, imx) - fwd(i, j, k, imx)
        q_xd = -(sk(i, j, k, 1)*frhoed)
        q_yd = -(sk(i, j, k, 2)*frhoed)
        q_zd = -(sk(i, j, k, 3)*frhoed)
        tempd = sk(i, j, k, 3)*frhoed
        ubard = tauxz*tempd
        tauxzd = ubar*tempd
        vbard = tauyz*tempd
        tauyzd = vbar*tempd
        wbard = tauzz*tempd
        tauzzd = wbar*tempd + sk(i, j, k, 3)*fmzd
        tempd = sk(i, j, k, 2)*frhoed
        ubard = ubard + tauxy*tempd
        tauxyd = ubar*tempd
        vbard = vbard + tauyy*tempd
        tauyyd = vbar*tempd + sk(i, j, k, 2)*fmyd
        wbard = wbard + tauyz*tempd
        tauyzd = tauyzd + wbar*tempd + sk(i, j, k, 2)*fmzd + sk(i, j, k&
&         , 3)*fmyd
        tempd = sk(i, j, k, 1)*frhoed
        ubard = ubard + tauxx*tempd
        tauxxd = ubar*tempd + sk(i, j, k, 1)*fmxd
        vbard = vbard + tauxy*tempd
        tauxyd = tauxyd + vbar*tempd + sk(i, j, k, 1)*fmyd + sk(i, j, k&
&         , 2)*fmxd
        wbard = wbard + tauxz*tempd
        tauxzd = tauxzd + wbar*tempd + sk(i, j, k, 1)*fmzd + sk(i, j, k&
&         , 3)*fmxd
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + half*wbard
        wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + half*wbard
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + half*vbard
        wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + half*vbard
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + half*ubard
        wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + half*ubard
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          eyzd = -tauyzd
          exzd = -tauxzd
          tempd = fact*eyzd
          tauxzsd = mut*tauxzd + wyx*tempd
          tauxysd = mut*tauxyd + wzx*tempd
          tauzzsd = mut*tauzzd + wyz*tempd
          tauyysd = mut*tauyyd + wzy*tempd
          wyxd = tauxzs*tempd
          wyzd = tauzzs*tempd
          wzxd = tauxys*tempd
          wzyd = tauyys*tempd
          tempd = fact*exzd
          mutd = tauyzs*tauyzd + tauxzs*tauxzd + tauxys*tauxyd + tauzzs*&
&           tauzzd + tauyys*tauyyd + tauxxs*tauxxd
          tauyzsd = mut*tauyzd + wxy*tempd
          exyd = -tauxyd
          ezzd = -tauzzd
          eyyd = -tauyyd
          tauxxsd = mut*tauxxd + wzx*tempd
          exxd = -tauxxd
          factd = (wyx*tauxzs+wyz*tauzzs+wzx*tauxys+wzy*tauyys)*eyzd + (&
&           wxy*tauyzs+wxz*tauzzs+wzx*tauxxs+wzy*tauxys)*exzd + (wxy*&
&           tauyys+wxz*tauyzs+wyx*tauxxs+wyz*tauxzs)*exyd + (wzx*tauxzs+&
&           wzy*tauyzs)*two*ezzd + (wyx*tauxys+wyz*tauyzs)*two*eyyd + (&
&           wxy*tauxys+wxz*tauxzs)*two*exxd
          wxyd = tauyzs*tempd
          wxzd = tauzzs*tempd
          tauzzsd = tauzzsd + wxz*tempd
          wzxd = wzxd + tauxxs*tempd
          wzyd = wzyd + tauxys*tempd
          tauxysd = tauxysd + wzy*tempd
          tempd = fact*exyd
          wxyd = wxyd + tauyys*tempd
          tauyysd = tauyysd + wxy*tempd
          wxzd = wxzd + tauyzs*tempd
          tauyzsd = tauyzsd + wxz*tempd
          wyxd = wyxd + tauxxs*tempd
          tauxxsd = tauxxsd + wyx*tempd
          wyzd = wyzd + tauxzs*tempd
          tauxzsd = tauxzsd + wyz*tempd
          tempd = fact*two*ezzd
          wzxd = wzxd + tauxzs*tempd
          tauxzsd = tauxzsd + wzx*tempd
          wzyd = wzyd + tauyzs*tempd
          tauyzsd = tauyzsd + wzy*tempd
          tempd = fact*two*eyyd
          wyxd = wyxd + tauxys*tempd
          tauxysd = tauxysd + wyx*tempd
          wyzd = wyzd + tauyzs*tempd - wzyd
          tauyzsd = tauyzsd + wyz*tempd
          tempd = fact*two*exxd
          wxyd = wxyd + tauxys*tempd - wyxd
          tauxysd = tauxysd + wxy*tempd
          wxzd = wxzd + tauxzs*tempd - wzxd
          tauxzsd = tauxzsd + wxz*tempd
          v_zd = wyzd
          w_yd = -wyzd
          u_zd = wxzd
          w_xd = -wxzd
          u_yd = wxyd
          v_xd = -wxyd
          tempd = ccr1*factd/den
          mued = mued + tempd
          dend = -(mue*tempd/den)
branch = myintstack(myintptr)
 myintptr = myintptr - 1
          if (branch .eq. 0) dend = 0.0_8
          if (u_x**2 + u_y**2 + u_z**2 + v_x**2 + v_y**2 + v_z**2 + w_x&
&             **2 + w_y**2 + w_z**2 .eq. 0.0_8) then
            tempd = 0.0_8
          else
            tempd = dend/(2.0*sqrt(u_x**2+u_y**2+u_z**2+v_x**2+v_y**2+&
&             v_z**2+w_x**2+w_y**2+w_z**2))
          end if
          u_xd = 2*u_x*tempd
          u_yd = u_yd + 2*u_y*tempd
          u_zd = u_zd + 2*u_z*tempd
          v_xd = v_xd + 2*v_x*tempd
          v_yd = 2*v_y*tempd
          v_zd = v_zd + 2*v_z*tempd
          w_xd = w_xd + 2*w_x*tempd
          w_yd = w_yd + 2*w_y*tempd
          w_zd = 2*w_z*tempd
        else
          mutd = tauyzs*tauyzd + tauxzs*tauxzd + tauxys*tauxyd + tauzzs*&
&           tauzzd + tauyys*tauyyd + tauxxs*tauxxd
          tauyzsd = mut*tauyzd
          tauxzsd = mut*tauxzd
          tauxysd = mut*tauxyd
          tauzzsd = mut*tauzzd
          tauyysd = mut*tauyyd
          tauxxsd = mut*tauxxd
          u_xd = 0.0_8
          u_yd = 0.0_8
          u_zd = 0.0_8
          w_xd = 0.0_8
          w_yd = 0.0_8
          w_zd = 0.0_8
          v_xd = 0.0_8
          v_yd = 0.0_8
          v_zd = 0.0_8
        end if
        fracdivd = -tauzzsd - tauyysd - tauxxsd
        tempd = twothird*fracdivd
        heatcoefd = q_z*q_zd + q_y*q_yd + q_x*q_xd
        q_zd = heatcoef*q_zd
        q_yd = heatcoef*q_yd
        q_xd = heatcoef*q_xd
        v_zd = v_zd + tauyzsd
        w_yd = w_yd + tauyzsd
        u_zd = u_zd + tauxzsd
        w_xd = w_xd + tauxzsd
        u_yd = u_yd + tauxysd
        v_xd = v_xd + tauxysd
        w_zd = w_zd + two*tauzzsd + tempd
        v_yd = v_yd + two*tauyysd + tempd
        u_xd = u_xd + two*tauxxsd + tempd
        corrd = -(ssz*q_zd) - ssy*q_yd - ssx*q_xd
        q_xd = q_xd + ssx*corrd
        q_yd = q_yd + ssy*corrd
        q_zd = q_zd + ssz*corrd
        aad(i, j, k+1) = aad(i, j, k+1) + ss*corrd
        aad(i, j, k) = aad(i, j, k) - ss*corrd
        corrd = -(ssz*w_zd) - ssy*w_yd - ssx*w_xd
        w_xd = w_xd + ssx*corrd
        w_yd = w_yd + ssy*corrd
        w_zd = w_zd + ssz*corrd
        wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) - ss*corrd
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + ss*corrd
        corrd = -(ssz*v_zd) - ssy*v_yd - ssx*v_xd
        v_xd = v_xd + ssx*corrd
        v_yd = v_yd + ssy*corrd
        v_zd = v_zd + ssz*corrd
        wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) - ss*corrd
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + ss*corrd
        corrd = -(ssz*u_zd) - ssy*u_yd - ssx*u_xd
        u_xd = u_xd + ssx*corrd
        u_yd = u_yd + ssy*corrd
        u_zd = u_zd + ssz*corrd
        wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) - ss*corrd
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + ss*corrd
        tempd = fourth*q_zd
        qzd(i-1, j-1, k) = qzd(i-1, j-1, k) + tempd
        qzd(i, j-1, k) = qzd(i, j-1, k) + tempd
        qzd(i-1, j, k) = qzd(i-1, j, k) + tempd
        qzd(i, j, k) = qzd(i, j, k) + tempd
        tempd = fourth*q_yd
        qyd(i-1, j-1, k) = qyd(i-1, j-1, k) + tempd
        qyd(i, j-1, k) = qyd(i, j-1, k) + tempd
        qyd(i-1, j, k) = qyd(i-1, j, k) + tempd
        qyd(i, j, k) = qyd(i, j, k) + tempd
        tempd = fourth*q_xd
        qxd(i-1, j-1, k) = qxd(i-1, j-1, k) + tempd
        qxd(i, j-1, k) = qxd(i, j-1, k) + tempd
        qxd(i-1, j, k) = qxd(i-1, j, k) + tempd
        qxd(i, j, k) = qxd(i, j, k) + tempd
        tempd = fourth*w_zd
        wzd(i-1, j-1, k) = wzd(i-1, j-1, k) + tempd
        wzd(i, j-1, k) = wzd(i, j-1, k) + tempd
        wzd(i-1, j, k) = wzd(i-1, j, k) + tempd
        wzd(i, j, k) = wzd(i, j, k) + tempd
        tempd = fourth*w_yd
        wyd(i-1, j-1, k) = wyd(i-1, j-1, k) + tempd
        wyd(i, j-1, k) = wyd(i, j-1, k) + tempd
        wyd(i-1, j, k) = wyd(i-1, j, k) + tempd
        wyd(i, j, k) = wyd(i, j, k) + tempd
        tempd = fourth*w_xd
        wxd(i-1, j-1, k) = wxd(i-1, j-1, k) + tempd
        wxd(i, j-1, k) = wxd(i, j-1, k) + tempd
        wxd(i-1, j, k) = wxd(i-1, j, k) + tempd
        wxd(i, j, k) = wxd(i, j, k) + tempd
        tempd = fourth*v_zd
        vzd(i-1, j-1, k) = vzd(i-1, j-1, k) + tempd
        vzd(i, j-1, k) = vzd(i, j-1, k) + tempd
        vzd(i-1, j, k) = vzd(i-1, j, k) + tempd
        vzd(i, j, k) = vzd(i, j, k) + tempd
        tempd = fourth*v_yd
        vyd(i-1, j-1, k) = vyd(i-1, j-1, k) + tempd
        vyd(i, j-1, k) = vyd(i, j-1, k) + tempd
        vyd(i-1, j, k) = vyd(i-1, j, k) + tempd
        vyd(i, j, k) = vyd(i, j, k) + tempd
        tempd = fourth*v_xd
        vxd(i-1, j-1, k) = vxd(i-1, j-1, k) + tempd
        vxd(i, j-1, k) = vxd(i, j-1, k) + tempd
        vxd(i-1, j, k) = vxd(i-1, j, k) + tempd
        vxd(i, j, k) = vxd(i, j, k) + tempd
        tempd = fourth*u_zd
        uzd(i-1, j-1, k) = uzd(i-1, j-1, k) + tempd
        uzd(i, j-1, k) = uzd(i, j-1, k) + tempd
        uzd(i-1, j, k) = uzd(i-1, j, k) + tempd
        uzd(i, j, k) = uzd(i, j, k) + tempd
        tempd = fourth*u_yd
        uyd(i-1, j-1, k) = uyd(i-1, j-1, k) + tempd
        uyd(i, j-1, k) = uyd(i, j-1, k) + tempd
        uyd(i-1, j, k) = uyd(i-1, j, k) + tempd
        uyd(i, j, k) = uyd(i, j, k) + tempd
        tempd = fourth*u_xd
        uxd(i-1, j-1, k) = uxd(i-1, j-1, k) + tempd
        uxd(i, j-1, k) = uxd(i, j-1, k) + tempd
        uxd(i-1, j, k) = uxd(i-1, j, k) + tempd
        uxd(i, j, k) = uxd(i, j, k) + tempd
        muld = factlamheat*heatcoefd + mutd
        mued = mued + factturbheat*heatcoefd + mutd
branch = myintstack(myintptr)
 myintptr = myintptr - 1
        if (branch .eq. 0) then
          revd(i, j, k) = revd(i, j, k) + por*mued
          revd(i, j, k+1) = revd(i, j, k+1) + por*mued
          mued = 0.0_8
        end if
        rlvd(i, j, k) = rlvd(i, j, k) + por*muld
        rlvd(i, j, k+1) = rlvd(i, j, k+1) + por*muld
      end do
    end if
  end subroutine viscousflux_fast_b
 
  subroutine viscousflux()
!
!       viscousflux computes the viscous fluxes using a central
!       difference scheme for a block.
!       it is assumed that the pointers in block pointer already point
!       to the correct block.
!
    use constants
    use blockpointers
    use flowvarrefstate
    use inputphysics
    use iteration
    implicit none
!
!      local parameter.
!
    real(kind=realtype), parameter :: twothird=two*third
    real(kind=realtype), parameter :: xminn=1.e-14_realtype
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k, ii
    real(kind=realtype) :: rfilv, por, mul, mue, mut, heatcoef
    real(kind=realtype) :: gm1, factlamheat, factturbheat
    real(kind=realtype) :: u_x, u_y, u_z, v_x, v_y, v_z, w_x, w_y, w_z
    real(kind=realtype) :: q_x, q_y, q_z, ubar, vbar, wbar
    real(kind=realtype) :: corr, ssx, ssy, ssz, ss, fracdiv
    real(kind=realtype) :: tauxx, tauyy, tauzz
    real(kind=realtype) :: tauxy, tauxz, tauyz
    real(kind=realtype) :: tauxxs, tauyys, tauzzs
    real(kind=realtype) :: tauxys, tauxzs, tauyzs
    real(kind=realtype) :: exx, eyy, ezz
    real(kind=realtype) :: exy, exz, eyz
    real(kind=realtype) :: wxy, wxz, wyz, wyx, wzx, wzy
    real(kind=realtype) :: den, ccr1, fact
    real(kind=realtype) :: fmx, fmy, fmz, frhoe
    logical :: correctfork, storewalltensor
    intrinsic abs
    intrinsic mod
    intrinsic sqrt
    intrinsic max
    real(kind=realtype) :: abs0
! set qcr parameters
    ccr1 = 0.3_realtype
! set rfilv to rfil to indicate that this is the viscous part.
! if rfilv == 0 the viscous residuals need not to be computed
! and a return can be made.
    rfilv = rfil
    if (rfilv .ge. 0.) then
      abs0 = rfilv
    else
      abs0 = -rfilv
    end if
    if (abs0 .lt. thresholdreal) then
      return
    else
! determine whether or not the wall stress tensor and wall heat
! flux must be stored for viscous walls.
      storewalltensor = .false.
      if (wallfunctions) then
        storewalltensor = .true.
      else if (rkstage .eq. 0 .and. currentlevel .eq. groundlevel) then
        storewalltensor = .true.
      end if
!$ad checkpoint-start
!
!         viscous fluxes in the k-direction.
!
      mue = zero
!$ad ii-loop
      do ii=0,nx*ny*kl-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, ny) + 2
        k = ii/(nx*ny) + 1
! set the value of the porosity. if not zero, it is set
! to average the eddy-viscosity and to take the factor
! rfilv into account.
        por = half*rfilv
        if (pork(i, j, k) .eq. noflux) por = zero
! compute the laminar and (if present) the eddy viscosities
! multiplied by the porosity. compute the factor in front of
! the gradients of the speed of sound squared for the heat
! flux.
        mul = por*(rlv(i, j, k)+rlv(i, j, k+1))
        if (eddymodel) mue = por*(rev(i, j, k)+rev(i, j, k+1))
        mut = mul + mue
        gm1 = half*(gamma(i, j, k)+gamma(i, j, k+1)) - one
        factlamheat = one/(prandtl*gm1)
        factturbheat = one/(prandtlturb*gm1)
        heatcoef = mul*factlamheat + mue*factturbheat
! compute the gradients at the face by averaging the four
! nodal values.
        u_x = fourth*(ux(i-1, j-1, k)+ux(i, j-1, k)+ux(i-1, j, k)+ux(i, &
&         j, k))
        u_y = fourth*(uy(i-1, j-1, k)+uy(i, j-1, k)+uy(i-1, j, k)+uy(i, &
&         j, k))
        u_z = fourth*(uz(i-1, j-1, k)+uz(i, j-1, k)+uz(i-1, j, k)+uz(i, &
&         j, k))
        v_x = fourth*(vx(i-1, j-1, k)+vx(i, j-1, k)+vx(i-1, j, k)+vx(i, &
&         j, k))
        v_y = fourth*(vy(i-1, j-1, k)+vy(i, j-1, k)+vy(i-1, j, k)+vy(i, &
&         j, k))
        v_z = fourth*(vz(i-1, j-1, k)+vz(i, j-1, k)+vz(i-1, j, k)+vz(i, &
&         j, k))
        w_x = fourth*(wx(i-1, j-1, k)+wx(i, j-1, k)+wx(i-1, j, k)+wx(i, &
&         j, k))
        w_y = fourth*(wy(i-1, j-1, k)+wy(i, j-1, k)+wy(i-1, j, k)+wy(i, &
&         j, k))
        w_z = fourth*(wz(i-1, j-1, k)+wz(i, j-1, k)+wz(i-1, j, k)+wz(i, &
&         j, k))
        q_x = fourth*(qx(i-1, j-1, k)+qx(i, j-1, k)+qx(i-1, j, k)+qx(i, &
&         j, k))
        q_y = fourth*(qy(i-1, j-1, k)+qy(i, j-1, k)+qy(i-1, j, k)+qy(i, &
&         j, k))
        q_z = fourth*(qz(i-1, j-1, k)+qz(i, j-1, k)+qz(i-1, j, k)+qz(i, &
&         j, k))
! the gradients in the normal direction are corrected, such
! that no averaging takes places here.
! first determine the vector in the direction from the
! cell center k to cell center k+1.
        ssx = eighth*(x(i-1, j-1, k+1, 1)-x(i-1, j-1, k-1, 1)+x(i-1, j, &
&         k+1, 1)-x(i-1, j, k-1, 1)+x(i, j-1, k+1, 1)-x(i, j-1, k-1, 1)+&
&         x(i, j, k+1, 1)-x(i, j, k-1, 1))
        ssy = eighth*(x(i-1, j-1, k+1, 2)-x(i-1, j-1, k-1, 2)+x(i-1, j, &
&         k+1, 2)-x(i-1, j, k-1, 2)+x(i, j-1, k+1, 2)-x(i, j-1, k-1, 2)+&
&         x(i, j, k+1, 2)-x(i, j, k-1, 2))
        ssz = eighth*(x(i-1, j-1, k+1, 3)-x(i-1, j-1, k-1, 3)+x(i-1, j, &
&         k+1, 3)-x(i-1, j, k-1, 3)+x(i, j-1, k+1, 3)-x(i, j-1, k-1, 3)+&
&         x(i, j, k+1, 3)-x(i, j, k-1, 3))
! determine the length of this vector and create the
! unit normal.
        ss = one/sqrt(ssx*ssx+ssy*ssy+ssz*ssz)
        ssx = ss*ssx
        ssy = ss*ssy
        ssz = ss*ssz
! correct the gradients.
        corr = u_x*ssx + u_y*ssy + u_z*ssz - (w(i, j, k+1, ivx)-w(i, j, &
&         k, ivx))*ss
        u_x = u_x - corr*ssx
        u_y = u_y - corr*ssy
        u_z = u_z - corr*ssz
        corr = v_x*ssx + v_y*ssy + v_z*ssz - (w(i, j, k+1, ivy)-w(i, j, &
&         k, ivy))*ss
        v_x = v_x - corr*ssx
        v_y = v_y - corr*ssy
        v_z = v_z - corr*ssz
        corr = w_x*ssx + w_y*ssy + w_z*ssz - (w(i, j, k+1, ivz)-w(i, j, &
&         k, ivz))*ss
        w_x = w_x - corr*ssx
        w_y = w_y - corr*ssy
        w_z = w_z - corr*ssz
        corr = q_x*ssx + q_y*ssy + q_z*ssz + (aa(i, j, k+1)-aa(i, j, k))&
&         *ss
        q_x = q_x - corr*ssx
        q_y = q_y - corr*ssy
        q_z = q_z - corr*ssz
! compute the stress tensor and the heat flux vector.
! we remove the viscosity from the stress tensor (tau)
! to define taus since we still need to separate between
! laminar and turbulent stress for qcr.
! therefore, laminar tau = mue*taus, turbulent
! tau = mue*taus, and total tau = mut*taus.
        fracdiv = twothird*(u_x+v_y+w_z)
        tauxxs = two*u_x - fracdiv
        tauyys = two*v_y - fracdiv
        tauzzs = two*w_z - fracdiv
        tauxys = u_y + v_x
        tauxzs = u_z + w_x
        tauyzs = v_z + w_y
        q_x = heatcoef*q_x
        q_y = heatcoef*q_y
        q_z = heatcoef*q_z
! add qcr corrections if necessary
        if (useqcr) then
! in the qcr formulation, we add an extra term to the turbulent stress tensor:
!
! tau_ij,qcr = tau_ij - e_ij
!
! where, according to tmr website (http://turbmodels.larc.nasa.gov/spalart.html):
!
! e_ij = ccr1*(o_ik*tau_jk + o_jk*tau_ik)
!
! we are computing o_ik as follows:
!
! o_ik = 2*w_ik/den
!
! remember that the tau_ij in e_ij should use only the eddy viscosity!
! compute denominator
          den = sqrt(u_x*u_x + u_y*u_y + u_z*u_z + v_x*v_x + v_y*v_y + &
&           v_z*v_z + w_x*w_x + w_y*w_y + w_z*w_z)
          if (den .lt. xminn) then
            den = xminn
          else
            den = den
          end if
! compute factor that will multiply all tensor components.
! here we add the eddy viscosity that should multiply the stress tensor (tau)
! components as well.
          fact = mue*ccr1/den
! compute off-diagonal terms of vorticity tensor (we will ommit the 1/2)
! the diagonals of the vorticity tensor components are always zero
          wxy = u_y - v_x
          wxz = u_z - w_x
          wyz = v_z - w_y
          wyx = -wxy
          wzx = -wxz
          wzy = -wyz
! compute the extra terms of the boussinesq relation
          exx = fact*(wxy*tauxys+wxz*tauxzs)*two
          eyy = fact*(wyx*tauxys+wyz*tauyzs)*two
          ezz = fact*(wzx*tauxzs+wzy*tauyzs)*two
          exy = fact*(wxy*tauyys+wxz*tauyzs+wyx*tauxxs+wyz*tauxzs)
          exz = fact*(wxy*tauyzs+wxz*tauzzs+wzx*tauxxs+wzy*tauxys)
          eyz = fact*(wyx*tauxzs+wyz*tauzzs+wzx*tauxys+wzy*tauyys)
! apply the total viscosity to the stress tensor and add extra terms
          tauxx = mut*tauxxs - exx
          tauyy = mut*tauyys - eyy
          tauzz = mut*tauzzs - ezz
          tauxy = mut*tauxys - exy
          tauxz = mut*tauxzs - exz
          tauyz = mut*tauyzs - eyz
        else
! just apply the total viscosity to the stress tensor
          tauxx = mut*tauxxs
          tauyy = mut*tauyys
          tauzz = mut*tauzzs
          tauxy = mut*tauxys
          tauxz = mut*tauxzs
          tauyz = mut*tauyzs
        end if
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
        ubar = half*(w(i, j, k, ivx)+w(i, j, k+1, ivx))
        vbar = half*(w(i, j, k, ivy)+w(i, j, k+1, ivy))
        wbar = half*(w(i, j, k, ivz)+w(i, j, k+1, ivz))
! compute the viscous fluxes for this k-face.
        fmx = tauxx*sk(i, j, k, 1) + tauxy*sk(i, j, k, 2) + tauxz*sk(i, &
&         j, k, 3)
        fmy = tauxy*sk(i, j, k, 1) + tauyy*sk(i, j, k, 2) + tauyz*sk(i, &
&         j, k, 3)
        fmz = tauxz*sk(i, j, k, 1) + tauyz*sk(i, j, k, 2) + tauzz*sk(i, &
&         j, k, 3)
        frhoe = (ubar*tauxx+vbar*tauxy+wbar*tauxz)*sk(i, j, k, 1)
        frhoe = frhoe + (ubar*tauxy+vbar*tauyy+wbar*tauyz)*sk(i, j, k, 2&
&         )
        frhoe = frhoe + (ubar*tauxz+vbar*tauyz+wbar*tauzz)*sk(i, j, k, 3&
&         )
        frhoe = frhoe - q_x*sk(i, j, k, 1) - q_y*sk(i, j, k, 2) - q_z*sk&
&         (i, j, k, 3)
! update the residuals of cell k and k+1.
        fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
        fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
        fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
        fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fmx
        fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fmy
        fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fmz
        fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + frhoe
! store the stress tensor and the heat flux vector if this
! face is part of a viscous subface. both the cases k == 1
! and k == kl must be tested.
        if (k .eq. 1 .and. storewalltensor .and. visckminpointer(i, j) &
&           .gt. 0) then
! we need to index viscsubface with visckminpointer(i,j)
! since tapenade does not like temporary indexes
          viscsubface(visckminpointer(i, j))%tau(i, j, 1) = tauxx
          viscsubface(visckminpointer(i, j))%tau(i, j, 2) = tauyy
          viscsubface(visckminpointer(i, j))%tau(i, j, 3) = tauzz
          viscsubface(visckminpointer(i, j))%tau(i, j, 4) = tauxy
          viscsubface(visckminpointer(i, j))%tau(i, j, 5) = tauxz
          viscsubface(visckminpointer(i, j))%tau(i, j, 6) = tauyz
          viscsubface(visckminpointer(i, j))%q(i, j, 1) = q_x
          viscsubface(visckminpointer(i, j))%q(i, j, 2) = q_y
          viscsubface(visckminpointer(i, j))%q(i, j, 3) = q_z
        end if
! and the k == kl case.
        if (k .eq. kl .and. storewalltensor .and. visckmaxpointer(i, j) &
&           .gt. 0) then
          viscsubface(visckmaxpointer(i, j))%tau(i, j, 1) = tauxx
          viscsubface(visckmaxpointer(i, j))%tau(i, j, 2) = tauyy
          viscsubface(visckmaxpointer(i, j))%tau(i, j, 3) = tauzz
          viscsubface(visckmaxpointer(i, j))%tau(i, j, 4) = tauxy
          viscsubface(visckmaxpointer(i, j))%tau(i, j, 5) = tauxz
          viscsubface(visckmaxpointer(i, j))%tau(i, j, 6) = tauyz
          viscsubface(visckmaxpointer(i, j))%q(i, j, 1) = q_x
          viscsubface(visckmaxpointer(i, j))%q(i, j, 2) = q_y
          viscsubface(visckmaxpointer(i, j))%q(i, j, 3) = q_z
        end if
      end do
!$ad checkpoint-end
!
!         viscous fluxes in the j-direction.
!
      continue
!$ad checkpoint-start
      mue = zero
!$ad ii-loop
      do ii=0,nx*jl*nz-1
        i = mod(ii, nx) + 2
        j = mod(ii/nx, jl) + 1
        k = ii/(nx*jl) + 2
! set the value of the porosity. if not zero, it is set
! to average the eddy-viscosity and to take the factor
! rfilv into account.
        por = half*rfilv
        if (porj(i, j, k) .eq. noflux) por = zero
! compute the laminar and (if present) the eddy viscosities
! multiplied by the porosity. compute the factor in front of
! the gradients of the speed of sound squared for the heat
! flux.
        mul = por*(rlv(i, j, k)+rlv(i, j+1, k))
        if (eddymodel) mue = por*(rev(i, j, k)+rev(i, j+1, k))
        mut = mul + mue
        gm1 = half*(gamma(i, j, k)+gamma(i, j+1, k)) - one
        factlamheat = one/(prandtl*gm1)
        factturbheat = one/(prandtlturb*gm1)
        heatcoef = mul*factlamheat + mue*factturbheat
! compute the gradients at the face by averaging the four
! nodal values.
        u_x = fourth*(ux(i-1, j, k-1)+ux(i, j, k-1)+ux(i-1, j, k)+ux(i, &
&         j, k))
        u_y = fourth*(uy(i-1, j, k-1)+uy(i, j, k-1)+uy(i-1, j, k)+uy(i, &
&         j, k))
        u_z = fourth*(uz(i-1, j, k-1)+uz(i, j, k-1)+uz(i-1, j, k)+uz(i, &
&         j, k))
        v_x = fourth*(vx(i-1, j, k-1)+vx(i, j, k-1)+vx(i-1, j, k)+vx(i, &
&         j, k))
        v_y = fourth*(vy(i-1, j, k-1)+vy(i, j, k-1)+vy(i-1, j, k)+vy(i, &
&         j, k))
        v_z = fourth*(vz(i-1, j, k-1)+vz(i, j, k-1)+vz(i-1, j, k)+vz(i, &
&         j, k))
        w_x = fourth*(wx(i-1, j, k-1)+wx(i, j, k-1)+wx(i-1, j, k)+wx(i, &
&         j, k))
        w_y = fourth*(wy(i-1, j, k-1)+wy(i, j, k-1)+wy(i-1, j, k)+wy(i, &
&         j, k))
        w_z = fourth*(wz(i-1, j, k-1)+wz(i, j, k-1)+wz(i-1, j, k)+wz(i, &
&         j, k))
        q_x = fourth*(qx(i-1, j, k-1)+qx(i, j, k-1)+qx(i-1, j, k)+qx(i, &
&         j, k))
        q_y = fourth*(qy(i-1, j, k-1)+qy(i, j, k-1)+qy(i-1, j, k)+qy(i, &
&         j, k))
        q_z = fourth*(qz(i-1, j, k-1)+qz(i, j, k-1)+qz(i-1, j, k)+qz(i, &
&         j, k))
! the gradients in the normal direction are corrected, such
! that no averaging takes places here.
! first determine the vector in the direction from the
! cell center j to cell center j+1.
        ssx = eighth*(x(i-1, j+1, k-1, 1)-x(i-1, j-1, k-1, 1)+x(i-1, j+1&
&         , k, 1)-x(i-1, j-1, k, 1)+x(i, j+1, k-1, 1)-x(i, j-1, k-1, 1)+&
&         x(i, j+1, k, 1)-x(i, j-1, k, 1))
        ssy = eighth*(x(i-1, j+1, k-1, 2)-x(i-1, j-1, k-1, 2)+x(i-1, j+1&
&         , k, 2)-x(i-1, j-1, k, 2)+x(i, j+1, k-1, 2)-x(i, j-1, k-1, 2)+&
&         x(i, j+1, k, 2)-x(i, j-1, k, 2))
        ssz = eighth*(x(i-1, j+1, k-1, 3)-x(i-1, j-1, k-1, 3)+x(i-1, j+1&
&         , k, 3)-x(i-1, j-1, k, 3)+x(i, j+1, k-1, 3)-x(i, j-1, k-1, 3)+&
&         x(i, j+1, k, 3)-x(i, j-1, k, 3))
! determine the length of this vector and create the
! unit normal.
        ss = one/sqrt(ssx*ssx+ssy*ssy+ssz*ssz)
        ssx = ss*ssx
        ssy = ss*ssy
        ssz = ss*ssz
! correct the gradients.
        corr = u_x*ssx + u_y*ssy + u_z*ssz - (w(i, j+1, k, ivx)-w(i, j, &
&         k, ivx))*ss
        u_x = u_x - corr*ssx
        u_y = u_y - corr*ssy
        u_z = u_z - corr*ssz
        corr = v_x*ssx + v_y*ssy + v_z*ssz - (w(i, j+1, k, ivy)-w(i, j, &
&         k, ivy))*ss
        v_x = v_x - corr*ssx
        v_y = v_y - corr*ssy
        v_z = v_z - corr*ssz
        corr = w_x*ssx + w_y*ssy + w_z*ssz - (w(i, j+1, k, ivz)-w(i, j, &
&         k, ivz))*ss
        w_x = w_x - corr*ssx
        w_y = w_y - corr*ssy
        w_z = w_z - corr*ssz
        corr = q_x*ssx + q_y*ssy + q_z*ssz + (aa(i, j+1, k)-aa(i, j, k))&
&         *ss
        q_x = q_x - corr*ssx
        q_y = q_y - corr*ssy
        q_z = q_z - corr*ssz
! compute the stress tensor and the heat flux vector.
! we remove the viscosity from the stress tensor (tau)
! to define taus since we still need to separate between
! laminar and turbulent stress for qcr.
! therefore, laminar tau = mue*taus, turbulent
! tau = mue*taus, and total tau = mut*taus.
        fracdiv = twothird*(u_x+v_y+w_z)
        tauxxs = two*u_x - fracdiv
        tauyys = two*v_y - fracdiv
        tauzzs = two*w_z - fracdiv
        tauxys = u_y + v_x
        tauxzs = u_z + w_x
        tauyzs = v_z + w_y
        q_x = heatcoef*q_x
        q_y = heatcoef*q_y
        q_z = heatcoef*q_z
! add qcr corrections if necessary
        if (useqcr) then
! in the qcr formulation, we add an extra term to the turbulent stress tensor:
!
! tau_ij,qcr = tau_ij - e_ij
!
! where, according to tmr website (http://turbmodels.larc.nasa.gov/spalart.html):
!
! e_ij = ccr1*(o_ik*tau_jk + o_jk*tau_ik)
!
! we are computing o_ik as follows:
!
! o_ik = 2*w_ik/den
!
! remember that the tau_ij in e_ij should use only the eddy viscosity!
! compute denominator
          den = sqrt(u_x*u_x + u_y*u_y + u_z*u_z + v_x*v_x + v_y*v_y + &
&           v_z*v_z + w_x*w_x + w_y*w_y + w_z*w_z)
          if (den .lt. xminn) then
            den = xminn
          else
            den = den
          end if
! compute factor that will multiply all tensor components.
! here we add the eddy viscosity that should multiply the stress tensor (tau)
! components as well.
          fact = mue*ccr1/den
! compute off-diagonal terms of vorticity tensor (we will ommit the 1/2)
! the diagonals of the vorticity tensor components are always zero
          wxy = u_y - v_x
          wxz = u_z - w_x
          wyz = v_z - w_y
          wyx = -wxy
          wzx = -wxz
          wzy = -wyz
! compute the extra terms of the boussinesq relation
          exx = fact*(wxy*tauxys+wxz*tauxzs)*two
          eyy = fact*(wyx*tauxys+wyz*tauyzs)*two
          ezz = fact*(wzx*tauxzs+wzy*tauyzs)*two
          exy = fact*(wxy*tauyys+wxz*tauyzs+wyx*tauxxs+wyz*tauxzs)
          exz = fact*(wxy*tauyzs+wxz*tauzzs+wzx*tauxxs+wzy*tauxys)
          eyz = fact*(wyx*tauxzs+wyz*tauzzs+wzx*tauxys+wzy*tauyys)
! apply the total viscosity to the stress tensor and add extra terms
          tauxx = mut*tauxxs - exx
          tauyy = mut*tauyys - eyy
          tauzz = mut*tauzzs - ezz
          tauxy = mut*tauxys - exy
          tauxz = mut*tauxzs - exz
          tauyz = mut*tauyzs - eyz
        else
! just apply the total viscosity to the stress tensor
          tauxx = mut*tauxxs
          tauyy = mut*tauyys
          tauzz = mut*tauzzs
          tauxy = mut*tauxys
          tauxz = mut*tauxzs
          tauyz = mut*tauyzs
        end if
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
        ubar = half*(w(i, j, k, ivx)+w(i, j+1, k, ivx))
        vbar = half*(w(i, j, k, ivy)+w(i, j+1, k, ivy))
        wbar = half*(w(i, j, k, ivz)+w(i, j+1, k, ivz))
! compute the viscous fluxes for this j-face.
        fmx = tauxx*sj(i, j, k, 1) + tauxy*sj(i, j, k, 2) + tauxz*sj(i, &
&         j, k, 3)
        fmy = tauxy*sj(i, j, k, 1) + tauyy*sj(i, j, k, 2) + tauyz*sj(i, &
&         j, k, 3)
        fmz = tauxz*sj(i, j, k, 1) + tauyz*sj(i, j, k, 2) + tauzz*sj(i, &
&         j, k, 3)
        frhoe = (ubar*tauxx+vbar*tauxy+wbar*tauxz)*sj(i, j, k, 1) + (&
&         ubar*tauxy+vbar*tauyy+wbar*tauyz)*sj(i, j, k, 2) + (ubar*tauxz&
&         +vbar*tauyz+wbar*tauzz)*sj(i, j, k, 3) - q_x*sj(i, j, k, 1) - &
&         q_y*sj(i, j, k, 2) - q_z*sj(i, j, k, 3)
! update the residuals of cell j and j+1.
        fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
        fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
        fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
        fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fmx
        fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fmy
        fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fmz
        fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + frhoe
! store the stress tensor and the heat flux vector if this
! face is part of a viscous subface. both the cases j == 1
! and j == jl must be tested.
        if (j .eq. 1 .and. storewalltensor .and. viscjminpointer(i, k) &
&           .gt. 0) then
! we need to index viscsubface with viscjminpointer(i,k)
! since tapenade does not like temporary indexes
          viscsubface(viscjminpointer(i, k))%tau(i, k, 1) = tauxx
          viscsubface(viscjminpointer(i, k))%tau(i, k, 2) = tauyy
          viscsubface(viscjminpointer(i, k))%tau(i, k, 3) = tauzz
          viscsubface(viscjminpointer(i, k))%tau(i, k, 4) = tauxy
          viscsubface(viscjminpointer(i, k))%tau(i, k, 5) = tauxz
          viscsubface(viscjminpointer(i, k))%tau(i, k, 6) = tauyz
          viscsubface(viscjminpointer(i, k))%q(i, k, 1) = q_x
          viscsubface(viscjminpointer(i, k))%q(i, k, 2) = q_y
          viscsubface(viscjminpointer(i, k))%q(i, k, 3) = q_z
        end if
! and the j == jl case.
        if (j .eq. jl .and. storewalltensor .and. viscjmaxpointer(i, k) &
&           .gt. 0) then
          viscsubface(viscjmaxpointer(i, k))%tau(i, k, 1) = tauxx
          viscsubface(viscjmaxpointer(i, k))%tau(i, k, 2) = tauyy
          viscsubface(viscjmaxpointer(i, k))%tau(i, k, 3) = tauzz
          viscsubface(viscjmaxpointer(i, k))%tau(i, k, 4) = tauxy
          viscsubface(viscjmaxpointer(i, k))%tau(i, k, 5) = tauxz
          viscsubface(viscjmaxpointer(i, k))%tau(i, k, 6) = tauyz
          viscsubface(viscjmaxpointer(i, k))%q(i, k, 1) = q_x
          viscsubface(viscjmaxpointer(i, k))%q(i, k, 2) = q_y
          viscsubface(viscjmaxpointer(i, k))%q(i, k, 3) = q_z
        end if
      end do
!$ad checkpoint-end
!
!         viscous fluxes in the i-direction.
!
      continue
!$ad checkpoint-start
      mue = zero
!$ad ii-loop
      do ii=0,il*ny*nz-1
        i = mod(ii, il) + 1
        j = mod(ii/il, ny) + 2
        k = ii/(il*ny) + 2
! set the value of the porosity. if not zero, it is set
! to average the eddy-viscosity and to take the factor
! rfilv into account.
        por = half*rfilv
        if (pori(i, j, k) .eq. noflux) por = zero
! compute the laminar and (if present) the eddy viscosities
! multiplied the porosity. compute the factor in front of
! the gradients of the speed of sound squared for the heat
! flux.
        mul = por*(rlv(i, j, k)+rlv(i+1, j, k))
        if (eddymodel) mue = por*(rev(i, j, k)+rev(i+1, j, k))
        mut = mul + mue
        gm1 = half*(gamma(i, j, k)+gamma(i+1, j, k)) - one
        factlamheat = one/(prandtl*gm1)
        factturbheat = one/(prandtlturb*gm1)
        heatcoef = mul*factlamheat + mue*factturbheat
! compute the gradients at the face by averaging the four
! nodal values.
        u_x = fourth*(ux(i, j-1, k-1)+ux(i, j, k-1)+ux(i, j-1, k)+ux(i, &
&         j, k))
        u_y = fourth*(uy(i, j-1, k-1)+uy(i, j, k-1)+uy(i, j-1, k)+uy(i, &
&         j, k))
        u_z = fourth*(uz(i, j-1, k-1)+uz(i, j, k-1)+uz(i, j-1, k)+uz(i, &
&         j, k))
        v_x = fourth*(vx(i, j-1, k-1)+vx(i, j, k-1)+vx(i, j-1, k)+vx(i, &
&         j, k))
        v_y = fourth*(vy(i, j-1, k-1)+vy(i, j, k-1)+vy(i, j-1, k)+vy(i, &
&         j, k))
        v_z = fourth*(vz(i, j-1, k-1)+vz(i, j, k-1)+vz(i, j-1, k)+vz(i, &
&         j, k))
        w_x = fourth*(wx(i, j-1, k-1)+wx(i, j, k-1)+wx(i, j-1, k)+wx(i, &
&         j, k))
        w_y = fourth*(wy(i, j-1, k-1)+wy(i, j, k-1)+wy(i, j-1, k)+wy(i, &
&         j, k))
        w_z = fourth*(wz(i, j-1, k-1)+wz(i, j, k-1)+wz(i, j-1, k)+wz(i, &
&         j, k))
        q_x = fourth*(qx(i, j-1, k-1)+qx(i, j, k-1)+qx(i, j-1, k)+qx(i, &
&         j, k))
        q_y = fourth*(qy(i, j-1, k-1)+qy(i, j, k-1)+qy(i, j-1, k)+qy(i, &
&         j, k))
        q_z = fourth*(qz(i, j-1, k-1)+qz(i, j, k-1)+qz(i, j-1, k)+qz(i, &
&         j, k))
! the gradients in the normal direction are corrected, such
! that no averaging takes places here.
! first determine the vector in the direction from the
! cell center i to cell center i+1.
        ssx = eighth*(x(i+1, j-1, k-1, 1)-x(i-1, j-1, k-1, 1)+x(i+1, j-1&
&         , k, 1)-x(i-1, j-1, k, 1)+x(i+1, j, k-1, 1)-x(i-1, j, k-1, 1)+&
&         x(i+1, j, k, 1)-x(i-1, j, k, 1))
        ssy = eighth*(x(i+1, j-1, k-1, 2)-x(i-1, j-1, k-1, 2)+x(i+1, j-1&
&         , k, 2)-x(i-1, j-1, k, 2)+x(i+1, j, k-1, 2)-x(i-1, j, k-1, 2)+&
&         x(i+1, j, k, 2)-x(i-1, j, k, 2))
        ssz = eighth*(x(i+1, j-1, k-1, 3)-x(i-1, j-1, k-1, 3)+x(i+1, j-1&
&         , k, 3)-x(i-1, j-1, k, 3)+x(i+1, j, k-1, 3)-x(i-1, j, k-1, 3)+&
&         x(i+1, j, k, 3)-x(i-1, j, k, 3))
! determine the length of this vector and create the
! unit normal.
        ss = one/sqrt(ssx*ssx+ssy*ssy+ssz*ssz)
        ssx = ss*ssx
        ssy = ss*ssy
        ssz = ss*ssz
! correct the gradients.
        corr = u_x*ssx + u_y*ssy + u_z*ssz - (w(i+1, j, k, ivx)-w(i, j, &
&         k, ivx))*ss
        u_x = u_x - corr*ssx
        u_y = u_y - corr*ssy
        u_z = u_z - corr*ssz
        corr = v_x*ssx + v_y*ssy + v_z*ssz - (w(i+1, j, k, ivy)-w(i, j, &
&         k, ivy))*ss
        v_x = v_x - corr*ssx
        v_y = v_y - corr*ssy
        v_z = v_z - corr*ssz
        corr = w_x*ssx + w_y*ssy + w_z*ssz - (w(i+1, j, k, ivz)-w(i, j, &
&         k, ivz))*ss
        w_x = w_x - corr*ssx
        w_y = w_y - corr*ssy
        w_z = w_z - corr*ssz
        corr = q_x*ssx + q_y*ssy + q_z*ssz + (aa(i+1, j, k)-aa(i, j, k))&
&         *ss
        q_x = q_x - corr*ssx
        q_y = q_y - corr*ssy
        q_z = q_z - corr*ssz
! compute the stress tensor and the heat flux vector.
! we remove the viscosity from the stress tensor (tau)
! to define taus since we still need to separate between
! laminar and turbulent stress for qcr.
! therefore, laminar tau = mue*taus, turbulent
! tau = mue*taus, and total tau = mut*taus.
        fracdiv = twothird*(u_x+v_y+w_z)
        tauxxs = two*u_x - fracdiv
        tauyys = two*v_y - fracdiv
        tauzzs = two*w_z - fracdiv
        tauxys = u_y + v_x
        tauxzs = u_z + w_x
        tauyzs = v_z + w_y
        q_x = heatcoef*q_x
        q_y = heatcoef*q_y
        q_z = heatcoef*q_z
! add qcr corrections if necessary
        if (useqcr) then
! in the qcr formulation, we add an extra term to the turbulent stress tensor:
!
! tau_ij,qcr = tau_ij - e_ij
!
! where, according to tmr website (http://turbmodels.larc.nasa.gov/spalart.html):
!
! e_ij = ccr1*(o_ik*tau_jk + o_jk*tau_ik)
!
! we are computing o_ik as follows:
!
! o_ik = 2*w_ik/den
!
! remember that the tau_ij in e_ij should use only the eddy viscosity!
! compute denominator
          den = sqrt(u_x*u_x + u_y*u_y + u_z*u_z + v_x*v_x + v_y*v_y + &
&           v_z*v_z + w_x*w_x + w_y*w_y + w_z*w_z)
          if (den .lt. xminn) then
            den = xminn
          else
            den = den
          end if
! compute factor that will multiply all tensor components.
! here we add the eddy viscosity that should multiply the stress tensor (tau)
! components as well.
          fact = mue*ccr1/den
! compute off-diagonal terms of vorticity tensor (we will ommit the 1/2)
! the diagonals of the vorticity tensor components are always zero
          wxy = u_y - v_x
          wxz = u_z - w_x
          wyz = v_z - w_y
          wyx = -wxy
          wzx = -wxz
          wzy = -wyz
! compute the extra terms of the boussinesq relation
          exx = fact*(wxy*tauxys+wxz*tauxzs)*two
          eyy = fact*(wyx*tauxys+wyz*tauyzs)*two
          ezz = fact*(wzx*tauxzs+wzy*tauyzs)*two
          exy = fact*(wxy*tauyys+wxz*tauyzs+wyx*tauxxs+wyz*tauxzs)
          exz = fact*(wxy*tauyzs+wxz*tauzzs+wzx*tauxxs+wzy*tauxys)
          eyz = fact*(wyx*tauxzs+wyz*tauzzs+wzx*tauxys+wzy*tauyys)
! apply the total viscosity to the stress tensor and add extra terms
          tauxx = mut*tauxxs - exx
          tauyy = mut*tauyys - eyy
          tauzz = mut*tauzzs - ezz
          tauxy = mut*tauxys - exy
          tauxz = mut*tauxzs - exz
          tauyz = mut*tauyzs - eyz
        else
! just apply the total viscosity to the stress tensor
          tauxx = mut*tauxxs
          tauyy = mut*tauyys
          tauzz = mut*tauzzs
          tauxy = mut*tauxys
          tauxz = mut*tauxzs
          tauyz = mut*tauyzs
        end if
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
        ubar = half*(w(i, j, k, ivx)+w(i+1, j, k, ivx))
        vbar = half*(w(i, j, k, ivy)+w(i+1, j, k, ivy))
        wbar = half*(w(i, j, k, ivz)+w(i+1, j, k, ivz))
! compute the viscous fluxes for this i-face.
        fmx = tauxx*si(i, j, k, 1) + tauxy*si(i, j, k, 2) + tauxz*si(i, &
&         j, k, 3)
        fmy = tauxy*si(i, j, k, 1) + tauyy*si(i, j, k, 2) + tauyz*si(i, &
&         j, k, 3)
        fmz = tauxz*si(i, j, k, 1) + tauyz*si(i, j, k, 2) + tauzz*si(i, &
&         j, k, 3)
        frhoe = (ubar*tauxx+vbar*tauxy+wbar*tauxz)*si(i, j, k, 1) + (&
&         ubar*tauxy+vbar*tauyy+wbar*tauyz)*si(i, j, k, 2) + (ubar*tauxz&
&         +vbar*tauyz+wbar*tauzz)*si(i, j, k, 3) - q_x*si(i, j, k, 1) - &
&         q_y*si(i, j, k, 2) - q_z*si(i, j, k, 3)
! update the residuals of cell i and i+1.
        fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
        fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
        fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
        fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
        fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fmx
        fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fmy
        fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fmz
        fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + frhoe
! store the stress tensor and the heat flux vector if this
! face is part of a viscous subface. both the cases i == 1
! and i == il must be tested.
        if (i .eq. 1 .and. storewalltensor .and. visciminpointer(j, k) &
&           .gt. 0) then
! we need to index viscsubface with visciminpointer(j,k)
! since tapenade does not like temporary indexes
          viscsubface(visciminpointer(j, k))%tau(j, k, 1) = tauxx
          viscsubface(visciminpointer(j, k))%tau(j, k, 2) = tauyy
          viscsubface(visciminpointer(j, k))%tau(j, k, 3) = tauzz
          viscsubface(visciminpointer(j, k))%tau(j, k, 4) = tauxy
          viscsubface(visciminpointer(j, k))%tau(j, k, 5) = tauxz
          viscsubface(visciminpointer(j, k))%tau(j, k, 6) = tauyz
          viscsubface(visciminpointer(j, k))%q(j, k, 1) = q_x
          viscsubface(visciminpointer(j, k))%q(j, k, 2) = q_y
          viscsubface(visciminpointer(j, k))%q(j, k, 3) = q_z
        end if
! and the i == il case.
        if (i .eq. il .and. storewalltensor .and. viscimaxpointer(j, k) &
&           .gt. 0) then
! we need to index viscsubface with viscimaxpointer(j,k)
! since tapenade does not like temporary indexes
          viscsubface(viscimaxpointer(j, k))%tau(j, k, 1) = tauxx
          viscsubface(viscimaxpointer(j, k))%tau(j, k, 2) = tauyy
          viscsubface(viscimaxpointer(j, k))%tau(j, k, 3) = tauzz
          viscsubface(viscimaxpointer(j, k))%tau(j, k, 4) = tauxy
          viscsubface(viscimaxpointer(j, k))%tau(j, k, 5) = tauxz
          viscsubface(viscimaxpointer(j, k))%tau(j, k, 6) = tauyz
          viscsubface(viscimaxpointer(j, k))%q(j, k, 1) = q_x
          viscsubface(viscimaxpointer(j, k))%q(j, k, 2) = q_y
          viscsubface(viscimaxpointer(j, k))%q(j, k, 3) = q_z
        end if
      end do
!$ad checkpoint-end
      continue
! possibly correct the wall shear stress.
! wall function is not aded
    end if
  end subroutine viscousflux
 
  subroutine viscousfluxapprox()
    use constants
    use blockpointers
    use flowvarrefstate
    use inputphysics
    use iteration
    implicit none
!
!      local parameter.
!
    real(kind=realtype), parameter :: twothird=two*third
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k
    integer(kind=inttype) :: ii, jj, kk
    real(kind=realtype) :: rfilv, por, mul, mue, mut, heatcoef
    real(kind=realtype) :: gm1, factlamheat, factturbheat
    real(kind=realtype) :: u_x, u_y, u_z, v_x, v_y, v_z, w_x, w_y, w_z
    real(kind=realtype) :: q_x, q_y, q_z, ubar, vbar, wbar
    real(kind=realtype) :: corr, ssx, ssy, ssz, ss, fracdiv
    real(kind=realtype) :: tauxx, tauyy, tauzz
    real(kind=realtype) :: tauxy, tauxz, tauyz
    real(kind=realtype) :: fmx, fmy, fmz, frhoe
    real(kind=realtype) :: dd
    logical :: correctfork
    mue = zero
    rfilv = rfil
! viscous fluxes in the i-direction
    do k=2,kl
      do j=2,jl
        do i=1,il
! compute the vector from the center of cell i to cell i+1
          ssx = eighth*(x(i+1, j-1, k-1, 1)-x(i-1, j-1, k-1, 1)+x(i+1, j&
&           -1, k, 1)-x(i-1, j-1, k, 1)+x(i+1, j, k-1, 1)-x(i-1, j, k-1&
&           , 1)+x(i+1, j, k, 1)-x(i-1, j, k, 1))
          ssy = eighth*(x(i+1, j-1, k-1, 2)-x(i-1, j-1, k-1, 2)+x(i+1, j&
&           -1, k, 2)-x(i-1, j-1, k, 2)+x(i+1, j, k-1, 2)-x(i-1, j, k-1&
&           , 2)+x(i+1, j, k, 2)-x(i-1, j, k, 2))
          ssz = eighth*(x(i+1, j-1, k-1, 3)-x(i-1, j-1, k-1, 3)+x(i+1, j&
&           -1, k, 3)-x(i-1, j-1, k, 3)+x(i+1, j, k-1, 3)-x(i-1, j, k-1&
&           , 3)+x(i+1, j, k, 3)-x(i-1, j, k, 3))
! and determine one/ length of vector squared
          ss = one/(ssx*ssx+ssy*ssy+ssz*ssz)
          ssx = ss*ssx
          ssy = ss*ssy
          ssz = ss*ssz
! now compute each gradient
          dd = w(i+1, j, k, ivx) - w(i, j, k, ivx)
          u_x = dd*ssx
          u_y = dd*ssy
          u_z = dd*ssz
          dd = w(i+1, j, k, ivy) - w(i, j, k, ivy)
          v_x = dd*ssx
          v_y = dd*ssy
          v_z = dd*ssz
          dd = w(i+1, j, k, ivz) - w(i, j, k, ivz)
          w_x = dd*ssx
          w_y = dd*ssy
          w_z = dd*ssz
          dd = aa(i+1, j, k) - aa(i, j, k)
          q_x = -(dd*ssx)
          q_y = -(dd*ssy)
          q_z = -(dd*ssz)
          por = half*rfilv
          if (pori(i, j, k) .eq. noflux) por = zero
! compute the laminar and (if present) the eddy viscosities
! multiplied by the porosity. compute the factor in front of
! the gradients of the speed of sound squared for the heat
! flux.
          mul = por*(rlv(i, j, k)+rlv(i+1, j, k))
          if (eddymodel) mue = por*(rev(i, j, k)+rev(i+1, j, k))
          mut = mul + mue
          gm1 = half*(gamma(i, j, k)+gamma(i+1, j, k)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          heatcoef = mul*factlamheat + mue*factturbheat
! compute the stress tensor and the heat flux vector.
          fracdiv = twothird*(u_x+v_y+w_z)
          tauxx = mut*(two*u_x-fracdiv)
          tauyy = mut*(two*v_y-fracdiv)
          tauzz = mut*(two*w_z-fracdiv)
          tauxy = mut*(u_y+v_x)
          tauxz = mut*(u_z+w_x)
          tauyz = mut*(v_z+w_y)
          q_x = heatcoef*q_x
          q_y = heatcoef*q_y
          q_z = heatcoef*q_z
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
          ubar = half*(w(i, j, k, ivx)+w(i+1, j, k, ivx))
          vbar = half*(w(i, j, k, ivy)+w(i+1, j, k, ivy))
          wbar = half*(w(i, j, k, ivz)+w(i+1, j, k, ivz))
! compute the viscous fluxes for this i-face.
          fmx = tauxx*si(i, j, k, 1) + tauxy*si(i, j, k, 2) + tauxz*si(i&
&           , j, k, 3)
          fmy = tauxy*si(i, j, k, 1) + tauyy*si(i, j, k, 2) + tauyz*si(i&
&           , j, k, 3)
          fmz = tauxz*si(i, j, k, 1) + tauyz*si(i, j, k, 2) + tauzz*si(i&
&           , j, k, 3)
          frhoe = (ubar*tauxx+vbar*tauxy+wbar*tauxz)*si(i, j, k, 1) + (&
&           ubar*tauxy+vbar*tauyy+wbar*tauyz)*si(i, j, k, 2) + (ubar*&
&           tauxz+vbar*tauyz+wbar*tauzz)*si(i, j, k, 3) - q_x*si(i, j, k&
&           , 1) - q_y*si(i, j, k, 2) - q_z*si(i, j, k, 3)
! update the residuals of cell i and i+1.
          fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
          fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
          fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
          fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
          fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fmx
          fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fmy
          fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fmz
          fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + frhoe
        end do
      end do
    end do
! viscous fluxes in the j-direction
    do k=2,kl
      do j=1,jl
        do i=2,il
! compute the vector from the center of cell j to cell j+1
          ssx = eighth*(x(i-1, j+1, k-1, 1)-x(i-1, j-1, k-1, 1)+x(i-1, j&
&           +1, k, 1)-x(i-1, j-1, k, 1)+x(i, j+1, k-1, 1)-x(i, j-1, k-1&
&           , 1)+x(i, j+1, k, 1)-x(i, j-1, k, 1))
          ssy = eighth*(x(i-1, j+1, k-1, 2)-x(i-1, j-1, k-1, 2)+x(i-1, j&
&           +1, k, 2)-x(i-1, j-1, k, 2)+x(i, j+1, k-1, 2)-x(i, j-1, k-1&
&           , 2)+x(i, j+1, k, 2)-x(i, j-1, k, 2))
          ssz = eighth*(x(i-1, j+1, k-1, 3)-x(i-1, j-1, k-1, 3)+x(i-1, j&
&           +1, k, 3)-x(i-1, j-1, k, 3)+x(i, j+1, k-1, 3)-x(i, j-1, k-1&
&           , 3)+x(i, j+1, k, 3)-x(i, j-1, k, 3))
! and determine one/ length of vector squared
          ss = one/(ssx*ssx+ssy*ssy+ssz*ssz)
          ssx = ss*ssx
          ssy = ss*ssy
          ssz = ss*ssz
! now compute each gradient
          dd = w(i, j+1, k, ivx) - w(i, j, k, ivx)
          u_x = dd*ssx
          u_y = dd*ssy
          u_z = dd*ssz
          dd = w(i, j+1, k, ivy) - w(i, j, k, ivy)
          v_x = dd*ssx
          v_y = dd*ssy
          v_z = dd*ssz
          dd = w(i, j+1, k, ivz) - w(i, j, k, ivz)
          w_x = dd*ssx
          w_y = dd*ssy
          w_z = dd*ssz
          dd = aa(i, j+1, k) - aa(i, j, k)
          q_x = -(dd*ssx)
          q_y = -(dd*ssy)
          q_z = -(dd*ssz)
          por = half*rfilv
          if (porj(i, j, k) .eq. noflux) por = zero
! compute the laminar and (if present) the eddy viscosities
! multiplied by the porosity. compute the factor in front of
! the gradients of the speed of sound squared for the heat
! flux.
          mul = por*(rlv(i, j, k)+rlv(i, j+1, k))
          if (eddymodel) mue = por*(rev(i, j, k)+rev(i, j+1, k))
          mut = mul + mue
          gm1 = half*(gamma(i, j, k)+gamma(i, j+1, k)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          heatcoef = mul*factlamheat + mue*factturbheat
! compute the stress tensor and the heat flux vector.
          fracdiv = twothird*(u_x+v_y+w_z)
          tauxx = mut*(two*u_x-fracdiv)
          tauyy = mut*(two*v_y-fracdiv)
          tauzz = mut*(two*w_z-fracdiv)
          tauxy = mut*(u_y+v_x)
          tauxz = mut*(u_z+w_x)
          tauyz = mut*(v_z+w_y)
          q_x = heatcoef*q_x
          q_y = heatcoef*q_y
          q_z = heatcoef*q_z
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
          ubar = half*(w(i, j, k, ivx)+w(i, j+1, k, ivx))
          vbar = half*(w(i, j, k, ivy)+w(i, j+1, k, ivy))
          wbar = half*(w(i, j, k, ivz)+w(i, j+1, k, ivz))
! compute the viscous fluxes for this j-face.
          fmx = tauxx*sj(i, j, k, 1) + tauxy*sj(i, j, k, 2) + tauxz*sj(i&
&           , j, k, 3)
          fmy = tauxy*sj(i, j, k, 1) + tauyy*sj(i, j, k, 2) + tauyz*sj(i&
&           , j, k, 3)
          fmz = tauxz*sj(i, j, k, 1) + tauyz*sj(i, j, k, 2) + tauzz*sj(i&
&           , j, k, 3)
          frhoe = (ubar*tauxx+vbar*tauxy+wbar*tauxz)*sj(i, j, k, 1) + (&
&           ubar*tauxy+vbar*tauyy+wbar*tauyz)*sj(i, j, k, 2) + (ubar*&
&           tauxz+vbar*tauyz+wbar*tauzz)*sj(i, j, k, 3) - q_x*sj(i, j, k&
&           , 1) - q_y*sj(i, j, k, 2) - q_z*sj(i, j, k, 3)
! update the residuals of cell j and j+1.
          fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
          fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
          fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
          fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
          fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fmx
          fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fmy
          fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fmz
          fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + frhoe
        end do
      end do
    end do
! viscous fluxes in the k-direction
    do k=1,kl
      do j=2,jl
        do i=2,il
! compute the vector from the center of cell k to cell k+1
          ssx = eighth*(x(i-1, j-1, k+1, 1)-x(i-1, j-1, k-1, 1)+x(i-1, j&
&           , k+1, 1)-x(i-1, j, k-1, 1)+x(i, j-1, k+1, 1)-x(i, j-1, k-1&
&           , 1)+x(i, j, k+1, 1)-x(i, j, k-1, 1))
          ssy = eighth*(x(i-1, j-1, k+1, 2)-x(i-1, j-1, k-1, 2)+x(i-1, j&
&           , k+1, 2)-x(i-1, j, k-1, 2)+x(i, j-1, k+1, 2)-x(i, j-1, k-1&
&           , 2)+x(i, j, k+1, 2)-x(i, j, k-1, 2))
          ssz = eighth*(x(i-1, j-1, k+1, 3)-x(i-1, j-1, k-1, 3)+x(i-1, j&
&           , k+1, 3)-x(i-1, j, k-1, 3)+x(i, j-1, k+1, 3)-x(i, j-1, k-1&
&           , 3)+x(i, j, k+1, 3)-x(i, j, k-1, 3))
! and determine one/ length of vector squared
          ss = one/(ssx*ssx+ssy*ssy+ssz*ssz)
          ssx = ss*ssx
          ssy = ss*ssy
          ssz = ss*ssz
! now compute each gradient
          dd = w(i, j, k+1, ivx) - w(i, j, k, ivx)
          u_x = dd*ssx
          u_y = dd*ssy
          u_z = dd*ssz
          dd = w(i, j, k+1, ivy) - w(i, j, k, ivy)
          v_x = dd*ssx
          v_y = dd*ssy
          v_z = dd*ssz
          dd = w(i, j, k+1, ivz) - w(i, j, k, ivz)
          w_x = dd*ssx
          w_y = dd*ssy
          w_z = dd*ssz
          dd = aa(i, j, k+1) - aa(i, j, k)
          q_x = -(dd*ssx)
          q_y = -(dd*ssy)
          q_z = -(dd*ssz)
          por = half*rfilv
          if (pork(i, j, k) .eq. noflux) por = zero
! compute the laminar and (if present) the eddy viscosities
! multiplied by the porosity. compute the factor in front of
! the gradients of the speed of sound squared for the heat
! flux.
          mul = por*(rlv(i, j, k)+rlv(i, j, k+1))
          if (eddymodel) mue = por*(rev(i, j, k)+rev(i, j, k+1))
          mut = mul + mue
          gm1 = half*(gamma(i, j, k)+gamma(i, j, k+1)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          heatcoef = mul*factlamheat + mue*factturbheat
! compute the stress tensor and the heat flux vector.
          fracdiv = twothird*(u_x+v_y+w_z)
          tauxx = mut*(two*u_x-fracdiv)
          tauyy = mut*(two*v_y-fracdiv)
          tauzz = mut*(two*w_z-fracdiv)
          tauxy = mut*(u_y+v_x)
          tauxz = mut*(u_z+w_x)
          tauyz = mut*(v_z+w_y)
          q_x = heatcoef*q_x
          q_y = heatcoef*q_y
          q_z = heatcoef*q_z
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
          ubar = half*(w(i, j, k, ivx)+w(i, j, k+1, ivx))
          vbar = half*(w(i, j, k, ivy)+w(i, j, k+1, ivy))
          wbar = half*(w(i, j, k, ivz)+w(i, j, k+1, ivz))
! compute the viscous fluxes for this j-face.
          fmx = tauxx*sk(i, j, k, 1) + tauxy*sk(i, j, k, 2) + tauxz*sk(i&
&           , j, k, 3)
          fmy = tauxy*sk(i, j, k, 1) + tauyy*sk(i, j, k, 2) + tauyz*sk(i&
&           , j, k, 3)
          fmz = tauxz*sk(i, j, k, 1) + tauyz*sk(i, j, k, 2) + tauzz*sk(i&
&           , j, k, 3)
          frhoe = (ubar*tauxx+vbar*tauxy+wbar*tauxz)*sk(i, j, k, 1) + (&
&           ubar*tauxy+vbar*tauyy+wbar*tauyz)*sk(i, j, k, 2) + (ubar*&
&           tauxz+vbar*tauyz+wbar*tauzz)*sk(i, j, k, 3) - q_x*sk(i, j, k&
&           , 1) - q_y*sk(i, j, k, 2) - q_z*sk(i, j, k, 3)
! update the residuals of cell j and j+1.
          fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
          fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
          fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
          fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
          fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fmx
          fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fmy
          fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fmz
          fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + frhoe
        end do
      end do
    end do
  end subroutine viscousfluxapprox
 
  subroutine invisciddissfluxscalarapprox()
!
!       invisciddissfluxscalar computes the scalar artificial
!       dissipation, see aiaa paper 81-1259, for a given block.
!       therefore it is assumed that the pointers in  blockpointers
!       already point to the correct block.
!
    use blockpointers
    use cgnsgrid
    use constants
    use flowvarrefstate
    use inputdiscretization
    use inputiteration, only : usedisscontinuation, disscontmagnitude, &
&   disscontmidpoint, disscontsharpness
    use inputphysics
    use iteration
    implicit none
!
!      local parameter.
!
    real(kind=realtype), parameter :: dssmax=0.25_realtype
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k, ind
    real(kind=realtype) :: sslim, rhoi
    real(kind=realtype) :: sfil, fis2, fis4
    real(kind=realtype) :: ppor, rrad, dis2
    real(kind=realtype) :: dss1, dss2, ddw, fs
    intrinsic abs
    intrinsic log10
    intrinsic exp
    intrinsic max
    intrinsic min
    real(kind=realtype) :: x1
    real(kind=realtype) :: x2
    real(kind=realtype) :: y1
    real(kind=realtype) :: x3
    real(kind=realtype) :: x4
    real(kind=realtype) :: y2
    real(kind=realtype) :: x5
    real(kind=realtype) :: x6
    real(kind=realtype) :: y3
    real(kind=realtype) :: abs0
    real(kind=realtype) :: min1
    real(kind=realtype) :: min2
    real(kind=realtype) :: min3
    if (rfil .ge. 0.) then
      abs0 = rfil
    else
      abs0 = -rfil
    end if
! check if rfil == 0. if so, the dissipative flux needs not to
! be computed.
    if (abs0 .lt. thresholdreal) then
      return
    else
! determine the variables used to compute the switch.
! for the inviscid case this is the pressure; for the viscous
! case it is the entropy.
      select case  (equations) 
      case (eulerequations) 
! inviscid case. pressure switch is based on the pressure.
! also set the value of sslim. to be fully consistent this
! must have the dimension of pressure and it is therefore
! set to a fraction of the free stream value.
        sslim = 0.001_realtype*pinfcorr
!===============================================================
      case (nsequations, ransequations) 
! viscous case. pressure switch is based on the entropy.
! also set the value of sslim. to be fully consistent this
! must have the dimension of entropy and it is therefore
! set to a fraction of the free stream value.
        sslim = 0.001_realtype*pinfcorr/rhoinf**gammainf
      end select
! set the dissipation constants for the scheme.
! rfil and sfil are fractions used by the runge-kutta solver to compute residuals at intermediate steps.
! this means that fis2 and fis4 will be some fraction of vis2 and vis4, respectively.
! for other solvers, rfil==1, sfil==0, fis2==vis2, and fis4==vis4.
! the sigmoid function used for dissipation-based continuation is described in eq. 28 and eq. 29 from the paper:
! "improving the performance of a compressible rans solver for low and high mach number flows" (seraj2022c).
! the options documentation also has information on the parameters in this formulation.
      if (usedisscontinuation) then
        fis2 = rfil*(vis2+disscontmagnitude/(1+exp(-(disscontsharpness*(&
&         log10(totalr/totalr0)+disscontmidpoint)))))
      else
        fis2 = rfil*vis2
      end if
      fis4 = rfil*vis4
      sfil = one - rfil
! replace the total energy by rho times the total enthalpy.
! in this way the numerical solution is total enthalpy preserving
! for the steady euler equations. also replace the velocities by
! the momentum. only done for the entries used in the
! discretization, i.e. ignore the corner halo's.
      do k=0,kb
        do j=2,jl
          do i=2,il
            w(i, j, k, ivx) = w(i, j, k, irho)*w(i, j, k, ivx)
            w(i, j, k, ivy) = w(i, j, k, irho)*w(i, j, k, ivy)
            w(i, j, k, ivz) = w(i, j, k, irho)*w(i, j, k, ivz)
            w(i, j, k, irhoe) = w(i, j, k, irhoe) + p(i, j, k)
          end do
        end do
      end do
      do k=2,kl
        do j=2,jl
          w(0, j, k, ivx) = w(0, j, k, irho)*w(0, j, k, ivx)
          w(0, j, k, ivy) = w(0, j, k, irho)*w(0, j, k, ivy)
          w(0, j, k, ivz) = w(0, j, k, irho)*w(0, j, k, ivz)
          w(0, j, k, irhoe) = w(0, j, k, irhoe) + p(0, j, k)
          w(1, j, k, ivx) = w(1, j, k, irho)*w(1, j, k, ivx)
          w(1, j, k, ivy) = w(1, j, k, irho)*w(1, j, k, ivy)
          w(1, j, k, ivz) = w(1, j, k, irho)*w(1, j, k, ivz)
          w(1, j, k, irhoe) = w(1, j, k, irhoe) + p(1, j, k)
          w(ie, j, k, ivx) = w(ie, j, k, irho)*w(ie, j, k, ivx)
          w(ie, j, k, ivy) = w(ie, j, k, irho)*w(ie, j, k, ivy)
          w(ie, j, k, ivz) = w(ie, j, k, irho)*w(ie, j, k, ivz)
          w(ie, j, k, irhoe) = w(ie, j, k, irhoe) + p(ie, j, k)
          w(ib, j, k, ivx) = w(ib, j, k, irho)*w(ib, j, k, ivx)
          w(ib, j, k, ivy) = w(ib, j, k, irho)*w(ib, j, k, ivy)
          w(ib, j, k, ivz) = w(ib, j, k, irho)*w(ib, j, k, ivz)
          w(ib, j, k, irhoe) = w(ib, j, k, irhoe) + p(ib, j, k)
        end do
      end do
      do k=2,kl
        do i=2,il
          w(i, 0, k, ivx) = w(i, 0, k, irho)*w(i, 0, k, ivx)
          w(i, 0, k, ivy) = w(i, 0, k, irho)*w(i, 0, k, ivy)
          w(i, 0, k, ivz) = w(i, 0, k, irho)*w(i, 0, k, ivz)
          w(i, 0, k, irhoe) = w(i, 0, k, irhoe) + p(i, 0, k)
          w(i, 1, k, ivx) = w(i, 1, k, irho)*w(i, 1, k, ivx)
          w(i, 1, k, ivy) = w(i, 1, k, irho)*w(i, 1, k, ivy)
          w(i, 1, k, ivz) = w(i, 1, k, irho)*w(i, 1, k, ivz)
          w(i, 1, k, irhoe) = w(i, 1, k, irhoe) + p(i, 1, k)
          w(i, je, k, ivx) = w(i, je, k, irho)*w(i, je, k, ivx)
          w(i, je, k, ivy) = w(i, je, k, irho)*w(i, je, k, ivy)
          w(i, je, k, ivz) = w(i, je, k, irho)*w(i, je, k, ivz)
          w(i, je, k, irhoe) = w(i, je, k, irhoe) + p(i, je, k)
          w(i, jb, k, ivx) = w(i, jb, k, irho)*w(i, jb, k, ivx)
          w(i, jb, k, ivy) = w(i, jb, k, irho)*w(i, jb, k, ivy)
          w(i, jb, k, ivz) = w(i, jb, k, irho)*w(i, jb, k, ivz)
          w(i, jb, k, irhoe) = w(i, jb, k, irhoe) + p(i, jb, k)
        end do
      end do
! initialize the dissipative residual to a certain times,
! possibly zero, the previously stored value. owned cells
! only, because the halo values do not matter.
      do k=2,kl
        do j=2,jl
          do i=2,il
            fw(i, j, k, irho) = sfil*fw(i, j, k, irho)
            fw(i, j, k, imx) = sfil*fw(i, j, k, imx)
            fw(i, j, k, imy) = sfil*fw(i, j, k, imy)
            fw(i, j, k, imz) = sfil*fw(i, j, k, imz)
            fw(i, j, k, irhoe) = sfil*fw(i, j, k, irhoe)
          end do
        end do
      end do
!
!       dissipative fluxes in the i-direction.
!
      do k=2,kl
        do j=2,jl
          x1 = (shocksensor(2, j, k)-two*shocksensor(1, j, k)+&
&           shocksensor(0, j, k))/(shocksensor(2, j, k)+two*shocksensor(&
&           1, j, k)+shocksensor(0, j, k)+sslim)
          if (x1 .ge. 0.) then
            dss1 = x1
          else
            dss1 = -x1
          end if
! loop in i-direction.
          do i=1,il
            x2 = (shocksensor(i+2, j, k)-two*shocksensor(i+1, j, k)+&
&             shocksensor(i, j, k))/(shocksensor(i+2, j, k)+two*&
&             shocksensor(i+1, j, k)+shocksensor(i, j, k)+sslim)
            if (x2 .ge. 0.) then
              dss2 = x2
            else
              dss2 = -x2
            end if
! compute the dissipation coefficients for this face.
            ppor = zero
            if (pori(i, j, k) .eq. normalflux) ppor = half
            rrad = ppor*(radi(i, j, k)+radi(i+1, j, k))
            if (dss1 .lt. dss2) then
              y1 = dss2
            else
              y1 = dss1
            end if
            if (dssmax .gt. y1) then
              min1 = y1
            else
              min1 = dssmax
            end if
! modification for fd preconditioner note: this lumping
! actually still results in a greater than 3 cell stencil
! in any direction. since this seems to work slightly
! better than the dis2=sigma*fis4*rrad, we will just use
! a 5-cell stencil for doing the pc
            dis2 = fis2*rrad*min1 + sigma*fis4*rrad
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
            ddw = w(i+1, j, k, irho) - w(i, j, k, irho)
            fs = dis2*ddw
            fw(i+1, j, k, irho) = fw(i+1, j, k, irho) + fs
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            ddw = w(i+1, j, k, ivx) - w(i, j, k, ivx)
            fs = dis2*ddw
            fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fs
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            ddw = w(i+1, j, k, ivy) - w(i, j, k, ivy)
            fs = dis2*ddw
            fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fs
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            ddw = w(i+1, j, k, ivz) - w(i, j, k, ivz)
            fs = dis2*ddw
            fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fs
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            ddw = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
            fs = dis2*ddw
            fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + fs
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dss1 to dss2 for the next face.
            dss1 = dss2
          end do
        end do
      end do
!
!       dissipative fluxes in the j-direction.
!
      do k=2,kl
        do i=2,il
          x3 = (shocksensor(i, 2, k)-two*shocksensor(i, 1, k)+&
&           shocksensor(i, 0, k))/(shocksensor(i, 2, k)+two*shocksensor(&
&           i, 1, k)+shocksensor(i, 0, k)+sslim)
          if (x3 .ge. 0.) then
            dss1 = x3
          else
            dss1 = -x3
          end if
! loop in j-direction.
          do j=1,jl
            x4 = (shocksensor(i, j+2, k)-two*shocksensor(i, j+1, k)+&
&             shocksensor(i, j, k))/(shocksensor(i, j+2, k)+two*&
&             shocksensor(i, j+1, k)+shocksensor(i, j, k)+sslim)
            if (x4 .ge. 0.) then
              dss2 = x4
            else
              dss2 = -x4
            end if
! compute the dissipation coefficients for this face.
            ppor = zero
            if (porj(i, j, k) .eq. normalflux) ppor = half
            rrad = ppor*(radj(i, j, k)+radj(i, j+1, k))
            if (dss1 .lt. dss2) then
              y2 = dss2
            else
              y2 = dss1
            end if
            if (dssmax .gt. y2) then
              min2 = y2
            else
              min2 = dssmax
            end if
! modification for fd preconditioner
            dis2 = fis2*rrad*min2 + sigma*fis4*rrad
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
            ddw = w(i, j+1, k, irho) - w(i, j, k, irho)
            fs = dis2*ddw
            fw(i, j+1, k, irho) = fw(i, j+1, k, irho) + fs
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            ddw = w(i, j+1, k, ivx) - w(i, j, k, ivx)
            fs = dis2*ddw
            fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fs
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            ddw = w(i, j+1, k, ivy) - w(i, j, k, ivy)
            fs = dis2*ddw
            fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fs
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            ddw = w(i, j+1, k, ivz) - w(i, j, k, ivz)
            fs = dis2*ddw
            fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fs
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            ddw = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
            fs = dis2*ddw
            fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + fs
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dss1 to dss2 for the next face.
            dss1 = dss2
          end do
        end do
      end do
!
!       dissipative fluxes in the k-direction.
!
      do j=2,jl
        do i=2,il
          x5 = (shocksensor(i, j, 2)-two*shocksensor(i, j, 1)+&
&           shocksensor(i, j, 0))/(shocksensor(i, j, 2)+two*shocksensor(&
&           i, j, 1)+shocksensor(i, j, 0)+sslim)
          if (x5 .ge. 0.) then
            dss1 = x5
          else
            dss1 = -x5
          end if
! loop in k-direction.
          do k=1,kl
            x6 = (shocksensor(i, j, k+2)-two*shocksensor(i, j, k+1)+&
&             shocksensor(i, j, k))/(shocksensor(i, j, k+2)+two*&
&             shocksensor(i, j, k+1)+shocksensor(i, j, k)+sslim)
            if (x6 .ge. 0.) then
              dss2 = x6
            else
              dss2 = -x6
            end if
! compute the dissipation coefficients for this face.
            ppor = zero
            if (pork(i, j, k) .eq. normalflux) ppor = half
            rrad = ppor*(radk(i, j, k)+radk(i, j, k+1))
            if (dss1 .lt. dss2) then
              y3 = dss2
            else
              y3 = dss1
            end if
            if (dssmax .gt. y3) then
              min3 = y3
            else
              min3 = dssmax
            end if
! modification for fd preconditioner
            dis2 = fis2*rrad*min3 + sigma*fis4*rrad
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
            ddw = w(i, j, k+1, irho) - w(i, j, k, irho)
            fs = dis2*ddw
            fw(i, j, k+1, irho) = fw(i, j, k+1, irho) + fs
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            ddw = w(i, j, k+1, ivx) - w(i, j, k, ivx)
            fs = dis2*ddw
            fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fs
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            ddw = w(i, j, k+1, ivy) - w(i, j, k, ivy)
            fs = dis2*ddw
            fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fs
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            ddw = w(i, j, k+1, ivz) - w(i, j, k, ivz)
            fs = dis2*ddw
            fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fs
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            ddw = w(i, j, k+1, irhoe) - w(i, j, k, irhoe)
            fs = dis2*ddw
            fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + fs
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dss1 to dss2 for the next face.
            dss1 = dss2
          end do
        end do
      end do
! replace rho times the total enthalpy by the total energy and
! store the velocities again instead of the momentum. only for
! those entries that have been altered, i.e. ignore the
! corner halo's.
      do k=0,kb
        do j=2,jl
          do i=2,il
            rhoi = one/w(i, j, k, irho)
            w(i, j, k, ivx) = w(i, j, k, ivx)*rhoi
            w(i, j, k, ivy) = w(i, j, k, ivy)*rhoi
            w(i, j, k, ivz) = w(i, j, k, ivz)*rhoi
            w(i, j, k, irhoe) = w(i, j, k, irhoe) - p(i, j, k)
          end do
        end do
      end do
      do k=2,kl
        do j=2,jl
          rhoi = one/w(0, j, k, irho)
          w(0, j, k, ivx) = w(0, j, k, ivx)*rhoi
          w(0, j, k, ivy) = w(0, j, k, ivy)*rhoi
          w(0, j, k, ivz) = w(0, j, k, ivz)*rhoi
          w(0, j, k, irhoe) = w(0, j, k, irhoe) - p(0, j, k)
          rhoi = one/w(1, j, k, irho)
          w(1, j, k, ivx) = w(1, j, k, ivx)*rhoi
          w(1, j, k, ivy) = w(1, j, k, ivy)*rhoi
          w(1, j, k, ivz) = w(1, j, k, ivz)*rhoi
          w(1, j, k, irhoe) = w(1, j, k, irhoe) - p(1, j, k)
          rhoi = one/w(ie, j, k, irho)
          w(ie, j, k, ivx) = w(ie, j, k, ivx)*rhoi
          w(ie, j, k, ivy) = w(ie, j, k, ivy)*rhoi
          w(ie, j, k, ivz) = w(ie, j, k, ivz)*rhoi
          w(ie, j, k, irhoe) = w(ie, j, k, irhoe) - p(ie, j, k)
          rhoi = one/w(ib, j, k, irho)
          w(ib, j, k, ivx) = w(ib, j, k, ivx)*rhoi
          w(ib, j, k, ivy) = w(ib, j, k, ivy)*rhoi
          w(ib, j, k, ivz) = w(ib, j, k, ivz)*rhoi
          w(ib, j, k, irhoe) = w(ib, j, k, irhoe) - p(ib, j, k)
        end do
      end do
      do k=2,kl
        do i=2,il
          rhoi = one/w(i, 0, k, irho)
          w(i, 0, k, ivx) = w(i, 0, k, ivx)*rhoi
          w(i, 0, k, ivy) = w(i, 0, k, ivy)*rhoi
          w(i, 0, k, ivz) = w(i, 0, k, ivz)*rhoi
          w(i, 0, k, irhoe) = w(i, 0, k, irhoe) - p(i, 0, k)
          rhoi = one/w(i, 1, k, irho)
          w(i, 1, k, ivx) = w(i, 1, k, ivx)*rhoi
          w(i, 1, k, ivy) = w(i, 1, k, ivy)*rhoi
          w(i, 1, k, ivz) = w(i, 1, k, ivz)*rhoi
          w(i, 1, k, irhoe) = w(i, 1, k, irhoe) - p(i, 1, k)
          rhoi = one/w(i, je, k, irho)
          w(i, je, k, ivx) = w(i, je, k, ivx)*rhoi
          w(i, je, k, ivy) = w(i, je, k, ivy)*rhoi
          w(i, je, k, ivz) = w(i, je, k, ivz)*rhoi
          w(i, je, k, irhoe) = w(i, je, k, irhoe) - p(i, je, k)
          rhoi = one/w(i, jb, k, irho)
          w(i, jb, k, ivx) = w(i, jb, k, ivx)*rhoi
          w(i, jb, k, ivy) = w(i, jb, k, ivy)*rhoi
          w(i, jb, k, ivz) = w(i, jb, k, ivz)*rhoi
          w(i, jb, k, irhoe) = w(i, jb, k, irhoe) - p(i, jb, k)
        end do
      end do
    end if
  end subroutine invisciddissfluxscalarapprox
 
  subroutine invisciddissfluxmatrixapprox()
!
!       invisciddissfluxmatrix computes the matrix artificial
!       dissipation term. instead of the spectral radius, as used in
!       the scalar dissipation scheme, the absolute value of the flux
!       jacobian is used. this leads to a less diffusive and
!       consequently more accurate scheme. it is assumed that the
!       pointers in blockpointers already point to the correct block.
!
    use blockpointers
    use cgnsgrid
    use constants
    use flowvarrefstate
    use inputdiscretization
    use inputphysics
    use iteration
    use utils_fast_b, only : getcorrectfork
    implicit none
!
!      local parameters.
!
    real(kind=realtype), parameter :: dpmax=0.25_realtype
    real(kind=realtype), parameter :: epsacoustic=0.25_realtype
    real(kind=realtype), parameter :: epsshear=0.025_realtype
    real(kind=realtype), parameter :: omega=0.5_realtype
    real(kind=realtype), parameter :: oneminomega=one-omega
!
!      local variables.
!
    integer(kind=inttype) :: i, j, k, ind
    real(kind=realtype) :: plim, sface
    real(kind=realtype) :: sfil, fis2, fis4
    real(kind=realtype) :: gammaavg, gm1, ovgm1, gm53
    real(kind=realtype) :: ppor, rrad, dis2
    real(kind=realtype) :: dp1, dp2, ddw, tmp, fs
    real(kind=realtype) :: dr, dru, drv, drw, dre, drk, sx, sy, sz
    real(kind=realtype) :: uavg, vavg, wavg, a2avg, aavg, havg
    real(kind=realtype) :: alphaavg, unavg, ovaavg, ova2avg
    real(kind=realtype) :: kavg, lam1, lam2, lam3, area
    real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
    logical :: correctfork
    intrinsic abs
    intrinsic max
    intrinsic min
    intrinsic sqrt
    real(kind=realtype) :: x1
    real(kind=realtype) :: x2
    real(kind=realtype) :: y1
    real(kind=realtype) :: x3
    real(kind=realtype) :: x4
    real(kind=realtype) :: y2
    real(kind=realtype) :: x5
    real(kind=realtype) :: x6
    real(kind=realtype) :: y3
    real(kind=realtype) :: abs0
    real(kind=realtype) :: min1
    real(realtype) :: max1
    real(kind=realtype) :: min2
    real(realtype) :: max2
    real(kind=realtype) :: min3
    real(realtype) :: max3
    real(kind=realtype) :: abs1
    real(kind=realtype) :: abs2
    real(kind=realtype) :: abs3
    real(kind=realtype) :: abs4
    real(kind=realtype) :: abs5
    real(kind=realtype) :: abs6
    real(kind=realtype) :: abs7
    real(kind=realtype) :: abs8
    real(kind=realtype) :: abs9
    real(kind=realtype) :: abs10
    real(kind=realtype) :: abs11
    real(kind=realtype) :: abs12
    if (rfil .ge. 0.) then
      abs0 = rfil
    else
      abs0 = -rfil
    end if
! check if rfil == 0. if so, the dissipative flux needs not to
! be computed.
    if (abs0 .lt. thresholdreal) then
      return
    else
! set the value of plim. to be fully consistent this must have
! the dimension of a pressure. therefore a fraction of pinfcorr
! is used.
      plim = 0.001_realtype*pinfcorr
! determine whether or not the total energy must be corrected
! for the presence of the turbulent kinetic energy.
      correctfork = getcorrectfork()
! initialize sface to zero. this value will be used if the
! block is not moving.
      sface = zero
! set a couple of constants for the scheme.
      fis2 = rfil*vis2
      fis4 = rfil*vis4
      sfil = one - rfil
! initialize the dissipative residual to a certain times,
! possibly zero, the previously stored value. owned cells
! only, because the halo values do not matter.
      do k=2,kl
        do j=2,jl
          do i=2,il
            fw(i, j, k, irho) = sfil*fw(i, j, k, irho)
            fw(i, j, k, imx) = sfil*fw(i, j, k, imx)
            fw(i, j, k, imy) = sfil*fw(i, j, k, imy)
            fw(i, j, k, imz) = sfil*fw(i, j, k, imz)
            fw(i, j, k, irhoe) = sfil*fw(i, j, k, irhoe)
          end do
        end do
      end do
!
!       dissipative fluxes in the i-direction.
!
      do k=2,kl
        do j=2,jl
          if (shocksensor(2, j, k) - shocksensor(1, j, k) .ge. 0.) then
            abs1 = shocksensor(2, j, k) - shocksensor(1, j, k)
          else
            abs1 = -(shocksensor(2, j, k)-shocksensor(1, j, k))
          end if
          if (shocksensor(1, j, k) - shocksensor(0, j, k) .ge. 0.) then
            abs7 = shocksensor(1, j, k) - shocksensor(0, j, k)
          else
            abs7 = -(shocksensor(1, j, k)-shocksensor(0, j, k))
          end if
          x1 = (shocksensor(2, j, k)-two*shocksensor(1, j, k)+&
&           shocksensor(0, j, k))/(omega*(shocksensor(2, j, k)+two*&
&           shocksensor(1, j, k)+shocksensor(0, j, k))+oneminomega*(abs1&
&           +abs7)+plim)
          if (x1 .ge. 0.) then
            dp1 = x1
          else
            dp1 = -x1
          end if
! loop in i-direction.
          do i=1,il
            if (shocksensor(i+2, j, k) - shocksensor(i+1, j, k) .ge. 0.&
&           ) then
              abs2 = shocksensor(i+2, j, k) - shocksensor(i+1, j, k)
            else
              abs2 = -(shocksensor(i+2, j, k)-shocksensor(i+1, j, k))
            end if
            if (shocksensor(i+1, j, k) - shocksensor(i, j, k) .ge. 0.) &
&           then
              abs8 = shocksensor(i+1, j, k) - shocksensor(i, j, k)
            else
              abs8 = -(shocksensor(i+1, j, k)-shocksensor(i, j, k))
            end if
            x2 = (shocksensor(i+2, j, k)-two*shocksensor(i+1, j, k)+&
&             shocksensor(i, j, k))/(omega*(shocksensor(i+2, j, k)+two*&
&             shocksensor(i+1, j, k)+shocksensor(i, j, k))+oneminomega*(&
&             abs2+abs8)+plim)
            if (x2 .ge. 0.) then
              dp2 = x2
            else
              dp2 = -x2
            end if
! compute the dissipation coefficients for this face.
            ppor = zero
            if (pori(i, j, k) .eq. normalflux) ppor = one
            if (dp1 .lt. dp2) then
              y1 = dp2
            else
              y1 = dp1
            end if
            if (dpmax .gt. y1) then
              min1 = y1
            else
              min1 = dpmax
            end if
            dis2 = fis2*ppor*min1 + sigma*fis4*ppor
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            ddw = w(i+1, j, k, irho) - w(i, j, k, irho)
            dr = dis2*ddw
            ddw = w(i+1, j, k, irho)*w(i+1, j, k, ivx) - w(i, j, k, irho&
&             )*w(i, j, k, ivx)
            dru = dis2*ddw
            ddw = w(i+1, j, k, irho)*w(i+1, j, k, ivy) - w(i, j, k, irho&
&             )*w(i, j, k, ivy)
            drv = dis2*ddw
            ddw = w(i+1, j, k, irho)*w(i+1, j, k, ivz) - w(i, j, k, irho&
&             )*w(i, j, k, ivz)
            drw = dis2*ddw
            ddw = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
            dre = dis2*ddw
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
            if (correctfork) then
              ddw = w(i+1, j, k, irho)*w(i+1, j, k, itu1) - w(i, j, k, &
&               irho)*w(i, j, k, itu1)
              drk = dis2*ddw
              kavg = half*(w(i, j, k, itu1)+w(i+1, j, k, itu1))
            else
              drk = zero
              kavg = zero
            end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
            gammaavg = half*(gamma(i+1, j, k)+gamma(i, j, k))
            gm1 = gammaavg - one
            ovgm1 = one/gm1
            gm53 = gammaavg - five*third
! compute the average state at the interface.
            uavg = half*(w(i+1, j, k, ivx)+w(i, j, k, ivx))
            vavg = half*(w(i+1, j, k, ivy)+w(i, j, k, ivy))
            wavg = half*(w(i+1, j, k, ivz)+w(i, j, k, ivz))
            a2avg = half*(gamma(i+1, j, k)*p(i+1, j, k)/w(i+1, j, k, &
&             irho)+gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
            sx = si(i, j, k, 1)
            sy = si(i, j, k, 2)
            sz = si(i, j, k, 3)
            area = sqrt(sx**2 + sy**2 + sz**2)
            if (1.e-25_realtype .lt. area) then
              max1 = area
            else
              max1 = 1.e-25_realtype
            end if
            tmp = one/max1
            sx = sx*tmp
            sy = sy*tmp
            sz = sz*tmp
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            aavg = sqrt(a2avg)
            unavg = uavg*sx + vavg*sy + wavg*sz
            ovaavg = one/aavg
            ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
            if (addgridvelocities) sface = sfacei(i, j, k)*tmp
            if (unavg - sface + aavg .ge. 0.) then
              lam1 = unavg - sface + aavg
            else
              lam1 = -(unavg-sface+aavg)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2 = unavg - sface - aavg
            else
              lam2 = -(unavg-sface-aavg)
            end if
            if (unavg - sface .ge. 0.) then
              lam3 = unavg - sface
            else
              lam3 = -(unavg-sface)
            end if
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              lam1 = epsacoustic*rrad
            else
              lam1 = lam1
            end if
            if (lam2 .lt. epsacoustic*rrad) then
              lam2 = epsacoustic*rrad
            else
              lam2 = lam2
            end if
            if (lam3 .lt. epsshear*rrad) then
              lam3 = epsshear*rrad
            else
              lam3 = lam3
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            lam1 = lam1*area
            lam2 = lam2*area
            lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1 = half*(lam1+lam2)
            abv2 = half*(lam1-lam2)
            abv3 = abv1 - lam3
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
            fs = lam3*dr + abv6
            fw(i+1, j, k, irho) = fw(i+1, j, k, irho) + fs
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            fs = lam3*dru + uavg*abv6 + sx*abv7
            fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fs
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            fs = lam3*drv + vavg*abv6 + sy*abv7
            fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fs
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            fs = lam3*drw + wavg*abv6 + sz*abv7
            fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fs
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            fs = lam3*dre + havg*abv6 + unavg*abv7
            fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + fs
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dp1 to dp2 for the next face.
            dp1 = dp2
          end do
        end do
      end do
!
!       dissipative fluxes in the j-direction.
!
      do k=2,kl
        do i=2,il
          if (shocksensor(i, 2, k) - shocksensor(i, 1, k) .ge. 0.) then
            abs3 = shocksensor(i, 2, k) - shocksensor(i, 1, k)
          else
            abs3 = -(shocksensor(i, 2, k)-shocksensor(i, 1, k))
          end if
          if (shocksensor(i, 1, k) - shocksensor(i, 0, k) .ge. 0.) then
            abs9 = shocksensor(i, 1, k) - shocksensor(i, 0, k)
          else
            abs9 = -(shocksensor(i, 1, k)-shocksensor(i, 0, k))
          end if
          x3 = (shocksensor(i, 2, k)-two*shocksensor(i, 1, k)+&
&           shocksensor(i, 0, k))/(omega*(shocksensor(i, 2, k)+two*&
&           shocksensor(i, 1, k)+shocksensor(i, 0, k))+oneminomega*(abs3&
&           +abs9)+plim)
          if (x3 .ge. 0.) then
            dp1 = x3
          else
            dp1 = -x3
          end if
! loop in j-direction.
          do j=1,jl
            if (shocksensor(i, j+2, k) - shocksensor(i, j+1, k) .ge. 0.&
&           ) then
              abs4 = shocksensor(i, j+2, k) - shocksensor(i, j+1, k)
            else
              abs4 = -(shocksensor(i, j+2, k)-shocksensor(i, j+1, k))
            end if
            if (shocksensor(i, j+1, k) - shocksensor(i, j, k) .ge. 0.) &
&           then
              abs10 = shocksensor(i, j+1, k) - shocksensor(i, j, k)
            else
              abs10 = -(shocksensor(i, j+1, k)-shocksensor(i, j, k))
            end if
            x4 = (shocksensor(i, j+2, k)-two*shocksensor(i, j+1, k)+&
&             shocksensor(i, j, k))/(omega*(shocksensor(i, j+2, k)+two*&
&             shocksensor(i, j+1, k)+shocksensor(i, j, k))+oneminomega*(&
&             abs4+abs10)+plim)
            if (x4 .ge. 0.) then
              dp2 = x4
            else
              dp2 = -x4
            end if
! compute the dissipation coefficients for this face.
            ppor = zero
            if (porj(i, j, k) .eq. normalflux) ppor = one
            if (dp1 .lt. dp2) then
              y2 = dp2
            else
              y2 = dp1
            end if
            if (dpmax .gt. y2) then
              min2 = y2
            else
              min2 = dpmax
            end if
            dis2 = fis2*ppor*min2 + sigma*fis4*ppor
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            ddw = w(i, j+1, k, irho) - w(i, j, k, irho)
            dr = dis2*ddw
            ddw = w(i, j+1, k, irho)*w(i, j+1, k, ivx) - w(i, j, k, irho&
&             )*w(i, j, k, ivx)
            dru = dis2*ddw
            ddw = w(i, j+1, k, irho)*w(i, j+1, k, ivy) - w(i, j, k, irho&
&             )*w(i, j, k, ivy)
            drv = dis2*ddw
            ddw = w(i, j+1, k, irho)*w(i, j+1, k, ivz) - w(i, j, k, irho&
&             )*w(i, j, k, ivz)
            drw = dis2*ddw
            ddw = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
            dre = dis2*ddw
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
            if (correctfork) then
              ddw = w(i, j+1, k, irho)*w(i, j+1, k, itu1) - w(i, j, k, &
&               irho)*w(i, j, k, itu1)
              drk = dis2*ddw
              kavg = half*(w(i, j, k, itu1)+w(i, j+1, k, itu1))
            else
              drk = zero
              kavg = zero
            end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
            gammaavg = half*(gamma(i, j+1, k)+gamma(i, j, k))
            gm1 = gammaavg - one
            ovgm1 = one/gm1
            gm53 = gammaavg - five*third
! compute the average state at the interface.
            uavg = half*(w(i, j+1, k, ivx)+w(i, j, k, ivx))
            vavg = half*(w(i, j+1, k, ivy)+w(i, j, k, ivy))
            wavg = half*(w(i, j+1, k, ivz)+w(i, j, k, ivz))
            a2avg = half*(gamma(i, j+1, k)*p(i, j+1, k)/w(i, j+1, k, &
&             irho)+gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
            sx = sj(i, j, k, 1)
            sy = sj(i, j, k, 2)
            sz = sj(i, j, k, 3)
            area = sqrt(sx**2 + sy**2 + sz**2)
            if (1.e-25_realtype .lt. area) then
              max2 = area
            else
              max2 = 1.e-25_realtype
            end if
            tmp = one/max2
            sx = sx*tmp
            sy = sy*tmp
            sz = sz*tmp
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            aavg = sqrt(a2avg)
            unavg = uavg*sx + vavg*sy + wavg*sz
            ovaavg = one/aavg
            ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
            if (addgridvelocities) sface = sfacej(i, j, k)*tmp
            if (unavg - sface + aavg .ge. 0.) then
              lam1 = unavg - sface + aavg
            else
              lam1 = -(unavg-sface+aavg)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2 = unavg - sface - aavg
            else
              lam2 = -(unavg-sface-aavg)
            end if
            if (unavg - sface .ge. 0.) then
              lam3 = unavg - sface
            else
              lam3 = -(unavg-sface)
            end if
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              lam1 = epsacoustic*rrad
            else
              lam1 = lam1
            end if
            if (lam2 .lt. epsacoustic*rrad) then
              lam2 = epsacoustic*rrad
            else
              lam2 = lam2
            end if
            if (lam3 .lt. epsshear*rrad) then
              lam3 = epsshear*rrad
            else
              lam3 = lam3
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            lam1 = lam1*area
            lam2 = lam2*area
            lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1 = half*(lam1+lam2)
            abv2 = half*(lam1-lam2)
            abv3 = abv1 - lam3
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
            fs = lam3*dr + abv6
            fw(i, j+1, k, irho) = fw(i, j+1, k, irho) + fs
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            fs = lam3*dru + uavg*abv6 + sx*abv7
            fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fs
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            fs = lam3*drv + vavg*abv6 + sy*abv7
            fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fs
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            fs = lam3*drw + wavg*abv6 + sz*abv7
            fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fs
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            fs = lam3*dre + havg*abv6 + unavg*abv7
            fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + fs
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dp1 to dp2 for the next face.
            dp1 = dp2
          end do
        end do
      end do
!
!       dissipative fluxes in the k-direction.
!
      do j=2,jl
        do i=2,il
          if (shocksensor(i, j, 2) - shocksensor(i, j, 1) .ge. 0.) then
            abs5 = shocksensor(i, j, 2) - shocksensor(i, j, 1)
          else
            abs5 = -(shocksensor(i, j, 2)-shocksensor(i, j, 1))
          end if
          if (shocksensor(i, j, 1) - shocksensor(i, j, 0) .ge. 0.) then
            abs11 = shocksensor(i, j, 1) - shocksensor(i, j, 0)
          else
            abs11 = -(shocksensor(i, j, 1)-shocksensor(i, j, 0))
          end if
          x5 = (shocksensor(i, j, 2)-two*shocksensor(i, j, 1)+&
&           shocksensor(i, j, 0))/(omega*(shocksensor(i, j, 2)+two*&
&           shocksensor(i, j, 1)+shocksensor(i, j, 0))+oneminomega*(abs5&
&           +abs11)+plim)
          if (x5 .ge. 0.) then
            dp1 = x5
          else
            dp1 = -x5
          end if
! loop in k-direction.
          do k=1,kl
            if (shocksensor(i, j, k+2) - shocksensor(i, j, k+1) .ge. 0.&
&           ) then
              abs6 = shocksensor(i, j, k+2) - shocksensor(i, j, k+1)
            else
              abs6 = -(shocksensor(i, j, k+2)-shocksensor(i, j, k+1))
            end if
            if (shocksensor(i, j, k+1) - shocksensor(i, j, k) .ge. 0.) &
&           then
              abs12 = shocksensor(i, j, k+1) - shocksensor(i, j, k)
            else
              abs12 = -(shocksensor(i, j, k+1)-shocksensor(i, j, k))
            end if
            x6 = (shocksensor(i, j, k+2)-two*shocksensor(i, j, k+1)+&
&             shocksensor(i, j, k))/(omega*(shocksensor(i, j, k+2)+two*&
&             shocksensor(i, j, k+1)+shocksensor(i, j, k))+oneminomega*(&
&             abs6+abs12)+plim)
            if (x6 .ge. 0.) then
              dp2 = x6
            else
              dp2 = -x6
            end if
! compute the dissipation coefficients for this face.
            ppor = zero
            if (pork(i, j, k) .eq. normalflux) ppor = one
            if (dp1 .lt. dp2) then
              y3 = dp2
            else
              y3 = dp1
            end if
            if (dpmax .gt. y3) then
              min3 = y3
            else
              min3 = dpmax
            end if
            dis2 = fis2*ppor*min3 + sigma*fis4*ppor
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            ddw = w(i, j, k+1, irho) - w(i, j, k, irho)
            dr = dis2*ddw
            ddw = w(i, j, k+1, irho)*w(i, j, k+1, ivx) - w(i, j, k, irho&
&             )*w(i, j, k, ivx)
            dru = dis2*ddw
            ddw = w(i, j, k+1, irho)*w(i, j, k+1, ivy) - w(i, j, k, irho&
&             )*w(i, j, k, ivy)
            drv = dis2*ddw
            ddw = w(i, j, k+1, irho)*w(i, j, k+1, ivz) - w(i, j, k, irho&
&             )*w(i, j, k, ivz)
            drw = dis2*ddw
            ddw = w(i, j, k+1, irhoe) - w(i, j, k, irhoe)
            dre = dis2*ddw
! in case a k-equation is present, compute the difference
! of rhok and store the average value of k. if not present,
! set both these values to zero, such that later on no
! decision needs to be made anymore.
            if (correctfork) then
              ddw = w(i, j, k+1, irho)*w(i, j, k+1, itu1) - w(i, j, k, &
&               irho)*w(i, j, k, itu1)
              drk = dis2*ddw
              kavg = half*(w(i, j, k+1, itu1)+w(i, j, k, itu1))
            else
              drk = zero
              kavg = zero
            end if
! compute the average value of gamma and compute some
! expressions in which it occurs.
            gammaavg = half*(gamma(i, j, k+1)+gamma(i, j, k))
            gm1 = gammaavg - one
            ovgm1 = one/gm1
            gm53 = gammaavg - five*third
! compute the average state at the interface.
            uavg = half*(w(i, j, k+1, ivx)+w(i, j, k, ivx))
            vavg = half*(w(i, j, k+1, ivy)+w(i, j, k, ivy))
            wavg = half*(w(i, j, k+1, ivz)+w(i, j, k, ivz))
            a2avg = half*(gamma(i, j, k+1)*p(i, j, k+1)/w(i, j, k+1, &
&             irho)+gamma(i, j, k)*p(i, j, k)/w(i, j, k, irho))
            sx = sk(i, j, k, 1)
            sy = sk(i, j, k, 2)
            sz = sk(i, j, k, 3)
            area = sqrt(sx**2 + sy**2 + sz**2)
            if (1.e-25_realtype .lt. area) then
              max3 = area
            else
              max3 = 1.e-25_realtype
            end if
            tmp = one/max3
            sx = sx*tmp
            sy = sy*tmp
            sz = sz*tmp
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            aavg = sqrt(a2avg)
            unavg = uavg*sx + vavg*sy + wavg*sz
            ovaavg = one/aavg
            ova2avg = one/a2avg
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
            if (addgridvelocities) sface = sfacek(i, j, k)*tmp
            if (unavg - sface + aavg .ge. 0.) then
              lam1 = unavg - sface + aavg
            else
              lam1 = -(unavg-sface+aavg)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2 = unavg - sface - aavg
            else
              lam2 = -(unavg-sface-aavg)
            end if
            if (unavg - sface .ge. 0.) then
              lam3 = unavg - sface
            else
              lam3 = -(unavg-sface)
            end if
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              lam1 = epsacoustic*rrad
            else
              lam1 = lam1
            end if
            if (lam2 .lt. epsacoustic*rrad) then
              lam2 = epsacoustic*rrad
            else
              lam2 = lam2
            end if
            if (lam3 .lt. epsshear*rrad) then
              lam3 = epsshear*rrad
            else
              lam3 = lam3
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            lam1 = lam1*area
            lam2 = lam2*area
            lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1 = half*(lam1+lam2)
            abv2 = half*(lam1-lam2)
            abv3 = abv1 - lam3
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
            fs = lam3*dr + abv6
            fw(i, j, k+1, irho) = fw(i, j, k+1, irho) + fs
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            fs = lam3*dru + uavg*abv6 + sx*abv7
            fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fs
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            fs = lam3*drv + vavg*abv6 + sy*abv7
            fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fs
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            fs = lam3*drw + wavg*abv6 + sz*abv7
            fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fs
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            fs = lam3*dre + havg*abv6 + unavg*abv7
            fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + fs
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dp1 to dp2 for the next face.
            dp1 = dp2
          end do
        end do
      end do
    end if
  end subroutine invisciddissfluxmatrixapprox
! ----------------------------------------------------------------------
!                                                                      |
!                    no tapenade routine below this line               |
!                                                                      |
! ----------------------------------------------------------------------
 
end module fluxes_fast_b