fluxes_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_b
  implicit none
 
contains
!  differentiation of inviscidcentralflux in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: timeref *p *sfacei *sfacej
!                *sfacek *w *dw *vol *si *sj *sk
!   with respect to varying inputs: timeref *p *sfacei *sfacej
!                *sfacek *w *dw *vol *si *sj *sk
!   rw status of diff variables: timeref:incr *p:incr *sfacei:incr
!                *sfacej:incr *sfacek:incr *w:incr *dw:in-out *vol:incr
!                *si:incr *sj:incr *sk:incr
!   plus diff mem management of: p:in sfacei:in sfacej:in sfacek:in
!                w:in dw:in vol:in si:in sj:in sk:in
  subroutine inviscidcentralflux_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, sid, sj, sjd, sk, skd, dw, dwd, pori, porj, &
&   pork, indfamilyi, indfamilyj, indfamilyk, p, pd, sfacei, sfaceid, &
&   sfacej, sfacejd, sfacek, sfacekd, nbkglobal, addgridvelocities, &
&   blockismoving, vol, vold, factfamilyi, factfamilyj, factfamilyk
    use cgnsgrid, only : cgnsdoms, massflowfamilyinv
    use flowvarrefstate, only : timeref, timerefd
    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, sfaced, vnpd, vnmd
    real(kind=realtype) :: wwx, wwy, wwz, rvol
    real(kind=realtype) :: wwxd, wwyd, wwzd, rvold
    intrinsic mod
    real(kind=realtype) :: temp
    real(kind=realtype) :: tempd
    integer :: branch
    real(kind=realtype) :: temp0
    real(kind=realtype) :: temp1
    real(kind=realtype) :: tempd0
    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)
      wwxd = 0.0_8
      wwyd = 0.0_8
      wwzd = 0.0_8
!$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)
        tempd0 = rvol*dwd(i, j, k, imx)
        temp = w(i, j, k, ivy)
        temp1 = w(i, j, k, ivx)
        temp0 = w(i, j, k, ivy)
        rvold = (wwx*temp0-wwy*temp1)*dwd(i, j, k, imz)
        tempd = rvol*dwd(i, j, k, imz)
        wwxd = wwxd + temp0*tempd
        wd(i, j, k, ivy) = wd(i, j, k, ivy) + wwx*tempd
        wwyd = wwyd - temp1*tempd
        wd(i, j, k, ivx) = wd(i, j, k, ivx) - wwy*tempd
        temp1 = w(i, j, k, ivz)
        temp0 = w(i, j, k, ivx)
        rvold = rvold + (wwz*temp0-wwx*temp1)*dwd(i, j, k, imy)
        tempd = rvol*dwd(i, j, k, imy)
        wwzd = wwzd + temp0*tempd - temp*tempd0
        wd(i, j, k, ivx) = wd(i, j, k, ivx) + wwz*tempd
        wwxd = wwxd - temp1*tempd
        wd(i, j, k, ivz) = wd(i, j, k, ivz) + wwy*tempd0 - wwx*tempd
        temp0 = w(i, j, k, ivz)
        rvold = rvold + (wwy*temp0-wwz*temp)*dwd(i, j, k, imx)
        wwyd = wwyd + temp0*tempd0
        wd(i, j, k, ivy) = wd(i, j, k, ivy) - wwz*tempd0
        wd(i, j, k, irho) = wd(i, j, k, irho) + vol(i, j, k)*rvold
        vold(i, j, k) = vold(i, j, k) + w(i, j, k, irho)*rvold
      end do
      timerefd = timerefd + cgnsdoms(nbkglobal)%rotrate(3)*wwzd + &
&       cgnsdoms(nbkglobal)%rotrate(2)*wwyd + cgnsdoms(nbkglobal)%&
&       rotrate(1)*wwxd
    end if
    sfaced = 0.0_8
    sface = zero
    sfaced = 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 dot product of the grid velocity and the
! normal in k-direction for a moving face.
      if (addgridvelocities) then
        sface = sfacek(i, j, k)
        call pushcontrol1b(0)
      else
        call pushcontrol1b(1)
      end if
! 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
        call pushcontrol1b(0)
      else
        call pushcontrol1b(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.
      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.
      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
      skd(i, j, k, 3) = skd(i, j, k, 3) + pa*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
      skd(i, j, k, 2) = skd(i, j, k, 2) + pa*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
      skd(i, j, k, 1) = skd(i, j, k, 1) + pa*fsd
      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
      sfaced = sfaced - porvel*qsmd - porvel*qspd
      call popcontrol1b(branch)
      if (branch .eq. 0) then
        sfaced = sfaced + vnmd + vnpd
        vnmd = 0.0_8
        vnpd = 0.0_8
      end if
      skd(i, j, k, 3) = skd(i, j, k, 3) + w(i, j, k, ivz)*vnmd + w(i, j&
&       , k+1, ivz)*vnpd
      skd(i, j, k, 2) = skd(i, j, k, 2) + w(i, j, k, ivy)*vnmd + w(i, j&
&       , k+1, ivy)*vnpd
      wd(i, j, k, ivx) = wd(i, j, k, ivx) + sk(i, j, k, 1)*vnmd
      skd(i, j, k, 1) = skd(i, j, k, 1) + w(i, j, k, ivx)*vnmd + w(i, j&
&       , k+1, ivx)*vnpd
      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
      call popcontrol1b(branch)
      if (branch .eq. 0) then
        sfacekd(i, j, k) = sfacekd(i, j, k) + sfaced
        sfaced = 0.0_8
      end if
    end do
    sfaced = 0.0_8
    sface = zero
    sfaced = 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 dot product of the grid velocity and the
! normal in j-direction for a moving face.
      if (addgridvelocities) then
        sface = sfacej(i, j, k)
        call pushcontrol1b(0)
      else
        call pushcontrol1b(1)
      end if
! 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
        call pushcontrol1b(0)
      else
        call pushcontrol1b(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.
      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.
      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
      sjd(i, j, k, 3) = sjd(i, j, k, 3) + pa*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
      sjd(i, j, k, 2) = sjd(i, j, k, 2) + pa*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
      sjd(i, j, k, 1) = sjd(i, j, k, 1) + pa*fsd
      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
      sfaced = sfaced - porvel*qsmd - porvel*qspd
      call popcontrol1b(branch)
      if (branch .eq. 0) then
        sfaced = sfaced + vnmd + vnpd
        vnmd = 0.0_8
        vnpd = 0.0_8
      end if
      sjd(i, j, k, 3) = sjd(i, j, k, 3) + w(i, j, k, ivz)*vnmd + w(i, j+&
&       1, k, ivz)*vnpd
      sjd(i, j, k, 2) = sjd(i, j, k, 2) + w(i, j, k, ivy)*vnmd + w(i, j+&
&       1, k, ivy)*vnpd
      wd(i, j, k, ivx) = wd(i, j, k, ivx) + sj(i, j, k, 1)*vnmd
      sjd(i, j, k, 1) = sjd(i, j, k, 1) + w(i, j, k, ivx)*vnmd + w(i, j+&
&       1, k, ivx)*vnpd
      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
      call popcontrol1b(branch)
      if (branch .eq. 0) then
        sfacejd(i, j, k) = sfacejd(i, j, k) + sfaced
        sfaced = 0.0_8
      end if
    end do
    sfaced = 0.0_8
! initialize sface to zero. this value will be used if the
! block is not moving.
    sface = zero
    sfaced = 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 dot product of the grid velocity and the
! normal in i-direction for a moving face.
      if (addgridvelocities) then
        sface = sfacei(i, j, k)
        call pushcontrol1b(0)
      else
        call pushcontrol1b(1)
      end if
! 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
        call pushcontrol1b(0)
      else
        call pushcontrol1b(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.
      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.
      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
      sid(i, j, k, 3) = sid(i, j, k, 3) + pa*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
      sid(i, j, k, 2) = sid(i, j, k, 2) + pa*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
      sid(i, j, k, 1) = sid(i, j, k, 1) + pa*fsd
      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
      sfaced = sfaced - porvel*qsmd - porvel*qspd
      call popcontrol1b(branch)
      if (branch .eq. 0) then
        sfaced = sfaced + vnmd + vnpd
        vnmd = 0.0_8
        vnpd = 0.0_8
      end if
      sid(i, j, k, 3) = sid(i, j, k, 3) + w(i, j, k, ivz)*vnmd + w(i+1, &
&       j, k, ivz)*vnpd
      sid(i, j, k, 2) = sid(i, j, k, 2) + w(i, j, k, ivy)*vnmd + w(i+1, &
&       j, k, ivy)*vnpd
      wd(i, j, k, ivx) = wd(i, j, k, ivx) + si(i, j, k, 1)*vnmd
      sid(i, j, k, 1) = sid(i, j, k, 1) + w(i, j, k, ivx)*vnmd + w(i+1, &
&       j, k, ivx)*vnpd
      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
      call popcontrol1b(branch)
      if (branch .eq. 0) then
        sfaceid(i, j, k) = sfaceid(i, j, k) + sfaced
        sfaced = 0.0_8
      end if
    end do
  end subroutine inviscidcentralflux_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: pinfcorr *p *sfacei *sfacej
!                *sfacek *w *si *sj *sk *fw
!   with respect to varying inputs: pinfcorr *p *sfacei *sfacej
!                *sfacek *w *si *sj *sk *fw
!   rw status of diff variables: pinfcorr:incr *p:incr *sfacei:incr
!                *sfacej:incr *sfacek:incr *w:incr *si:incr *sj:incr
!                *sk:incr *fw:in-out
!   plus diff mem management of: p:in sfacei:in sfacej:in sfacek:in
!                w:in si:in sj:in sk:in fw:in
  subroutine invisciddissfluxmatrix_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, sid, sj,&
&   sjd, sk, skd, indfamilyi, indfamilyj, indfamilyk, spectralsol, &
&   addgridvelocities, sfacei, sfaceid, sfacej, sfacejd, sfacek, sfacekd&
&   , factfamilyi, factfamilyj, factfamilyk
    use flowvarrefstate, only : pinfcorr, pinfcorrd
    use inputdiscretization, only : vis2, vis4
    use inputphysics, only : equations
    use iteration, only : rfil
    use cgnsgrid, only : massflowfamilydiss
    use utils_b, only : getcorrectfork, mydim, mydim_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) :: plimd, sfaced
    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) :: tmpd, 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, sxd, syd, &
&   szd
    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, aread
    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(realtype) :: max1d
    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(realtype) :: max5d
    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(realtype) :: max9d
    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
      call pushreal8(sface)
!$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
      call pushreal8(sface)
!$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
      sfaced = 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)
          call pushcontrol1b(0)
        else
          y3 = dss(i, j, k, 3)
          call pushcontrol1b(1)
        end if
        if (dpmax .gt. y3) then
          min3 = y3
          call pushcontrol1b(0)
        else
          min3 = dpmax
          call pushcontrol1b(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))
          call pushcontrol1b(1)
        else
          drk = zero
          kavg = zero
          call pushcontrol1b(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
          call pushcontrol1b(0)
        else
          call pushcontrol1b(1)
          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) then
          sface = sfacek(i, j, k)*tmp
          call pushcontrol1b(1)
        else
          call pushcontrol1b(0)
        end if
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
          call pushcontrol1b(0)
        else
          lam1 = -(unavg-sface+aavg)
          call pushcontrol1b(1)
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
          call pushcontrol1b(0)
        else
          lam2 = -(unavg-sface-aavg)
          call pushcontrol1b(1)
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
          call pushcontrol1b(0)
        else
          lam3 = -(unavg-sface)
          call pushcontrol1b(1)
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max10 = epsacoustic*rrad
          call pushcontrol1b(0)
        else
          max10 = lam1
          call pushcontrol1b(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
          call pushcontrol1b(0)
        else
          max11 = lam2
          call pushcontrol1b(1)
        end if
        lam2 = max11*area
        if (lam3 .lt. epsshear*rrad) then
          max12 = epsshear*rrad
          call pushcontrol1b(0)
        else
          max12 = lam3
          call pushcontrol1b(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
        szd = abv7*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
        syd = abv7*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
        sxd = abv7*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
        sxd = sxd + dru*abv5d
        syd = syd + drv*abv5d
        szd = szd + drw*abv5d
        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
        aread = max12*lam3d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          rradd = epsshear*max12d
          lam3d = 0.0_8
        else
          lam3d = max12d
          rradd = 0.0_8
        end if
        max11d = area*lam2d
        aread = aread + max11*lam2d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max11d
          lam2d = 0.0_8
        else
          lam2d = max11d
        end if
        max10d = area*lam1d
        aread = aread + max10*lam1d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max10d
          lam1d = 0.0_8
        else
          lam1d = max10d
        end if
        lam3d = lam3d + rradd
        aavgd = rradd
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          unavgd = unavgd + lam3d
          sfaced = sfaced - lam3d
        else
          sfaced = sfaced + lam3d
          unavgd = unavgd - lam3d
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          unavgd = unavgd + lam2d
          sfaced = sfaced - lam2d
          aavgd = aavgd - lam2d
        else
          sfaced = sfaced + lam2d
          unavgd = unavgd - lam2d
          aavgd = aavgd + lam2d
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          unavgd = unavgd + lam1d
          sfaced = sfaced - lam1d
          aavgd = aavgd + lam1d
        else
          sfaced = sfaced + lam1d
          unavgd = unavgd - lam1d
          aavgd = aavgd - lam1d
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          tmpd = 0.0_8
        else
          sfacekd(i, j, k) = sfacekd(i, j, k) + tmp*sfaced
          tmpd = sfacek(i, j, k)*sfaced
          sfaced = 0.0_8
        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
        sxd = sxd + uavg*unavgd
        vavgd = vavgd + sy*unavgd + 2*vavg*tempd2
        syd = syd + vavg*unavgd
        wavgd = wavgd + sz*unavgd + 2*wavg*tempd2
        szd = szd + wavg*unavgd
        kavgd = -(gm53*ovgm1*havgd)
        skd(i, j, k, 3) = skd(i, j, k, 3) + tmp*szd
        tmpd = tmpd + sk(i, j, k, 3)*szd + sk(i, j, k, 2)*syd + sk(i, j&
&         , k, 1)*sxd
        skd(i, j, k, 2) = skd(i, j, k, 2) + tmp*syd
        skd(i, j, k, 1) = skd(i, j, k, 1) + tmp*sxd
        max9d = -(one*tmpd/max9**2)
        call popcontrol1b(branch)
        if (branch .eq. 0) aread = aread + max9d
        temp3 = sk(i, j, k, 3)
        temp2 = sk(i, j, k, 2)
        temp1 = sk(i, j, k, 1)
        if (temp1**2 + temp2**2 + temp3**2 .eq. 0.0_8) then
          tempd = 0.0_8
        else
          tempd = aread/(2.0*sqrt(temp1**2+temp2**2+temp3**2))
        end if
        skd(i, j, k, 1) = skd(i, j, k, 1) + 2*temp1*tempd
        skd(i, j, k, 2) = skd(i, j, k, 2) + 2*temp2*tempd
        skd(i, j, k, 3) = skd(i, j, k, 3) + 2*temp3*tempd
        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
        call popcontrol1b(branch)
        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
        arg1d = 0.0_8
        call mydim_b(arg1, arg1d, dis2, dis2d, dis4d)
        min3d = ppor*fis2*dis2d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          y3d = min3d
        else
          y3d = 0.0_8
        end if
        call popcontrol1b(branch)
        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
      call popreal8(sface)
!$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)
          call pushcontrol1b(0)
        else
          y2 = dss(i, j, k, 2)
          call pushcontrol1b(1)
        end if
        if (dpmax .gt. y2) then
          min2 = y2
          call pushcontrol1b(0)
        else
          min2 = dpmax
          call pushcontrol1b(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))
          call pushcontrol1b(1)
        else
          drk = zero
          kavg = zero
          call pushcontrol1b(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
          call pushcontrol1b(0)
        else
          call pushcontrol1b(1)
          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) then
          sface = sfacej(i, j, k)*tmp
          call pushcontrol1b(1)
        else
          call pushcontrol1b(0)
        end if
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
          call pushcontrol1b(0)
        else
          lam1 = -(unavg-sface+aavg)
          call pushcontrol1b(1)
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
          call pushcontrol1b(0)
        else
          lam2 = -(unavg-sface-aavg)
          call pushcontrol1b(1)
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
          call pushcontrol1b(0)
        else
          lam3 = -(unavg-sface)
          call pushcontrol1b(1)
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max6 = epsacoustic*rrad
          call pushcontrol1b(0)
        else
          max6 = lam1
          call pushcontrol1b(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
          call pushcontrol1b(0)
        else
          max7 = lam2
          call pushcontrol1b(1)
        end if
        lam2 = max7*area
        if (lam3 .lt. epsshear*rrad) then
          max8 = epsshear*rrad
          call pushcontrol1b(0)
        else
          max8 = lam3
          call pushcontrol1b(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
        szd = abv7*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
        syd = abv7*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
        sxd = abv7*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
        sxd = sxd + dru*abv5d
        syd = syd + drv*abv5d
        szd = szd + drw*abv5d
        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
        aread = max8*lam3d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          rradd = epsshear*max8d
          lam3d = 0.0_8
        else
          lam3d = max8d
          rradd = 0.0_8
        end if
        max7d = area*lam2d
        aread = aread + max7*lam2d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max7d
          lam2d = 0.0_8
        else
          lam2d = max7d
        end if
        max6d = area*lam1d
        aread = aread + max6*lam1d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max6d
          lam1d = 0.0_8
        else
          lam1d = max6d
        end if
        lam3d = lam3d + rradd
        aavgd = rradd
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          unavgd = unavgd + lam3d
          sfaced = sfaced - lam3d
        else
          sfaced = sfaced + lam3d
          unavgd = unavgd - lam3d
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          unavgd = unavgd + lam2d
          sfaced = sfaced - lam2d
          aavgd = aavgd - lam2d
        else
          sfaced = sfaced + lam2d
          unavgd = unavgd - lam2d
          aavgd = aavgd + lam2d
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          unavgd = unavgd + lam1d
          sfaced = sfaced - lam1d
          aavgd = aavgd + lam1d
        else
          sfaced = sfaced + lam1d
          unavgd = unavgd - lam1d
          aavgd = aavgd - lam1d
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          tmpd = 0.0_8
        else
          sfacejd(i, j, k) = sfacejd(i, j, k) + tmp*sfaced
          tmpd = sfacej(i, j, k)*sfaced
          sfaced = 0.0_8
        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
        sxd = sxd + uavg*unavgd
        vavgd = vavgd + sy*unavgd + 2*vavg*tempd2
        syd = syd + vavg*unavgd
        wavgd = wavgd + sz*unavgd + 2*wavg*tempd2
        szd = szd + wavg*unavgd
        kavgd = -(gm53*ovgm1*havgd)
        sjd(i, j, k, 3) = sjd(i, j, k, 3) + tmp*szd
        tmpd = tmpd + sj(i, j, k, 3)*szd + sj(i, j, k, 2)*syd + sj(i, j&
&         , k, 1)*sxd
        sjd(i, j, k, 2) = sjd(i, j, k, 2) + tmp*syd
        sjd(i, j, k, 1) = sjd(i, j, k, 1) + tmp*sxd
        max5d = -(one*tmpd/max5**2)
        call popcontrol1b(branch)
        if (branch .eq. 0) aread = aread + max5d
        temp3 = sj(i, j, k, 3)
        temp2 = sj(i, j, k, 2)
        temp1 = sj(i, j, k, 1)
        if (temp1**2 + temp2**2 + temp3**2 .eq. 0.0_8) then
          tempd = 0.0_8
        else
          tempd = aread/(2.0*sqrt(temp1**2+temp2**2+temp3**2))
        end if
        sjd(i, j, k, 1) = sjd(i, j, k, 1) + 2*temp1*tempd
        sjd(i, j, k, 2) = sjd(i, j, k, 2) + 2*temp2*tempd
        sjd(i, j, k, 3) = sjd(i, j, k, 3) + 2*temp3*tempd
        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
        call popcontrol1b(branch)
        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
        arg1d = 0.0_8
        call mydim_b(arg1, arg1d, dis2, dis2d, dis4d)
        min2d = ppor*fis2*dis2d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          y2d = min2d
        else
          y2d = 0.0_8
        end if
        call popcontrol1b(branch)
        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
      call popreal8(sface)
!$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)
          call pushcontrol1b(0)
        else
          y1 = dss(i, j, k, 1)
          call pushcontrol1b(1)
        end if
        if (dpmax .gt. y1) then
          min1 = y1
          call pushcontrol1b(0)
        else
          min1 = dpmax
          call pushcontrol1b(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))
          call pushcontrol1b(1)
        else
          drk = zero
          kavg = zero
          call pushcontrol1b(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
          call pushcontrol1b(0)
        else
          call pushcontrol1b(1)
          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) then
          sface = sfacei(i, j, k)*tmp
          call pushcontrol1b(1)
        else
          call pushcontrol1b(0)
        end if
        if (unavg - sface + aavg .ge. 0.) then
          lam1 = unavg - sface + aavg
          call pushcontrol1b(0)
        else
          lam1 = -(unavg-sface+aavg)
          call pushcontrol1b(1)
        end if
        if (unavg - sface - aavg .ge. 0.) then
          lam2 = unavg - sface - aavg
          call pushcontrol1b(0)
        else
          lam2 = -(unavg-sface-aavg)
          call pushcontrol1b(1)
        end if
        if (unavg - sface .ge. 0.) then
          lam3 = unavg - sface
          call pushcontrol1b(0)
        else
          lam3 = -(unavg-sface)
          call pushcontrol1b(1)
        end if
        rrad = lam3 + aavg
        if (lam1 .lt. epsacoustic*rrad) then
          max2 = epsacoustic*rrad
          call pushcontrol1b(0)
        else
          max2 = lam1
          call pushcontrol1b(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
          call pushcontrol1b(0)
        else
          max3 = lam2
          call pushcontrol1b(1)
        end if
        lam2 = max3*area
        if (lam3 .lt. epsshear*rrad) then
          max4 = epsshear*rrad
          call pushcontrol1b(0)
        else
          max4 = lam3
          call pushcontrol1b(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
        szd = abv7*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
        syd = abv7*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
        sxd = abv7*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
        sxd = sxd + dru*abv5d
        syd = syd + drv*abv5d
        szd = szd + drw*abv5d
        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
        aread = max4*lam3d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          rradd = epsshear*max4d
          lam3d = 0.0_8
        else
          lam3d = max4d
          rradd = 0.0_8
        end if
        max3d = area*lam2d
        aread = aread + max3*lam2d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max3d
          lam2d = 0.0_8
        else
          lam2d = max3d
        end if
        max2d = area*lam1d
        aread = aread + max2*lam1d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          rradd = rradd + epsacoustic*max2d
          lam1d = 0.0_8
        else
          lam1d = max2d
        end if
        lam3d = lam3d + rradd
        aavgd = rradd
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          unavgd = unavgd + lam3d
          sfaced = sfaced - lam3d
        else
          sfaced = sfaced + lam3d
          unavgd = unavgd - lam3d
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          unavgd = unavgd + lam2d
          sfaced = sfaced - lam2d
          aavgd = aavgd - lam2d
        else
          sfaced = sfaced + lam2d
          unavgd = unavgd - lam2d
          aavgd = aavgd + lam2d
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          unavgd = unavgd + lam1d
          sfaced = sfaced - lam1d
          aavgd = aavgd + lam1d
        else
          sfaced = sfaced + lam1d
          unavgd = unavgd - lam1d
          aavgd = aavgd - lam1d
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          tmpd = 0.0_8
        else
          sfaceid(i, j, k) = sfaceid(i, j, k) + tmp*sfaced
          tmpd = sfacei(i, j, k)*sfaced
          sfaced = 0.0_8
        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
        sxd = sxd + uavg*unavgd
        vavgd = vavgd + sy*unavgd + 2*vavg*tempd2
        syd = syd + vavg*unavgd
        wavgd = wavgd + sz*unavgd + 2*wavg*tempd2
        szd = szd + wavg*unavgd
        kavgd = -(gm53*ovgm1*havgd)
        sid(i, j, k, 3) = sid(i, j, k, 3) + tmp*szd
        tmpd = tmpd + si(i, j, k, 3)*szd + si(i, j, k, 2)*syd + si(i, j&
&         , k, 1)*sxd
        sid(i, j, k, 2) = sid(i, j, k, 2) + tmp*syd
        sid(i, j, k, 1) = sid(i, j, k, 1) + tmp*sxd
        max1d = -(one*tmpd/max1**2)
        call popcontrol1b(branch)
        if (branch .eq. 0) aread = aread + max1d
        temp3 = si(i, j, k, 3)
        temp2 = si(i, j, k, 2)
        temp1 = si(i, j, k, 1)
        if (temp1**2 + temp2**2 + temp3**2 .eq. 0.0_8) then
          tempd = 0.0_8
        else
          tempd = aread/(2.0*sqrt(temp1**2+temp2**2+temp3**2))
        end if
        sid(i, j, k, 1) = sid(i, j, k, 1) + 2*temp1*tempd
        sid(i, j, k, 2) = sid(i, j, k, 2) + 2*temp2*tempd
        sid(i, j, k, 3) = sid(i, j, k, 3) + 2*temp3*tempd
        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
        call popcontrol1b(branch)
        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
        arg1d = 0.0_8
        call mydim_b(arg1, arg1d, dis2, dis2d, dis4d)
        min1d = ppor*fis2*dis2d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          y1d = min1d
        else
          y1d = 0.0_8
        end if
        call popcontrol1b(branch)
        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
      plimd = 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
        if (p(i+1, j, k) - p(i, j, k) .ge. 0.) then
          abs1 = p(i+1, j, k) - p(i, j, k)
          call pushcontrol1b(1)
        else
          abs1 = -(p(i+1, j, k)-p(i, j, k))
          call pushcontrol1b(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)
          call pushcontrol1b(0)
        else
          abs4 = -(p(i, j, k)-p(i-1, j, k))
          call pushcontrol1b(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
          call pushcontrol1b(0)
        else
          call pushcontrol1b(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)
          call pushcontrol1b(1)
        else
          abs2 = -(p(i, j+1, k)-p(i, j, k))
          call pushcontrol1b(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)
          call pushcontrol1b(0)
        else
          abs5 = -(p(i, j, k)-p(i, j-1, k))
          call pushcontrol1b(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
          call pushcontrol1b(0)
        else
          call pushcontrol1b(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)
          call pushcontrol1b(1)
        else
          abs3 = -(p(i, j, k+1)-p(i, j, k))
          call pushcontrol1b(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)
          call pushcontrol1b(0)
        else
          abs6 = -(p(i, j, k)-p(i, j, k-1))
          call pushcontrol1b(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 = omega*(p(i, j, k+1)+two*p(i, j, k)+p(i, j, k-1)) + &
&         oneminomega*(abs3+abs6) + plim
        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
        plimd = plimd + tempd1
        call popcontrol1b(branch)
        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
        call popcontrol1b(branch)
        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
        call popcontrol1b(branch)
        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 = omega*(p(i, j+1, k)+two*p(i, j, k)+p(i, j-1, k)) + &
&         oneminomega*(abs2+abs5) + plim
        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
        plimd = plimd + tempd1
        call popcontrol1b(branch)
        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
        call popcontrol1b(branch)
        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
        call popcontrol1b(branch)
        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 = omega*(p(i+1, j, k)+two*p(i, j, k)+p(i-1, j, k)) + &
&         oneminomega*(abs1+abs4) + plim
        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
        plimd = plimd + tempd0
        call popcontrol1b(branch)
        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
        call popcontrol1b(branch)
        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
      pinfcorrd = pinfcorrd + 0.001_realtype*plimd
    end if
  end subroutine invisciddissfluxmatrix_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_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: rhoinf pinfcorr *p *w *fw *radi
!                *radj *radk
!   with respect to varying inputs: rhoinf pinfcorr *p *w *fw *radi
!                *radj *radk
!   rw status of diff variables: rhoinf:incr pinfcorr:incr *p:incr
!                *w:incr *fw:in-out *radi:incr *radj:incr *radk:incr
!   plus diff mem management of: p:in w:in fw:in radi:in radj:in
!                radk:in
  subroutine invisciddissfluxscalar_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, pinfcorrd, rhoinf,&
&   rhoinfd
    use inputdiscretization, only : vis2, vis4
    use inputiteration, only : usedisscontinuation, disscontmagnitude, &
&   disscontmidpoint, disscontsharpness
    use inputphysics, only : equations
    use iteration, only : rfil, totalr0, totalr
    use utils_b, only : mydim, mydim_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) :: sslimd
    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) :: tempd
    real(kind=realtype) :: temp1
    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 .ge. thresholdreal) then
! 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
          call pushcontrol1b(0)
          fis2 = rfil*(vis2+disscontmagnitude/(1+exp(-(disscontsharpness&
&           *disscontmidpoint))))
        else
          call pushcontrol1b(0)
          fis2 = rfil*(vis2+disscontmagnitude/(1+exp(-(disscontsharpness&
&           *(log10(totalr/totalr0)+disscontmidpoint)))))
        end if
      else
        call pushcontrol1b(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.
      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)
          call pushcontrol1b(0)
        else
          y3 = dss(i, j, k, 3)
          call pushcontrol1b(1)
        end if
        if (dssmax .gt. y3) then
          min3 = y3
          call pushcontrol1b(0)
        else
          min3 = dssmax
          call pushcontrol1b(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
        arg1d = 0.0_8
        call mydim_b(arg1, arg1d, dis2, dis2d, dis4d)
        rradd = fis4*arg1d + min3*fis2*dis2d
        min3d = rrad*fis2*dis2d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          y3d = min3d
        else
          y3d = 0.0_8
        end if
        call popcontrol1b(branch)
        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
!$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)
          call pushcontrol1b(0)
        else
          y2 = dss(i, j, k, 2)
          call pushcontrol1b(1)
        end if
        if (dssmax .gt. y2) then
          min2 = y2
          call pushcontrol1b(0)
        else
          min2 = dssmax
          call pushcontrol1b(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
        arg1d = 0.0_8
        call mydim_b(arg1, arg1d, dis2, dis2d, dis4d)
        rradd = fis4*arg1d + min2*fis2*dis2d
        min2d = rrad*fis2*dis2d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          y2d = min2d
        else
          y2d = 0.0_8
        end if
        call popcontrol1b(branch)
        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
!$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)
          call pushcontrol1b(0)
        else
          y1 = dss(i, j, k, 1)
          call pushcontrol1b(1)
        end if
        if (dssmax .gt. y1) then
          min1 = y1
          call pushcontrol1b(0)
        else
          min1 = dssmax
          call pushcontrol1b(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
        arg1d = 0.0_8
        call mydim_b(arg1, arg1d, dis2, dis2d, dis4d)
        rradd = fis4*arg1d + min1*fis2*dis2d
        min1d = rrad*fis2*dis2d
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          y1d = min1d
        else
          y1d = 0.0_8
        end if
        call popcontrol1b(branch)
        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
      call popcontrol1b(branch)
      sslimd = 0.0_8
      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
          call pushcontrol1b(0)
        else
          call pushcontrol1b(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
          call pushcontrol1b(0)
        else
          call pushcontrol1b(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 = ss(i, j, k+1) + two*ss(i, j, k) + ss(i, j, k-1) + sslim
        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
        sslimd = sslimd + tempd0
        call popcontrol1b(branch)
        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 = ss(i, j+1, k) + two*ss(i, j, k) + ss(i, j-1, k) + sslim
        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
        sslimd = sslimd + tempd0
        call popcontrol1b(branch)
        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 = ss(i+1, j, k) + two*ss(i, j, k) + ss(i-1, j, k) + sslim
        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
        sslimd = sslimd + tempd0
      end do
      call popcontrol2b(branch)
      if (branch .ne. 0) then
        if (branch .eq. 1) then
          pd = pd + ssd
          pinfcorrd = pinfcorrd + 0.001_realtype*sslimd
        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))
            temp0 = gamma(i, j, k)
            temp = w(i, j, k, irho)
            temp1 = temp**temp0
            pd(i, j, k) = pd(i, j, k) + ssd(i, j, k)/temp1
            if (.not.(temp .le. 0.0_8 .and. (temp0 .eq. 0.0_8 .or. temp0&
&               .ne. int(temp0)))) wd(i, j, k, irho) = wd(i, j, k, irho)&
&               - temp0*temp**(temp0-1)*p(i, j, k)*ssd(i, j, k)/temp1**2
            ssd(i, j, k) = 0.0_8
          end do
          temp = rhoinf**gammainf
          tempd = 0.001_realtype*sslimd/temp
          pinfcorrd = pinfcorrd + tempd
          if (.not.(rhoinf .le. 0.0_8 .and. (gammainf .eq. 0.0_8 .or. &
&             gammainf .ne. int(gammainf)))) rhoinfd = rhoinfd - &
&             gammainf*rhoinf**(gammainf-1)*pinfcorr*tempd/temp
        end if
      end if
    end if
  end subroutine invisciddissfluxscalar_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_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 *sfacei *sfacej *sfacek
!                *w *si *sj *sk *fw
!   with respect to varying inputs: *p *sfacei *sfacej *sfacek
!                *w *si *sj *sk *fw
!   rw status of diff variables: *p:incr *sfacei:incr *sfacej:incr
!                *sfacek:incr *w:incr *si:incr *sj:incr *sk:incr
!                *fw:in-out
!   plus diff mem management of: p:in sfacei:in sfacej:in sfacek:in
!                w:in si:in sj:in sk:in fw:in
  subroutine inviscidupwindflux_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, sid, sj, sjd, sk, &
&   skd, indfamilyi, indfamilyj, indfamilyk, spectralsol, &
&   addgridvelocities, sfacei, sfaceid, sfacej, sfacejd, sfacek, sfacekd&
&   , rotmatrixi, rotmatrixj, rotmatrixk, factfamilyi, factfamilyj, &
&   factfamilyk
    use flowvarrefstate, only : kpresent, nw, nwf, rgas, rgasd, tref, &
&   trefd
    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_b, only : getcorrectfork, terminate
    use flowutils_b, only : etot, etot_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) :: sxd, syd, szd
    real(kind=realtype) :: factminmod, sface
    real(kind=realtype) :: sfaced
    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
          call pushcontrol1b(0)
          nwint = nwf
          firstorderk = .true.
        else
          call pushcontrol1b(0)
          nwint = itu1
          firstorderk = .false.
        end if
      else
        call pushcontrol1b(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.
              call pushreal8(sx)
              sx = si(i, j, k, 1)
              call pushreal8(sy)
              sy = si(i, j, k, 2)
              call pushreal8(sz)
              sz = si(i, j, k, 3)
              if (addgridvelocities) then
                call pushreal8(sface)
                sface = sfacei(i, j, k)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
! determine the left and right state.
              call pushreal8(left(irho))
              left(irho) = w(i, j, k, irho)
              call pushreal8(left(ivx))
              left(ivx) = w(i, j, k, ivx)
              call pushreal8(left(ivy))
              left(ivy) = w(i, j, k, ivy)
              call pushreal8(left(ivz))
              left(ivz) = w(i, j, k, ivz)
              call pushreal8(left(irhoe))
              left(irhoe) = p(i, j, k)
              if (correctfork) then
                call pushreal8(left(itu1))
                left(itu1) = w(i, j, k, itu1)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
              call pushreal8(right(irho))
              right(irho) = w(i+1, j, k, irho)
              call pushreal8(right(ivx))
              right(ivx) = w(i+1, j, k, ivx)
              call pushreal8(right(ivy))
              right(ivy) = w(i+1, j, k, ivy)
              call pushreal8(right(ivz))
              right(ivz) = w(i+1, j, k, ivz)
              call pushreal8(right(irhoe))
              right(irhoe) = p(i+1, j, k)
              if (correctfork) then
                call pushreal8(right(itu1))
                right(itu1) = w(i+1, j, k, itu1)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(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.
              call pushreal8(sx)
              sx = sj(i, j, k, 1)
              call pushreal8(sy)
              sy = sj(i, j, k, 2)
              call pushreal8(sz)
              sz = sj(i, j, k, 3)
              if (addgridvelocities) then
                call pushreal8(sface)
                sface = sfacej(i, j, k)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
! determine the left and right state.
              call pushreal8(left(irho))
              left(irho) = w(i, j, k, irho)
              call pushreal8(left(ivx))
              left(ivx) = w(i, j, k, ivx)
              call pushreal8(left(ivy))
              left(ivy) = w(i, j, k, ivy)
              call pushreal8(left(ivz))
              left(ivz) = w(i, j, k, ivz)
              call pushreal8(left(irhoe))
              left(irhoe) = p(i, j, k)
              if (correctfork) then
                call pushreal8(left(itu1))
                left(itu1) = w(i, j, k, itu1)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
              call pushreal8(right(irho))
              right(irho) = w(i, j+1, k, irho)
              call pushreal8(right(ivx))
              right(ivx) = w(i, j+1, k, ivx)
              call pushreal8(right(ivy))
              right(ivy) = w(i, j+1, k, ivy)
              call pushreal8(right(ivz))
              right(ivz) = w(i, j+1, k, ivz)
              call pushreal8(right(irhoe))
              right(irhoe) = p(i, j+1, k)
              if (correctfork) then
                call pushreal8(right(itu1))
                right(itu1) = w(i, j+1, k, itu1)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(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.
              call pushreal8(sx)
              sx = sk(i, j, k, 1)
              call pushreal8(sy)
              sy = sk(i, j, k, 2)
              call pushreal8(sz)
              sz = sk(i, j, k, 3)
              if (addgridvelocities) then
                call pushreal8(sface)
                sface = sfacek(i, j, k)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
! determine the left and right state.
              call pushreal8(left(irho))
              left(irho) = w(i, j, k, irho)
              call pushreal8(left(ivx))
              left(ivx) = w(i, j, k, ivx)
              call pushreal8(left(ivy))
              left(ivy) = w(i, j, k, ivy)
              call pushreal8(left(ivz))
              left(ivz) = w(i, j, k, ivz)
              call pushreal8(left(irhoe))
              left(irhoe) = p(i, j, k)
              if (correctfork) then
                call pushreal8(left(itu1))
                left(itu1) = w(i, j, k, itu1)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
              call pushreal8(right(irho))
              right(irho) = w(i, j, k+1, irho)
              call pushreal8(right(ivx))
              right(ivx) = w(i, j, k+1, ivx)
              call pushreal8(right(ivy))
              right(ivy) = w(i, j, k+1, ivy)
              call pushreal8(right(ivz))
              right(ivz) = w(i, j, k+1, ivz)
              call pushreal8(right(irhoe))
              right(irhoe) = p(i, j, k+1)
              if (correctfork) then
                call pushreal8(right(itu1))
                right(itu1) = w(i, j, k+1, itu1)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
            end do
          end do
        end do
        fluxd = 0.0_8
        leftd = 0.0_8
        rightd = 0.0_8
        sfaced = 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_b(left, leftd, right, rightd, flux, fluxd&
&                         )
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(right(itu1))
                wd(i, j, k+1, itu1) = wd(i, j, k+1, itu1) + rightd(itu1)
                rightd(itu1) = 0.0_8
              end if
              call popreal8(right(irhoe))
              pd(i, j, k+1) = pd(i, j, k+1) + rightd(irhoe)
              rightd(irhoe) = 0.0_8
              call popreal8(right(ivz))
              wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + rightd(ivz)
              rightd(ivz) = 0.0_8
              call popreal8(right(ivy))
              wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + rightd(ivy)
              rightd(ivy) = 0.0_8
              call popreal8(right(ivx))
              wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + rightd(ivx)
              rightd(ivx) = 0.0_8
              call popreal8(right(irho))
              wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + rightd(irho)
              rightd(irho) = 0.0_8
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(left(itu1))
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + leftd(itu1)
                leftd(itu1) = 0.0_8
              end if
              call popreal8(left(irhoe))
              pd(i, j, k) = pd(i, j, k) + leftd(irhoe)
              leftd(irhoe) = 0.0_8
              call popreal8(left(ivz))
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + leftd(ivz)
              leftd(ivz) = 0.0_8
              call popreal8(left(ivy))
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + leftd(ivy)
              leftd(ivy) = 0.0_8
              call popreal8(left(ivx))
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + leftd(ivx)
              leftd(ivx) = 0.0_8
              call popreal8(left(irho))
              wd(i, j, k, irho) = wd(i, j, k, irho) + leftd(irho)
              leftd(irho) = 0.0_8
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(sface)
                sfacekd(i, j, k) = sfacekd(i, j, k) + sfaced
                sfaced = 0.0_8
              end if
              call popreal8(sz)
              skd(i, j, k, 3) = skd(i, j, k, 3) + szd
              call popreal8(sy)
              skd(i, j, k, 2) = skd(i, j, k, 2) + syd
              call popreal8(sx)
              skd(i, j, k, 1) = skd(i, j, k, 1) + sxd
            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_b(left, leftd, right, rightd, flux, fluxd&
&                         )
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(right(itu1))
                wd(i, j+1, k, itu1) = wd(i, j+1, k, itu1) + rightd(itu1)
                rightd(itu1) = 0.0_8
              end if
              call popreal8(right(irhoe))
              pd(i, j+1, k) = pd(i, j+1, k) + rightd(irhoe)
              rightd(irhoe) = 0.0_8
              call popreal8(right(ivz))
              wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + rightd(ivz)
              rightd(ivz) = 0.0_8
              call popreal8(right(ivy))
              wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + rightd(ivy)
              rightd(ivy) = 0.0_8
              call popreal8(right(ivx))
              wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + rightd(ivx)
              rightd(ivx) = 0.0_8
              call popreal8(right(irho))
              wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + rightd(irho)
              rightd(irho) = 0.0_8
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(left(itu1))
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + leftd(itu1)
                leftd(itu1) = 0.0_8
              end if
              call popreal8(left(irhoe))
              pd(i, j, k) = pd(i, j, k) + leftd(irhoe)
              leftd(irhoe) = 0.0_8
              call popreal8(left(ivz))
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + leftd(ivz)
              leftd(ivz) = 0.0_8
              call popreal8(left(ivy))
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + leftd(ivy)
              leftd(ivy) = 0.0_8
              call popreal8(left(ivx))
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + leftd(ivx)
              leftd(ivx) = 0.0_8
              call popreal8(left(irho))
              wd(i, j, k, irho) = wd(i, j, k, irho) + leftd(irho)
              leftd(irho) = 0.0_8
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(sface)
                sfacejd(i, j, k) = sfacejd(i, j, k) + sfaced
                sfaced = 0.0_8
              end if
              call popreal8(sz)
              sjd(i, j, k, 3) = sjd(i, j, k, 3) + szd
              call popreal8(sy)
              sjd(i, j, k, 2) = sjd(i, j, k, 2) + syd
              call popreal8(sx)
              sjd(i, j, k, 1) = sjd(i, j, k, 1) + sxd
            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_b(left, leftd, right, rightd, flux, fluxd&
&                         )
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(right(itu1))
                wd(i+1, j, k, itu1) = wd(i+1, j, k, itu1) + rightd(itu1)
                rightd(itu1) = 0.0_8
              end if
              call popreal8(right(irhoe))
              pd(i+1, j, k) = pd(i+1, j, k) + rightd(irhoe)
              rightd(irhoe) = 0.0_8
              call popreal8(right(ivz))
              wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + rightd(ivz)
              rightd(ivz) = 0.0_8
              call popreal8(right(ivy))
              wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + rightd(ivy)
              rightd(ivy) = 0.0_8
              call popreal8(right(ivx))
              wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + rightd(ivx)
              rightd(ivx) = 0.0_8
              call popreal8(right(irho))
              wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + rightd(irho)
              rightd(irho) = 0.0_8
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(left(itu1))
                wd(i, j, k, itu1) = wd(i, j, k, itu1) + leftd(itu1)
                leftd(itu1) = 0.0_8
              end if
              call popreal8(left(irhoe))
              pd(i, j, k) = pd(i, j, k) + leftd(irhoe)
              leftd(irhoe) = 0.0_8
              call popreal8(left(ivz))
              wd(i, j, k, ivz) = wd(i, j, k, ivz) + leftd(ivz)
              leftd(ivz) = 0.0_8
              call popreal8(left(ivy))
              wd(i, j, k, ivy) = wd(i, j, k, ivy) + leftd(ivy)
              leftd(ivy) = 0.0_8
              call popreal8(left(ivx))
              wd(i, j, k, ivx) = wd(i, j, k, ivx) + leftd(ivx)
              leftd(ivx) = 0.0_8
              call popreal8(left(irho))
              wd(i, j, k, irho) = wd(i, j, k, irho) + leftd(irho)
              leftd(irho) = 0.0_8
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(sface)
                sfaceid(i, j, k) = sfaceid(i, j, k) + sfaced
                sfaced = 0.0_8
              end if
              call popreal8(sz)
              sid(i, j, k, 3) = sid(i, j, k, 3) + szd
              call popreal8(sy)
              sid(i, j, k, 2) = sid(i, j, k, 2) + syd
              call popreal8(sx)
              sid(i, j, k, 1) = sid(i, j, k, 1) + sxd
            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)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
! compute the differences from the first order scheme.
              call pushreal8array(right, nw)
              call pushreal8array(left, nw)
              call pushreal8array(du3, nw)
              call pushreal8array(du2, nw)
              call pushreal8array(du1, nw)
              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)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
! store the normal vector, the porosity and the
! mesh velocity if present.
              call pushreal8(sx)
              sx = si(i, j, k, 1)
              call pushreal8(sy)
              sy = si(i, j, k, 2)
              call pushreal8(sz)
              sz = si(i, j, k, 3)
              if (addgridvelocities) then
                call pushreal8(sface)
                sface = sfacei(i, j, k)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(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)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
! compute the differences from the first order scheme.
              call pushreal8array(right, nw)
              call pushreal8array(left, nw)
              call pushreal8array(du3, nw)
              call pushreal8array(du2, nw)
              call pushreal8array(du1, nw)
              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)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
! store the normal vector, the porosity and the
! mesh velocity if present.
              call pushreal8(sx)
              sx = sj(i, j, k, 1)
              call pushreal8(sy)
              sy = sj(i, j, k, 2)
              call pushreal8(sz)
              sz = sj(i, j, k, 3)
              if (addgridvelocities) then
                call pushreal8(sface)
                sface = sfacej(i, j, k)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(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)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
! compute the differences from the first order scheme.
              call pushreal8array(right, nw)
              call pushreal8array(left, nw)
              call pushreal8array(du3, nw)
              call pushreal8array(du2, nw)
              call pushreal8array(du1, nw)
              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)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(1)
              end if
! store the normal vector, the porosity and the
! mesh velocity if present.
              call pushreal8(sx)
              sx = sk(i, j, k, 1)
              call pushreal8(sy)
              sy = sk(i, j, k, 2)
              call pushreal8(sz)
              sz = sk(i, j, k, 3)
              if (addgridvelocities) then
                call pushreal8(sface)
                sface = sfacek(i, j, k)
                call pushcontrol1b(0)
              else
                call pushcontrol1b(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
        sfaced = 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_b(left, leftd, right, rightd, flux, fluxd&
&                         )
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(sface)
                sfacekd(i, j, k) = sfacekd(i, j, k) + sfaced
                sfaced = 0.0_8
              end if
              call popreal8(sz)
              skd(i, j, k, 3) = skd(i, j, k, 3) + szd
              call popreal8(sy)
              skd(i, j, k, 2) = skd(i, j, k, 2) + syd
              call popreal8(sx)
              skd(i, j, k, 1) = skd(i, j, k, 1) + sxd
              call popcontrol1b(branch)
              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 popreal8array(du1, nw)
              call popreal8array(du2, nw)
              call popreal8array(du3, nw)
              call popreal8array(left, nw)
              call popreal8array(right, nw)
              call leftrightstate_b(du1, du1d, du2, du2d, du3, du3d, &
&                             rotmatrixk, left, leftd, right, rightd)
              call popcontrol1b(branch)
              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_b(left, leftd, right, rightd, flux, fluxd&
&                         )
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(sface)
                sfacejd(i, j, k) = sfacejd(i, j, k) + sfaced
                sfaced = 0.0_8
              end if
              call popreal8(sz)
              sjd(i, j, k, 3) = sjd(i, j, k, 3) + szd
              call popreal8(sy)
              sjd(i, j, k, 2) = sjd(i, j, k, 2) + syd
              call popreal8(sx)
              sjd(i, j, k, 1) = sjd(i, j, k, 1) + sxd
              call popcontrol1b(branch)
              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 popreal8array(du1, nw)
              call popreal8array(du2, nw)
              call popreal8array(du3, nw)
              call popreal8array(left, nw)
              call popreal8array(right, nw)
              call leftrightstate_b(du1, du1d, du2, du2d, du3, du3d, &
&                             rotmatrixj, left, leftd, right, rightd)
              call popcontrol1b(branch)
              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_b(left, leftd, right, rightd, flux, fluxd&
&                         )
              call popcontrol1b(branch)
              if (branch .eq. 0) then
                call popreal8(sface)
                sfaceid(i, j, k) = sfaceid(i, j, k) + sfaced
                sfaced = 0.0_8
              end if
              call popreal8(sz)
              sid(i, j, k, 3) = sid(i, j, k, 3) + szd
              call popreal8(sy)
              sid(i, j, k, 2) = sid(i, j, k, 2) + syd
              call popreal8(sx)
              sid(i, j, k, 1) = sid(i, j, k, 1) + sxd
              call popcontrol1b(branch)
              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 popreal8array(du1, nw)
              call popreal8array(du2, nw)
              call popreal8array(du3, nw)
              call popreal8array(left, nw)
              call popreal8array(right, nw)
              call leftrightstate_b(du1, du1d, du2, du2d, du3, du3d, &
&                             rotmatrixi, left, leftd, right, rightd)
              call popcontrol1b(branch)
              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
      call popcontrol1b(branch)
      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_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
        call pushcontrol1b(0)
      else
        call pushcontrol1b(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)
            call pushcontrol1b(0)
          else
            x1 = -du2(l)
            call pushcontrol1b(1)
          end if
          if (x1 .lt. epslim) then
            call pushreal8(max2)
            max2 = epslim
            call pushcontrol1b(0)
          else
            call pushreal8(max2)
            max2 = x1
            call pushcontrol1b(1)
          end if
! compute the limiter argument rl1, rl2, rr1 and rr2.
! note the cut off to 0.0.
          call pushreal8(tmp)
          tmp = one/sign(max2, du2(l))
          if (du1(l) .ge. 0.) then
            x3 = du1(l)
            call pushcontrol1b(0)
          else
            x3 = -du1(l)
            call pushcontrol1b(1)
          end if
          if (x3 .lt. epslim) then
            call pushreal8(max4)
            max4 = epslim
            call pushcontrol1b(0)
          else
            call pushreal8(max4)
            max4 = x3
            call pushcontrol1b(1)
          end if
          y1 = du2(l)/sign(max4, du1(l))
          if (zero .lt. y1) then
            call pushreal8(rl1)
            rl1 = y1
            call pushcontrol1b(0)
          else
            call pushreal8(rl1)
            rl1 = zero
            call pushcontrol1b(1)
          end if
          if (zero .lt. du1(l)*tmp) then
            call pushreal8(rl2)
            rl2 = du1(l)*tmp
            call pushcontrol1b(0)
          else
            call pushreal8(rl2)
            rl2 = zero
            call pushcontrol1b(1)
          end if
          if (zero .lt. du3(l)*tmp) then
            call pushreal8(rr1)
            rr1 = du3(l)*tmp
            call pushcontrol1b(0)
          else
            call pushreal8(rr1)
            rr1 = zero
            call pushcontrol1b(1)
          end if
          if (du3(l) .ge. 0.) then
            x4 = du3(l)
            call pushcontrol1b(0)
          else
            x4 = -du3(l)
            call pushcontrol1b(1)
          end if
          if (x4 .lt. epslim) then
            call pushreal8(max5)
            max5 = epslim
            call pushcontrol1b(0)
          else
            call pushreal8(max5)
            max5 = x4
            call pushcontrol1b(1)
          end if
          y2 = du2(l)/sign(max5, du3(l))
          if (zero .lt. y2) then
            call pushreal8(rr2)
            rr2 = y2
            call pushcontrol1b(0)
          else
            call pushreal8(rr2)
            rr2 = zero
            call pushcontrol1b(1)
          end if
! compute the corresponding limiter values.
          call pushreal8(rl1)
          rl1 = rl1*(rl1+one)/(rl1*rl1+one)
          call pushreal8(rl2)
          rl2 = rl2*(rl2+one)/(rl2*rl2+one)
          call pushreal8(rr1)
          rr1 = rr1*(rr1+one)/(rr1*rr1+one)
          call pushreal8(rr2)
          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)
            call pushcontrol1b(0)
          else
            x2 = -du2(l)
            call pushcontrol1b(1)
          end if
          if (x2 .lt. epslim) then
            call pushreal8(max3)
            max3 = epslim
            call pushcontrol1b(0)
          else
            call pushreal8(max3)
            max3 = x2
            call pushcontrol1b(1)
          end if
! compute the limiter argument rl1, rl2, rr1 and rr2.
! note the cut off to 0.0.
          call pushreal8(tmp)
          tmp = one/sign(max3, du2(l))
          if (du1(l) .ge. 0.) then
            x5 = du1(l)
            call pushcontrol1b(0)
          else
            x5 = -du1(l)
            call pushcontrol1b(1)
          end if
          if (x5 .lt. epslim) then
            call pushreal8(max6)
            max6 = epslim
            call pushcontrol1b(0)
          else
            call pushreal8(max6)
            max6 = x5
            call pushcontrol1b(1)
          end if
          y3 = du2(l)/sign(max6, du1(l))
          if (zero .lt. y3) then
            call pushreal8(rl1)
            rl1 = y3
            call pushcontrol1b(0)
          else
            call pushreal8(rl1)
            rl1 = zero
            call pushcontrol1b(1)
          end if
          if (zero .lt. du1(l)*tmp) then
            call pushreal8(rl2)
            rl2 = du1(l)*tmp
            call pushcontrol1b(0)
          else
            call pushreal8(rl2)
            rl2 = zero
            call pushcontrol1b(1)
          end if
          if (zero .lt. du3(l)*tmp) then
            call pushreal8(rr1)
            rr1 = du3(l)*tmp
            call pushcontrol1b(0)
          else
            call pushreal8(rr1)
            rr1 = zero
            call pushcontrol1b(1)
          end if
          if (du3(l) .ge. 0.) then
            x6 = du3(l)
            call pushcontrol1b(0)
          else
            x6 = -du3(l)
            call pushcontrol1b(1)
          end if
          if (x6 .lt. epslim) then
            call pushreal8(max7)
            max7 = epslim
            call pushcontrol1b(0)
          else
            call pushreal8(max7)
            max7 = x6
            call pushcontrol1b(1)
          end if
          y4 = du2(l)/sign(max7, du3(l))
          if (zero .lt. y4) then
            call pushreal8(rr2)
            rr2 = y4
            call pushcontrol1b(0)
          else
            call pushreal8(rr2)
            rr2 = zero
            call pushcontrol1b(1)
          end if
          if (one .gt. factminmod*rl1) then
            rl1 = factminmod*rl1
            call pushcontrol1b(0)
          else
            rl1 = one
            call pushcontrol1b(1)
          end if
          if (one .gt. factminmod*rl2) then
            rl2 = factminmod*rl2
            call pushcontrol1b(0)
          else
            rl2 = one
            call pushcontrol1b(1)
          end if
          if (one .gt. factminmod*rr1) then
            rr1 = factminmod*rr1
            call pushcontrol1b(0)
          else
            rr1 = one
            call pushcontrol1b(1)
          end if
          if (one .gt. factminmod*rr2) then
            rr2 = factminmod*rr2
            call pushcontrol1b(0)
          else
            rr2 = one
            call pushcontrol1b(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
        call pushcontrol1b(0)
      else
        call pushcontrol1b(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
      call popcontrol1b(branch)
      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
          call popreal8(rr2)
          tempd = rr2d/(one+rr2**2)
          rr2d = (one+2*rr2-2*rr2**2*(one+rr2)/(one+rr2**2))*tempd
          call popreal8(rr1)
          tempd = rr1d/(one+rr1**2)
          rr1d = (one+2*rr1-2*rr1**2*(one+rr1)/(one+rr1**2))*tempd
          call popreal8(rl2)
          tempd = rl2d/(one+rl2**2)
          rl2d = (one+2*rl2-2*rl2**2*(one+rl2)/(one+rl2**2))*tempd
          call popreal8(rl1)
          tempd = rl1d/(one+rl1**2)
          rl1d = (one+2*rl1-2*rl1**2*(one+rl1)/(one+rl1**2))*tempd
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(rr2)
            y2d = rr2d
          else
            call popreal8(rr2)
            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
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(max5)
            x4d = 0.0_8
          else
            call popreal8(max5)
            x4d = max5d
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            du3d(l) = du3d(l) + x4d
          else
            du3d(l) = du3d(l) - x4d
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(rr1)
            du3d(l) = du3d(l) + tmp*rr1d
            tmpd = du3(l)*rr1d
          else
            call popreal8(rr1)
            tmpd = 0.0_8
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(rl2)
            du1d(l) = du1d(l) + tmp*rl2d
            tmpd = tmpd + du1(l)*rl2d
          else
            call popreal8(rl2)
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(rl1)
            y1d = rl1d
          else
            call popreal8(rl1)
            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
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(max4)
            x3d = 0.0_8
          else
            call popreal8(max4)
            x3d = max4d
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            du1d(l) = du1d(l) + x3d
          else
            du1d(l) = du1d(l) - x3d
          end if
          call popreal8(tmp)
          temp = sign(max2, du2(l))
          tempd = -(one*tmpd/temp**2)
          max2d = sign(1.d0, max2*du2(l))*tempd
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(max2)
            x1d = 0.0_8
          else
            call popreal8(max2)
            x1d = max2d
          end if
          call popcontrol1b(branch)
          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
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            rr2d = factminmod*rr2d
          else
            rr2d = 0.0_8
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            rr1d = factminmod*rr1d
          else
            rr1d = 0.0_8
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            rl2d = factminmod*rl2d
          else
            rl2d = 0.0_8
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            rl1d = factminmod*rl1d
          else
            rl1d = 0.0_8
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(rr2)
            y4d = rr2d
          else
            call popreal8(rr2)
            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
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(max7)
            x6d = 0.0_8
          else
            call popreal8(max7)
            x6d = max7d
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            du3d(l) = du3d(l) + x6d
          else
            du3d(l) = du3d(l) - x6d
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(rr1)
            du3d(l) = du3d(l) + tmp*rr1d
            tmpd = du3(l)*rr1d
          else
            call popreal8(rr1)
            tmpd = 0.0_8
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(rl2)
            du1d(l) = du1d(l) + tmp*rl2d
            tmpd = tmpd + du1(l)*rl2d
          else
            call popreal8(rl2)
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(rl1)
            y3d = rl1d
          else
            call popreal8(rl1)
            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
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(max6)
            x5d = 0.0_8
          else
            call popreal8(max6)
            x5d = max6d
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            du1d(l) = du1d(l) + x5d
          else
            du1d(l) = du1d(l) - x5d
          end if
          call popreal8(tmp)
          temp = sign(max3, du2(l))
          tempd = -(one*tmpd/temp**2)
          max3d = sign(1.d0, max3*du2(l))*tempd
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(max3)
            x2d = 0.0_8
          else
            call popreal8(max3)
            x2d = max3d
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            du2d(l) = du2d(l) + x2d
          else
            du2d(l) = du2d(l) - x2d
          end if
        end do
      end if
      call popcontrol1b(branch)
      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_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: sface flux left right
!   with respect to varying inputs: sface sx sy sz flux left right
!        ================================================================
    subroutine riemannflux_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) :: rfaced
      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, aread, 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(realtype) :: max2d
      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))
            call pushcontrol1b(1)
          else
            call pushcontrol1b(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 pushreal8(etl)
          call etot(left(irho), left(ivx), left(ivy), left(ivz), left(&
&             irhoe), ktmp(1), etl, correctfork)
          call pushreal8(etr)
          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
            call pushcontrol1b(0)
          else
            call pushcontrol1b(1)
            max2 = 1.e-25_realtype
          end if
          tmp = one/max2
          call pushreal8(sx)
          sx = sx*tmp
          call pushreal8(sy)
          sy = sy*tmp
          call pushreal8(sz)
          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
            call pushcontrol1b(0)
          else
            a2avg = -(gm1*(havg-alphaavg)-gm53*kavg)
            call pushcontrol1b(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
            call pushcontrol1b(1)
          else
            call pushcontrol1b(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
            call pushcontrol1b(1)
          else
            abs1 = -x1
            call pushcontrol1b(0)
          end if
          x2 = sqrt(gammaface*left(irhoe)/left(irho)) - sqrt(gammaface*&
&           right(irhoe)/right(irho))
          if (x2 .ge. 0.) then
            abs2 = x2
            call pushcontrol1b(0)
          else
            abs2 = -x2
            call pushcontrol1b(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
            call pushcontrol1b(0)
          else
            lam1 = -(unavg-rface+aavg)
            call pushcontrol1b(1)
          end if
          if (unavg - rface - aavg .ge. 0.) then
            lam2 = unavg - rface - aavg
            call pushcontrol1b(0)
          else
            lam2 = -(unavg-rface-aavg)
            call pushcontrol1b(1)
          end if
          if (unavg - rface .ge. 0.) then
            lam3 = unavg - rface
            call pushcontrol1b(0)
          else
            lam3 = -(unavg-rface)
            call pushcontrol1b(1)
          end if
! apply the entropy correction to the eigenvalues.
          tmp = two*eta
          if (lam1 .lt. tmp) then
            call pushreal8(lam1)
            lam1 = eta + fourth*lam1*lam1/eta
            call pushcontrol1b(0)
          else
            call pushcontrol1b(1)
          end if
          if (lam2 .lt. tmp) then
            call pushreal8(lam2)
            lam2 = eta + fourth*lam2*lam2/eta
            call pushcontrol1b(0)
          else
            call pushcontrol1b(1)
          end if
          if (lam3 .lt. tmp) then
            call pushreal8(lam3)
            lam3 = eta + fourth*lam3*lam3/eta
            call pushcontrol1b(0)
          else
            call pushcontrol1b(1)
          end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
          call pushreal8(lam1)
          lam1 = lam1*area
          call pushreal8(lam2)
          lam2 = lam2*area
          call pushreal8(lam3)
          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
          szd = abv7*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
          syd = abv7*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
          sxd = abv7*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
          sxd = sxd + dru*abv5d
          syd = syd + drv*abv5d
          szd = szd + drw*abv5d
          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
          call popreal8(lam3)
          call popreal8(lam2)
          call popreal8(lam1)
          aread = lam3*lam3d + lam2*lam2d + lam1*lam1d
          lam3d = area*lam3d
          lam2d = area*lam2d
          lam1d = area*lam1d
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            tempd0 = fourth*lam3d/eta
            call popreal8(lam3)
            etad = lam3d - lam3**2*tempd0/eta
            lam3d = 2*lam3*tempd0
          else
            etad = 0.0_8
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            tempd0 = fourth*lam2d/eta
            call popreal8(lam2)
            etad = etad + lam2d - lam2**2*tempd0/eta
            lam2d = 2*lam2*tempd0
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            tempd0 = fourth*lam1d/eta
            call popreal8(lam1)
            etad = etad + lam1d - lam1**2*tempd0/eta
            lam1d = 2*lam1*tempd0
          end if
          tmp = one/max2
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            unavgd = unavgd + lam3d
            rfaced = -lam3d
          else
            rfaced = lam3d
            unavgd = unavgd - lam3d
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            unavgd = unavgd + lam2d
            rfaced = rfaced - lam2d
            aavgd = -lam2d
          else
            rfaced = rfaced + lam2d
            unavgd = unavgd - lam2d
            aavgd = lam2d
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            unavgd = unavgd + lam1d
            rfaced = rfaced - lam1d
            aavgd = aavgd + lam1d
          else
            rfaced = rfaced + lam1d
            unavgd = unavgd - lam1d
            aavgd = aavgd - lam1d
          end if
          abs1d = half*etad
          abs2d = half*etad
          call popcontrol1b(branch)
          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
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            x1d = -abs1d
          else
            x1d = abs1d
          end if
          leftd(ivx) = leftd(ivx) + sx*x1d
          rightd(ivx) = rightd(ivx) - sx*x1d
          sxd = sxd + (left(ivx)-right(ivx))*x1d
          leftd(ivy) = leftd(ivy) + sy*x1d
          rightd(ivy) = rightd(ivy) - sy*x1d
          syd = syd + (left(ivy)-right(ivy))*x1d
          leftd(ivz) = leftd(ivz) + sz*x1d
          rightd(ivz) = rightd(ivz) - sz*x1d
          szd = szd + (left(ivz)-right(ivz))*x1d
          call popcontrol1b(branch)
          if (branch .ne. 0) then
            rfaced = rfaced + unavgd
            unavgd = 0.0_8
          end if
          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
          sxd = sxd + uavg*unavgd
          vavgd = vavgd + sy*unavgd
          syd = syd + vavg*unavgd
          wavgd = wavgd + sz*unavgd
          szd = szd + wavg*unavgd
          call popcontrol1b(branch)
          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
          call popreal8(sz)
          call popreal8(sy)
          call popreal8(sx)
          tempd0 = half*alphaavgd
          uavgd = uavgd + 2*uavg*tempd0
          vavgd = vavgd + 2*vavg*tempd0
          wavgd = wavgd + 2*wavg*tempd0
          sfaced = sfaced + tmp*rfaced
          tmpd = sface*rfaced + sz*szd + sy*syd + sx*sxd
          szd = tmp*szd
          syd = tmp*syd
          sxd = tmp*sxd
          max2d = -(one*tmpd/max2**2)
          tmp = one/(z1l+z1r)
          call popcontrol1b(branch)
          if (branch .eq. 0) aread = aread + max2d
          if (sx**2 + sy**2 + sz**2 .eq. 0.0_8) then
            tempd0 = 0.0_8
          else
            tempd0 = aread/(2.0*sqrt(sx**2+sy**2+sz**2))
          end if
          sxd = sxd + 2*sx*tempd0
          syd = syd + 2*sy*tempd0
          szd = szd + 2*sz*tempd0
          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
          call popreal8(etr)
          ktmpd = 0.0_8
          call etot_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 popreal8(etl)
          call etot_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)
          call popcontrol1b(branch)
          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)))
        case (turkel) 
          sxd = 0.0_8
          syd = 0.0_8
          szd = 0.0_8
        case (choimerkle) 
          sxd = 0.0_8
          syd = 0.0_8
          szd = 0.0_8
        case default
          sxd = 0.0_8
          syd = 0.0_8
          szd = 0.0_8
        end select
      case (vanleer) 
        sxd = 0.0_8
        syd = 0.0_8
        szd = 0.0_8
      case (ausmdv) 
        sxd = 0.0_8
        syd = 0.0_8
        szd = 0.0_8
      case default
        sxd = 0.0_8
        syd = 0.0_8
        szd = 0.0_8
      end select
    end subroutine riemannflux_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_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_b, only : getcorrectfork, terminate
    use flowutils_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: *w *x *si *sj *sk *fw *(*viscsubface.tau)
!                *(*viscsubface.q)
!   with respect to varying inputs: *rev *aa *wx *wy *wz *w *x
!                *rlv *qx *qy *qz *ux *uy *uz *si *sj *sk *vx *vy
!                *vz *fw *(*viscsubface.tau) *(*viscsubface.q)
!   rw status of diff variables: *rev:out *aa:out *wx:out *wy:out
!                *wz:out *w:incr *x:incr *rlv:out *qx:out *qy:out
!                *qz:out *ux:out *uy:out *uz:out *si:incr *sj:incr
!                *sk:incr *vx:out *vy:out *vz:out *fw:in-out *(*viscsubface.tau):in-out
!                *(*viscsubface.q):in-out
!   plus diff mem management of: rev:in aa:in wx:in wy:in wz:in
!                w:in x:in rlv:in qx:in qy:in qz:in ux:in uy:in
!                uz:in si:in sj:in sk:in vx:in vy:in vz:in fw:in
!                viscsubface:in *viscsubface.tau:in *viscsubface.q:in
  subroutine viscousflux_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, ssxd, ssyd, sszd, ssd, 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) :: temp
    real(kind=realtype) :: tempd
    real(kind=realtype) :: temp0
    real(kind=realtype) :: tempd0
    integer :: branch
    real(kind=realtype) :: temp1
    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(aad)) aad = 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
! determine whether or not the wall stress tensor and wall heat
! flux must be stored for viscous walls.
      storewalltensor = .false.
      if (wallfunctions) then
        call pushcontrol1b(1)
        storewalltensor = .true.
      else if (rkstage .eq. 0 .and. currentlevel .eq. groundlevel) then
        call pushcontrol1b(0)
        storewalltensor = .true.
      else
        call pushcontrol1b(0)
      end if
      if (associated(revd)) revd = 0.0_8
      if (associated(aad)) aad = 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(aad)) aad = 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))
          call pushcontrol1b(0)
        else
          call pushcontrol1b(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)
        call pushreal8(ssx)
        ssx = ss*ssx
        call pushreal8(ssy)
        ssy = ss*ssy
        call pushreal8(ssz)
        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
        call pushreal8(u_x)
        u_x = u_x - corr*ssx
        call pushreal8(u_y)
        u_y = u_y - corr*ssy
        call pushreal8(u_z)
        u_z = u_z - corr*ssz
        call pushreal8(corr)
        corr = v_x*ssx + v_y*ssy + v_z*ssz - (w(i+1, j, k, ivy)-w(i, j, &
&         k, ivy))*ss
        call pushreal8(v_x)
        v_x = v_x - corr*ssx
        call pushreal8(v_y)
        v_y = v_y - corr*ssy
        call pushreal8(v_z)
        v_z = v_z - corr*ssz
        call pushreal8(corr)
        corr = w_x*ssx + w_y*ssy + w_z*ssz - (w(i+1, j, k, ivz)-w(i, j, &
&         k, ivz))*ss
        call pushreal8(w_x)
        w_x = w_x - corr*ssx
        call pushreal8(w_y)
        w_y = w_y - corr*ssy
        call pushreal8(w_z)
        w_z = w_z - corr*ssz
        call pushreal8(corr)
        corr = q_x*ssx + q_y*ssy + q_z*ssz + (aa(i+1, j, k)-aa(i, j, k))&
&         *ss
        call pushreal8(q_x)
        q_x = q_x - corr*ssx
        call pushreal8(q_y)
        q_y = q_y - corr*ssy
        call pushreal8(q_z)
        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
        call pushreal8(q_x)
        q_x = heatcoef*q_x
        call pushreal8(q_y)
        q_y = heatcoef*q_y
        call pushreal8(q_z)
        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
            call pushcontrol1b(0)
          else
            call pushcontrol1b(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
          call pushcontrol1b(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
          call pushcontrol1b(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.
        if (i .eq. 1 .and. storewalltensor .and. visciminpointer(j, k) &
&           .gt. 0) then
          call pushcontrol1b(0)
        else
          call pushcontrol1b(1)
        end if
! and the i == il case.
        if (i .eq. il .and. storewalltensor .and. viscimaxpointer(j, k) &
&           .gt. 0) then
          q_zd = viscsubfaced(viscimaxpointer(j, k))%q(j, k, 3)
          viscsubfaced(viscimaxpointer(j, k))%q(j, k, 3) = 0.0_8
          q_yd = viscsubfaced(viscimaxpointer(j, k))%q(j, k, 2)
          viscsubfaced(viscimaxpointer(j, k))%q(j, k, 2) = 0.0_8
          q_xd = viscsubfaced(viscimaxpointer(j, k))%q(j, k, 1)
          viscsubfaced(viscimaxpointer(j, k))%q(j, k, 1) = 0.0_8
          tauyzd = viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 6)
          viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 6) = 0.0_8
          tauxzd = viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 5)
          viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 5) = 0.0_8
          tauxyd = viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 4)
          viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 4) = 0.0_8
          tauzzd = viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 3)
          viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 3) = 0.0_8
          tauyyd = viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 2)
          viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 2) = 0.0_8
          tauxxd = viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 1)
          viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 1) = 0.0_8
        else
          tauzzd = 0.0_8
          tauxxd = 0.0_8
          tauxyd = 0.0_8
          tauxzd = 0.0_8
          q_xd = 0.0_8
          q_yd = 0.0_8
          q_zd = 0.0_8
          tauyyd = 0.0_8
          tauyzd = 0.0_8
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          q_zd = q_zd + viscsubfaced(visciminpointer(j, k))%q(j, k, 3)
          viscsubfaced(visciminpointer(j, k))%q(j, k, 3) = 0.0_8
          q_yd = q_yd + viscsubfaced(visciminpointer(j, k))%q(j, k, 2)
          viscsubfaced(visciminpointer(j, k))%q(j, k, 2) = 0.0_8
          q_xd = q_xd + viscsubfaced(visciminpointer(j, k))%q(j, k, 1)
          viscsubfaced(visciminpointer(j, k))%q(j, k, 1) = 0.0_8
          tauyzd = tauyzd + viscsubfaced(visciminpointer(j, k))%tau(j, k&
&           , 6)
          viscsubfaced(visciminpointer(j, k))%tau(j, k, 6) = 0.0_8
          tauxzd = tauxzd + viscsubfaced(visciminpointer(j, k))%tau(j, k&
&           , 5)
          viscsubfaced(visciminpointer(j, k))%tau(j, k, 5) = 0.0_8
          tauxyd = tauxyd + viscsubfaced(visciminpointer(j, k))%tau(j, k&
&           , 4)
          viscsubfaced(visciminpointer(j, k))%tau(j, k, 4) = 0.0_8
          tauzzd = tauzzd + viscsubfaced(visciminpointer(j, k))%tau(j, k&
&           , 3)
          viscsubfaced(visciminpointer(j, k))%tau(j, k, 3) = 0.0_8
          tauyyd = tauyyd + viscsubfaced(visciminpointer(j, k))%tau(j, k&
&           , 2)
          viscsubfaced(visciminpointer(j, k))%tau(j, k, 2) = 0.0_8
          tauxxd = tauxxd + viscsubfaced(visciminpointer(j, k))%tau(j, k&
&           , 1)
          viscsubfaced(visciminpointer(j, k))%tau(j, k, 1) = 0.0_8
        end if
        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
        sid(i, j, k, 3) = sid(i, j, k, 3) + (ubar*tauxz+vbar*tauyz+wbar*&
&         tauzz-q_z)*frhoed + tauzz*fmzd + tauyz*fmyd + tauxz*fmxd
        sid(i, j, k, 2) = sid(i, j, k, 2) + (ubar*tauxy+vbar*tauyy+wbar*&
&         tauyz-q_y)*frhoed + tauyz*fmzd + tauyy*fmyd + tauxy*fmxd
        sid(i, j, k, 1) = sid(i, j, k, 1) + (ubar*tauxx+vbar*tauxy+wbar*&
&         tauxz-q_x)*frhoed + tauxz*fmzd + tauxy*fmyd + tauxx*fmxd
        q_xd = q_xd - si(i, j, k, 1)*frhoed
        q_yd = q_yd - si(i, j, k, 2)*frhoed
        q_zd = q_zd - si(i, j, k, 3)*frhoed
        ubard = tauxz*tempd + tauxy*tempd0 + tauxx*tempd1
        tauxzd = 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 = 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 = tauzzd + wbar*tempd + si(i, j, k, 3)*fmzd
        tauxyd = tauxyd + ubar*tempd0 + vbar*tempd1 + si(i, j, k, 1)*&
&         fmyd + si(i, j, k, 2)*fmxd
        tauyyd = tauyyd + vbar*tempd0 + si(i, j, k, 2)*fmyd
        tauxxd = 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
        call popcontrol1b(branch)
        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)
          call popcontrol1b(branch)
          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
        call popreal8(q_z)
        call popreal8(q_y)
        call popreal8(q_x)
        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
        call popreal8(q_z)
        corrd = -(ssz*q_zd) - ssy*q_yd - ssx*q_xd
        sszd = q_z*corrd - corr*q_zd
        call popreal8(q_y)
        ssyd = q_y*corrd - corr*q_yd
        call popreal8(q_x)
        ssxd = q_x*corrd - corr*q_xd
        call popreal8(corr)
        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
        ssd = (aa(i+1, j, k)-aa(i, j, k))*corrd
        call popreal8(w_z)
        corrd = -(ssz*w_zd) - ssy*w_yd - ssx*w_xd
        sszd = sszd + w_z*corrd - corr*w_zd
        call popreal8(w_y)
        ssyd = ssyd + w_y*corrd - corr*w_yd
        call popreal8(w_x)
        ssxd = ssxd + w_x*corrd - corr*w_xd
        call popreal8(corr)
        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
        ssd = ssd - (w(i+1, j, k, ivz)-w(i, j, k, ivz))*corrd
        call popreal8(v_z)
        corrd = -(ssz*v_zd) - ssy*v_yd - ssx*v_xd
        sszd = sszd + v_z*corrd - corr*v_zd
        call popreal8(v_y)
        ssyd = ssyd + v_y*corrd - corr*v_yd
        call popreal8(v_x)
        ssxd = ssxd + v_x*corrd - corr*v_xd
        call popreal8(corr)
        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
        ssd = ssd - (w(i+1, j, k, ivy)-w(i, j, k, ivy))*corrd
        call popreal8(u_z)
        corrd = -(ssz*u_zd) - ssy*u_yd - ssx*u_xd
        sszd = sszd + u_z*corrd - corr*u_zd
        call popreal8(u_y)
        ssyd = ssyd + u_y*corrd - corr*u_yd
        call popreal8(u_x)
        ssxd = ssxd + u_x*corrd - corr*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
        call popreal8(ssz)
        call popreal8(ssy)
        call popreal8(ssx)
        ssd = ssd + ssz*sszd - (w(i+1, j, k, ivx)-w(i, j, k, ivx))*corrd&
&         + ssy*ssyd + ssx*ssxd
        temp1 = ssx*ssx + ssy*ssy + ssz*ssz
        temp0 = sqrt(temp1)
        if (temp1 .eq. 0.0_8) then
          tempd1 = 0.0_8
        else
          tempd1 = -(one*ssd/(2.0*temp0**3))
        end if
        sszd = ss*sszd + 2*ssz*tempd1
        ssyd = ss*ssyd + 2*ssy*tempd1
        ssxd = ss*ssxd + 2*ssx*tempd1
        tempd1 = eighth*sszd
        xd(i+1, j-1, k-1, 3) = xd(i+1, j-1, k-1, 3) + tempd1
        xd(i-1, j-1, k-1, 3) = xd(i-1, j-1, k-1, 3) - tempd1
        xd(i+1, j-1, k, 3) = xd(i+1, j-1, k, 3) + tempd1
        xd(i-1, j-1, k, 3) = xd(i-1, j-1, k, 3) - tempd1
        xd(i+1, j, k-1, 3) = xd(i+1, j, k-1, 3) + tempd1
        xd(i-1, j, k-1, 3) = xd(i-1, j, k-1, 3) - tempd1
        xd(i+1, j, k, 3) = xd(i+1, j, k, 3) + tempd1
        xd(i-1, j, k, 3) = xd(i-1, j, k, 3) - tempd1
        tempd1 = eighth*ssyd
        xd(i+1, j-1, k-1, 2) = xd(i+1, j-1, k-1, 2) + tempd1
        xd(i-1, j-1, k-1, 2) = xd(i-1, j-1, k-1, 2) - tempd1
        xd(i+1, j-1, k, 2) = xd(i+1, j-1, k, 2) + tempd1
        xd(i-1, j-1, k, 2) = xd(i-1, j-1, k, 2) - tempd1
        xd(i+1, j, k-1, 2) = xd(i+1, j, k-1, 2) + tempd1
        xd(i-1, j, k-1, 2) = xd(i-1, j, k-1, 2) - tempd1
        xd(i+1, j, k, 2) = xd(i+1, j, k, 2) + tempd1
        xd(i-1, j, k, 2) = xd(i-1, j, k, 2) - tempd1
        tempd1 = eighth*ssxd
        xd(i+1, j-1, k-1, 1) = xd(i+1, j-1, k-1, 1) + tempd1
        xd(i-1, j-1, k-1, 1) = xd(i-1, j-1, k-1, 1) - tempd1
        xd(i+1, j-1, k, 1) = xd(i+1, j-1, k, 1) + tempd1
        xd(i-1, j-1, k, 1) = xd(i-1, j-1, k, 1) - tempd1
        xd(i+1, j, k-1, 1) = xd(i+1, j, k-1, 1) + tempd1
        xd(i-1, j, k-1, 1) = xd(i-1, j, k-1, 1) - tempd1
        xd(i+1, j, k, 1) = xd(i+1, j, k, 1) + tempd1
        xd(i-1, j, k, 1) = xd(i-1, j, k, 1) - tempd1
        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
        call popcontrol1b(branch)
        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))
          call pushcontrol1b(0)
        else
          call pushcontrol1b(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)
        call pushreal8(ssx)
        ssx = ss*ssx
        call pushreal8(ssy)
        ssy = ss*ssy
        call pushreal8(ssz)
        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
        call pushreal8(u_x)
        u_x = u_x - corr*ssx
        call pushreal8(u_y)
        u_y = u_y - corr*ssy
        call pushreal8(u_z)
        u_z = u_z - corr*ssz
        call pushreal8(corr)
        corr = v_x*ssx + v_y*ssy + v_z*ssz - (w(i, j+1, k, ivy)-w(i, j, &
&         k, ivy))*ss
        call pushreal8(v_x)
        v_x = v_x - corr*ssx
        call pushreal8(v_y)
        v_y = v_y - corr*ssy
        call pushreal8(v_z)
        v_z = v_z - corr*ssz
        call pushreal8(corr)
        corr = w_x*ssx + w_y*ssy + w_z*ssz - (w(i, j+1, k, ivz)-w(i, j, &
&         k, ivz))*ss
        call pushreal8(w_x)
        w_x = w_x - corr*ssx
        call pushreal8(w_y)
        w_y = w_y - corr*ssy
        call pushreal8(w_z)
        w_z = w_z - corr*ssz
        call pushreal8(corr)
        corr = q_x*ssx + q_y*ssy + q_z*ssz + (aa(i, j+1, k)-aa(i, j, k))&
&         *ss
        call pushreal8(q_x)
        q_x = q_x - corr*ssx
        call pushreal8(q_y)
        q_y = q_y - corr*ssy
        call pushreal8(q_z)
        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
        call pushreal8(q_x)
        q_x = heatcoef*q_x
        call pushreal8(q_y)
        q_y = heatcoef*q_y
        call pushreal8(q_z)
        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
            call pushcontrol1b(0)
          else
            call pushcontrol1b(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
          call pushcontrol1b(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
          call pushcontrol1b(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.
        if (j .eq. 1 .and. storewalltensor .and. viscjminpointer(i, k) &
&           .gt. 0) then
          call pushcontrol1b(0)
        else
          call pushcontrol1b(1)
        end if
! and the j == jl case.
        if (j .eq. jl .and. storewalltensor .and. viscjmaxpointer(i, k) &
&           .gt. 0) then
          q_zd = viscsubfaced(viscjmaxpointer(i, k))%q(i, k, 3)
          viscsubfaced(viscjmaxpointer(i, k))%q(i, k, 3) = 0.0_8
          q_yd = viscsubfaced(viscjmaxpointer(i, k))%q(i, k, 2)
          viscsubfaced(viscjmaxpointer(i, k))%q(i, k, 2) = 0.0_8
          q_xd = viscsubfaced(viscjmaxpointer(i, k))%q(i, k, 1)
          viscsubfaced(viscjmaxpointer(i, k))%q(i, k, 1) = 0.0_8
          tauyzd = viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 6)
          viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 6) = 0.0_8
          tauxzd = viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 5)
          viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 5) = 0.0_8
          tauxyd = viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 4)
          viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 4) = 0.0_8
          tauzzd = viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 3)
          viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 3) = 0.0_8
          tauyyd = viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 2)
          viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 2) = 0.0_8
          tauxxd = viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 1)
          viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 1) = 0.0_8
        else
          tauzzd = 0.0_8
          tauxxd = 0.0_8
          tauxyd = 0.0_8
          tauxzd = 0.0_8
          q_xd = 0.0_8
          q_yd = 0.0_8
          q_zd = 0.0_8
          tauyyd = 0.0_8
          tauyzd = 0.0_8
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          q_zd = q_zd + viscsubfaced(viscjminpointer(i, k))%q(i, k, 3)
          viscsubfaced(viscjminpointer(i, k))%q(i, k, 3) = 0.0_8
          q_yd = q_yd + viscsubfaced(viscjminpointer(i, k))%q(i, k, 2)
          viscsubfaced(viscjminpointer(i, k))%q(i, k, 2) = 0.0_8
          q_xd = q_xd + viscsubfaced(viscjminpointer(i, k))%q(i, k, 1)
          viscsubfaced(viscjminpointer(i, k))%q(i, k, 1) = 0.0_8
          tauyzd = tauyzd + viscsubfaced(viscjminpointer(i, k))%tau(i, k&
&           , 6)
          viscsubfaced(viscjminpointer(i, k))%tau(i, k, 6) = 0.0_8
          tauxzd = tauxzd + viscsubfaced(viscjminpointer(i, k))%tau(i, k&
&           , 5)
          viscsubfaced(viscjminpointer(i, k))%tau(i, k, 5) = 0.0_8
          tauxyd = tauxyd + viscsubfaced(viscjminpointer(i, k))%tau(i, k&
&           , 4)
          viscsubfaced(viscjminpointer(i, k))%tau(i, k, 4) = 0.0_8
          tauzzd = tauzzd + viscsubfaced(viscjminpointer(i, k))%tau(i, k&
&           , 3)
          viscsubfaced(viscjminpointer(i, k))%tau(i, k, 3) = 0.0_8
          tauyyd = tauyyd + viscsubfaced(viscjminpointer(i, k))%tau(i, k&
&           , 2)
          viscsubfaced(viscjminpointer(i, k))%tau(i, k, 2) = 0.0_8
          tauxxd = tauxxd + viscsubfaced(viscjminpointer(i, k))%tau(i, k&
&           , 1)
          viscsubfaced(viscjminpointer(i, k))%tau(i, k, 1) = 0.0_8
        end if
        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)
        tempd0 = sj(i, j, k, 1)*frhoed
        tempd = sj(i, j, k, 2)*frhoed
        tempd1 = sj(i, j, k, 3)*frhoed
        sjd(i, j, k, 3) = sjd(i, j, k, 3) + (ubar*tauxz+vbar*tauyz+wbar*&
&         tauzz-q_z)*frhoed + tauzz*fmzd + tauyz*fmyd + tauxz*fmxd
        sjd(i, j, k, 2) = sjd(i, j, k, 2) + (ubar*tauxy+vbar*tauyy+wbar*&
&         tauyz-q_y)*frhoed + tauyz*fmzd + tauyy*fmyd + tauxy*fmxd
        sjd(i, j, k, 1) = sjd(i, j, k, 1) + (ubar*tauxx+vbar*tauxy+wbar*&
&         tauxz-q_x)*frhoed + tauxz*fmzd + tauxy*fmyd + tauxx*fmxd
        q_xd = q_xd - sj(i, j, k, 1)*frhoed
        q_yd = q_yd - sj(i, j, k, 2)*frhoed
        q_zd = q_zd - sj(i, j, k, 3)*frhoed
        ubard = tauxz*tempd1 + tauxy*tempd + tauxx*tempd0
        tauxzd = tauxzd + ubar*tempd1 + wbar*tempd0 + sj(i, j, k, 1)*&
&         fmzd + sj(i, j, k, 3)*fmxd
        vbard = tauyz*tempd1 + tauyy*tempd + tauxy*tempd0
        tauyzd = tauyzd + vbar*tempd1 + wbar*tempd + sj(i, j, k, 2)*fmzd&
&         + sj(i, j, k, 3)*fmyd
        wbard = tauzz*tempd1 + tauyz*tempd + tauxz*tempd0
        tauzzd = tauzzd + wbar*tempd1 + sj(i, j, k, 3)*fmzd
        tauxyd = tauxyd + ubar*tempd + vbar*tempd0 + sj(i, j, k, 1)*fmyd&
&         + sj(i, j, k, 2)*fmxd
        tauyyd = tauyyd + vbar*tempd + sj(i, j, k, 2)*fmyd
        tauxxd = tauxxd + ubar*tempd0 + 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
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          eyzd = -tauyzd
          exzd = -tauxzd
          tempd0 = fact*eyzd
          tauxzsd = mut*tauxzd + wyx*tempd0
          tauxysd = mut*tauxyd + wzx*tempd0
          tauzzsd = mut*tauzzd + wyz*tempd0
          tauyysd = mut*tauyyd + wzy*tempd0
          wyxd = tauxzs*tempd0
          wyzd = tauzzs*tempd0
          wzxd = tauxys*tempd0
          wzyd = tauyys*tempd0
          tempd0 = fact*exzd
          mutd = tauyzs*tauyzd + tauxzs*tauxzd + tauxys*tauxyd + tauzzs*&
&           tauzzd + tauyys*tauyyd + tauxxs*tauxxd
          tauyzsd = mut*tauyzd + wxy*tempd0
          exyd = -tauxyd
          ezzd = -tauzzd
          eyyd = -tauyyd
          tauxxsd = mut*tauxxd + wzx*tempd0
          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*tempd0
          wxzd = tauzzs*tempd0
          tauzzsd = tauzzsd + wxz*tempd0
          wzxd = wzxd + tauxxs*tempd0
          wzyd = wzyd + tauxys*tempd0
          tauxysd = tauxysd + wzy*tempd0
          tempd0 = fact*exyd
          wxyd = wxyd + tauyys*tempd0
          tauyysd = tauyysd + wxy*tempd0
          wxzd = wxzd + tauyzs*tempd0
          tauyzsd = tauyzsd + wxz*tempd0
          wyxd = wyxd + tauxxs*tempd0
          tauxxsd = tauxxsd + wyx*tempd0
          wyzd = wyzd + tauxzs*tempd0
          tauxzsd = tauxzsd + wyz*tempd0
          tempd0 = fact*two*ezzd
          wzxd = wzxd + tauxzs*tempd0
          tauxzsd = tauxzsd + wzx*tempd0
          wzyd = wzyd + tauyzs*tempd0
          tauyzsd = tauyzsd + wzy*tempd0
          tempd0 = fact*two*eyyd
          wyxd = wyxd + tauxys*tempd0
          tauxysd = tauxysd + wyx*tempd0
          wyzd = wyzd + tauyzs*tempd0 - wzyd
          tauyzsd = tauyzsd + wyz*tempd0
          tempd0 = fact*two*exxd
          wxyd = wxyd + tauxys*tempd0 - wyxd
          tauxysd = tauxysd + wxy*tempd0
          wxzd = wxzd + tauxzs*tempd0 - wzxd
          tauxzsd = tauxzsd + wxz*tempd0
          v_zd = wyzd
          w_yd = -wyzd
          u_zd = wxzd
          w_xd = -wxzd
          u_yd = wxyd
          v_xd = -wxyd
          tempd0 = ccr1*factd/den
          mued = mued + tempd0
          dend = -(mue*tempd0/den)
          call popcontrol1b(branch)
          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
            tempd0 = 0.0_8
          else
            tempd0 = 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*tempd0
          u_yd = u_yd + 2*u_y*tempd0
          u_zd = u_zd + 2*u_z*tempd0
          v_xd = v_xd + 2*v_x*tempd0
          v_yd = 2*v_y*tempd0
          v_zd = v_zd + 2*v_z*tempd0
          w_xd = w_xd + 2*w_x*tempd0
          w_yd = w_yd + 2*w_y*tempd0
          w_zd = 2*w_z*tempd0
        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
        tempd0 = twothird*fracdivd
        call popreal8(q_z)
        call popreal8(q_y)
        call popreal8(q_x)
        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 + tempd0
        v_yd = v_yd + two*tauyysd + tempd0
        u_xd = u_xd + two*tauxxsd + tempd0
        call popreal8(q_z)
        corrd = -(ssz*q_zd) - ssy*q_yd - ssx*q_xd
        sszd = q_z*corrd - corr*q_zd
        call popreal8(q_y)
        ssyd = q_y*corrd - corr*q_yd
        call popreal8(q_x)
        ssxd = q_x*corrd - corr*q_xd
        call popreal8(corr)
        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
        ssd = (aa(i, j+1, k)-aa(i, j, k))*corrd
        call popreal8(w_z)
        corrd = -(ssz*w_zd) - ssy*w_yd - ssx*w_xd
        sszd = sszd + w_z*corrd - corr*w_zd
        call popreal8(w_y)
        ssyd = ssyd + w_y*corrd - corr*w_yd
        call popreal8(w_x)
        ssxd = ssxd + w_x*corrd - corr*w_xd
        call popreal8(corr)
        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
        ssd = ssd - (w(i, j+1, k, ivz)-w(i, j, k, ivz))*corrd
        call popreal8(v_z)
        corrd = -(ssz*v_zd) - ssy*v_yd - ssx*v_xd
        sszd = sszd + v_z*corrd - corr*v_zd
        call popreal8(v_y)
        ssyd = ssyd + v_y*corrd - corr*v_yd
        call popreal8(v_x)
        ssxd = ssxd + v_x*corrd - corr*v_xd
        call popreal8(corr)
        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
        ssd = ssd - (w(i, j+1, k, ivy)-w(i, j, k, ivy))*corrd
        call popreal8(u_z)
        corrd = -(ssz*u_zd) - ssy*u_yd - ssx*u_xd
        sszd = sszd + u_z*corrd - corr*u_zd
        call popreal8(u_y)
        ssyd = ssyd + u_y*corrd - corr*u_yd
        call popreal8(u_x)
        ssxd = ssxd + u_x*corrd - corr*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
        call popreal8(ssz)
        call popreal8(ssy)
        call popreal8(ssx)
        ssd = ssd + ssz*sszd - (w(i, j+1, k, ivx)-w(i, j, k, ivx))*corrd&
&         + ssy*ssyd + ssx*ssxd
        temp0 = ssx*ssx + ssy*ssy + ssz*ssz
        temp = sqrt(temp0)
        if (temp0 .eq. 0.0_8) then
          tempd0 = 0.0_8
        else
          tempd0 = -(one*ssd/(2.0*temp**3))
        end if
        sszd = ss*sszd + 2*ssz*tempd0
        ssyd = ss*ssyd + 2*ssy*tempd0
        ssxd = ss*ssxd + 2*ssx*tempd0
        tempd0 = eighth*sszd
        xd(i-1, j+1, k-1, 3) = xd(i-1, j+1, k-1, 3) + tempd0
        xd(i-1, j-1, k-1, 3) = xd(i-1, j-1, k-1, 3) - tempd0
        xd(i-1, j+1, k, 3) = xd(i-1, j+1, k, 3) + tempd0
        xd(i-1, j-1, k, 3) = xd(i-1, j-1, k, 3) - tempd0
        xd(i, j+1, k-1, 3) = xd(i, j+1, k-1, 3) + tempd0
        xd(i, j-1, k-1, 3) = xd(i, j-1, k-1, 3) - tempd0
        xd(i, j+1, k, 3) = xd(i, j+1, k, 3) + tempd0
        xd(i, j-1, k, 3) = xd(i, j-1, k, 3) - tempd0
        tempd0 = eighth*ssyd
        xd(i-1, j+1, k-1, 2) = xd(i-1, j+1, k-1, 2) + tempd0
        xd(i-1, j-1, k-1, 2) = xd(i-1, j-1, k-1, 2) - tempd0
        xd(i-1, j+1, k, 2) = xd(i-1, j+1, k, 2) + tempd0
        xd(i-1, j-1, k, 2) = xd(i-1, j-1, k, 2) - tempd0
        xd(i, j+1, k-1, 2) = xd(i, j+1, k-1, 2) + tempd0
        xd(i, j-1, k-1, 2) = xd(i, j-1, k-1, 2) - tempd0
        xd(i, j+1, k, 2) = xd(i, j+1, k, 2) + tempd0
        xd(i, j-1, k, 2) = xd(i, j-1, k, 2) - tempd0
        tempd0 = eighth*ssxd
        xd(i-1, j+1, k-1, 1) = xd(i-1, j+1, k-1, 1) + tempd0
        xd(i-1, j-1, k-1, 1) = xd(i-1, j-1, k-1, 1) - tempd0
        xd(i-1, j+1, k, 1) = xd(i-1, j+1, k, 1) + tempd0
        xd(i-1, j-1, k, 1) = xd(i-1, j-1, k, 1) - tempd0
        xd(i, j+1, k-1, 1) = xd(i, j+1, k-1, 1) + tempd0
        xd(i, j-1, k-1, 1) = xd(i, j-1, k-1, 1) - tempd0
        xd(i, j+1, k, 1) = xd(i, j+1, k, 1) + tempd0
        xd(i, j-1, k, 1) = xd(i, j-1, k, 1) - tempd0
        tempd0 = fourth*q_zd
        qzd(i-1, j, k-1) = qzd(i-1, j, k-1) + tempd0
        qzd(i, j, k-1) = qzd(i, j, k-1) + tempd0
        qzd(i-1, j, k) = qzd(i-1, j, k) + tempd0
        qzd(i, j, k) = qzd(i, j, k) + tempd0
        tempd0 = fourth*q_yd
        qyd(i-1, j, k-1) = qyd(i-1, j, k-1) + tempd0
        qyd(i, j, k-1) = qyd(i, j, k-1) + tempd0
        qyd(i-1, j, k) = qyd(i-1, j, k) + tempd0
        qyd(i, j, k) = qyd(i, j, k) + tempd0
        tempd0 = fourth*q_xd
        qxd(i-1, j, k-1) = qxd(i-1, j, k-1) + tempd0
        qxd(i, j, k-1) = qxd(i, j, k-1) + tempd0
        qxd(i-1, j, k) = qxd(i-1, j, k) + tempd0
        qxd(i, j, k) = qxd(i, j, k) + tempd0
        tempd0 = fourth*w_zd
        wzd(i-1, j, k-1) = wzd(i-1, j, k-1) + tempd0
        wzd(i, j, k-1) = wzd(i, j, k-1) + tempd0
        wzd(i-1, j, k) = wzd(i-1, j, k) + tempd0
        wzd(i, j, k) = wzd(i, j, k) + tempd0
        tempd0 = fourth*w_yd
        wyd(i-1, j, k-1) = wyd(i-1, j, k-1) + tempd0
        wyd(i, j, k-1) = wyd(i, j, k-1) + tempd0
        wyd(i-1, j, k) = wyd(i-1, j, k) + tempd0
        wyd(i, j, k) = wyd(i, j, k) + tempd0
        tempd0 = fourth*w_xd
        wxd(i-1, j, k-1) = wxd(i-1, j, k-1) + tempd0
        wxd(i, j, k-1) = wxd(i, j, k-1) + tempd0
        wxd(i-1, j, k) = wxd(i-1, j, k) + tempd0
        wxd(i, j, k) = wxd(i, j, k) + tempd0
        tempd0 = fourth*v_zd
        vzd(i-1, j, k-1) = vzd(i-1, j, k-1) + tempd0
        vzd(i, j, k-1) = vzd(i, j, k-1) + tempd0
        vzd(i-1, j, k) = vzd(i-1, j, k) + tempd0
        vzd(i, j, k) = vzd(i, j, k) + tempd0
        tempd0 = fourth*v_yd
        vyd(i-1, j, k-1) = vyd(i-1, j, k-1) + tempd0
        vyd(i, j, k-1) = vyd(i, j, k-1) + tempd0
        vyd(i-1, j, k) = vyd(i-1, j, k) + tempd0
        vyd(i, j, k) = vyd(i, j, k) + tempd0
        tempd0 = fourth*v_xd
        vxd(i-1, j, k-1) = vxd(i-1, j, k-1) + tempd0
        vxd(i, j, k-1) = vxd(i, j, k-1) + tempd0
        vxd(i-1, j, k) = vxd(i-1, j, k) + tempd0
        vxd(i, j, k) = vxd(i, j, k) + tempd0
        tempd0 = fourth*u_zd
        uzd(i-1, j, k-1) = uzd(i-1, j, k-1) + tempd0
        uzd(i, j, k-1) = uzd(i, j, k-1) + tempd0
        uzd(i-1, j, k) = uzd(i-1, j, k) + tempd0
        uzd(i, j, k) = uzd(i, j, k) + tempd0
        tempd0 = fourth*u_yd
        uyd(i-1, j, k-1) = uyd(i-1, j, k-1) + tempd0
        uyd(i, j, k-1) = uyd(i, j, k-1) + tempd0
        uyd(i-1, j, k) = uyd(i-1, j, k) + tempd0
        uyd(i, j, k) = uyd(i, j, k) + tempd0
        tempd0 = fourth*u_xd
        uxd(i-1, j, k-1) = uxd(i-1, j, k-1) + tempd0
        uxd(i, j, k-1) = uxd(i, j, k-1) + tempd0
        uxd(i-1, j, k) = uxd(i-1, j, k) + tempd0
        uxd(i, j, k) = uxd(i, j, k) + tempd0
        muld = factlamheat*heatcoefd + mutd
        mued = mued + factturbheat*heatcoefd + mutd
        call popcontrol1b(branch)
        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))
          call pushcontrol1b(0)
        else
          call pushcontrol1b(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)
        call pushreal8(ssx)
        ssx = ss*ssx
        call pushreal8(ssy)
        ssy = ss*ssy
        call pushreal8(ssz)
        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
        call pushreal8(u_x)
        u_x = u_x - corr*ssx
        call pushreal8(u_y)
        u_y = u_y - corr*ssy
        call pushreal8(u_z)
        u_z = u_z - corr*ssz
        call pushreal8(corr)
        corr = v_x*ssx + v_y*ssy + v_z*ssz - (w(i, j, k+1, ivy)-w(i, j, &
&         k, ivy))*ss
        call pushreal8(v_x)
        v_x = v_x - corr*ssx
        call pushreal8(v_y)
        v_y = v_y - corr*ssy
        call pushreal8(v_z)
        v_z = v_z - corr*ssz
        call pushreal8(corr)
        corr = w_x*ssx + w_y*ssy + w_z*ssz - (w(i, j, k+1, ivz)-w(i, j, &
&         k, ivz))*ss
        call pushreal8(w_x)
        w_x = w_x - corr*ssx
        call pushreal8(w_y)
        w_y = w_y - corr*ssy
        call pushreal8(w_z)
        w_z = w_z - corr*ssz
        call pushreal8(corr)
        corr = q_x*ssx + q_y*ssy + q_z*ssz + (aa(i, j, k+1)-aa(i, j, k))&
&         *ss
        call pushreal8(q_x)
        q_x = q_x - corr*ssx
        call pushreal8(q_y)
        q_y = q_y - corr*ssy
        call pushreal8(q_z)
        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
        call pushreal8(q_x)
        q_x = heatcoef*q_x
        call pushreal8(q_y)
        q_y = heatcoef*q_y
        call pushreal8(q_z)
        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
            call pushcontrol1b(0)
          else
            call pushcontrol1b(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
          call pushcontrol1b(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
          call pushcontrol1b(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.
        if (k .eq. 1 .and. storewalltensor .and. visckminpointer(i, j) &
&           .gt. 0) then
          call pushcontrol1b(0)
        else
          call pushcontrol1b(1)
        end if
! and the k == kl case.
        if (k .eq. kl .and. storewalltensor .and. visckmaxpointer(i, j) &
&           .gt. 0) then
          q_zd = viscsubfaced(visckmaxpointer(i, j))%q(i, j, 3)
          viscsubfaced(visckmaxpointer(i, j))%q(i, j, 3) = 0.0_8
          q_yd = viscsubfaced(visckmaxpointer(i, j))%q(i, j, 2)
          viscsubfaced(visckmaxpointer(i, j))%q(i, j, 2) = 0.0_8
          q_xd = viscsubfaced(visckmaxpointer(i, j))%q(i, j, 1)
          viscsubfaced(visckmaxpointer(i, j))%q(i, j, 1) = 0.0_8
          tauyzd = viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 6)
          viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 6) = 0.0_8
          tauxzd = viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 5)
          viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 5) = 0.0_8
          tauxyd = viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 4)
          viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 4) = 0.0_8
          tauzzd = viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 3)
          viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 3) = 0.0_8
          tauyyd = viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 2)
          viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 2) = 0.0_8
          tauxxd = viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 1)
          viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 1) = 0.0_8
        else
          tauzzd = 0.0_8
          tauxxd = 0.0_8
          tauxyd = 0.0_8
          tauxzd = 0.0_8
          q_xd = 0.0_8
          q_yd = 0.0_8
          q_zd = 0.0_8
          tauyyd = 0.0_8
          tauyzd = 0.0_8
        end if
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          q_zd = q_zd + viscsubfaced(visckminpointer(i, j))%q(i, j, 3)
          viscsubfaced(visckminpointer(i, j))%q(i, j, 3) = 0.0_8
          q_yd = q_yd + viscsubfaced(visckminpointer(i, j))%q(i, j, 2)
          viscsubfaced(visckminpointer(i, j))%q(i, j, 2) = 0.0_8
          q_xd = q_xd + viscsubfaced(visckminpointer(i, j))%q(i, j, 1)
          viscsubfaced(visckminpointer(i, j))%q(i, j, 1) = 0.0_8
          tauyzd = tauyzd + viscsubfaced(visckminpointer(i, j))%tau(i, j&
&           , 6)
          viscsubfaced(visckminpointer(i, j))%tau(i, j, 6) = 0.0_8
          tauxzd = tauxzd + viscsubfaced(visckminpointer(i, j))%tau(i, j&
&           , 5)
          viscsubfaced(visckminpointer(i, j))%tau(i, j, 5) = 0.0_8
          tauxyd = tauxyd + viscsubfaced(visckminpointer(i, j))%tau(i, j&
&           , 4)
          viscsubfaced(visckminpointer(i, j))%tau(i, j, 4) = 0.0_8
          tauzzd = tauzzd + viscsubfaced(visckminpointer(i, j))%tau(i, j&
&           , 3)
          viscsubfaced(visckminpointer(i, j))%tau(i, j, 3) = 0.0_8
          tauyyd = tauyyd + viscsubfaced(visckminpointer(i, j))%tau(i, j&
&           , 2)
          viscsubfaced(visckminpointer(i, j))%tau(i, j, 2) = 0.0_8
          tauxxd = tauxxd + viscsubfaced(visckminpointer(i, j))%tau(i, j&
&           , 1)
          viscsubfaced(visckminpointer(i, j))%tau(i, j, 1) = 0.0_8
        end if
        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 = q_xd - sk(i, j, k, 1)*frhoed
        q_yd = q_yd - sk(i, j, k, 2)*frhoed
        q_zd = q_zd - sk(i, j, k, 3)*frhoed
        skd(i, j, k, 3) = skd(i, j, k, 3) + (ubar*tauxz+vbar*tauyz+wbar*&
&         tauzz-q_z)*frhoed
        skd(i, j, k, 2) = skd(i, j, k, 2) + (ubar*tauxy+vbar*tauyy+wbar*&
&         tauyz-q_y)*frhoed
        skd(i, j, k, 1) = skd(i, j, k, 1) + (ubar*tauxx+vbar*tauxy+wbar*&
&         tauxz-q_x)*frhoed
        tempd0 = sk(i, j, k, 3)*frhoed
        ubard = tauxz*tempd0
        tauxzd = tauxzd + ubar*tempd0
        vbard = tauyz*tempd0
        tauyzd = tauyzd + vbar*tempd0
        wbard = tauzz*tempd0
        tauzzd = tauzzd + wbar*tempd0 + sk(i, j, k, 3)*fmzd
        tempd0 = sk(i, j, k, 2)*frhoed
        ubard = ubard + tauxy*tempd0
        tauxyd = tauxyd + ubar*tempd0
        vbard = vbard + tauyy*tempd0
        tauyyd = tauyyd + vbar*tempd0 + sk(i, j, k, 2)*fmyd
        wbard = wbard + tauyz*tempd0
        tauyzd = tauyzd + wbar*tempd0 + sk(i, j, k, 2)*fmzd + sk(i, j, k&
&         , 3)*fmyd
        tempd0 = sk(i, j, k, 1)*frhoed
        ubard = ubard + tauxx*tempd0
        tauxxd = tauxxd + ubar*tempd0 + sk(i, j, k, 1)*fmxd
        vbard = vbard + tauxy*tempd0
        tauxyd = tauxyd + vbar*tempd0 + sk(i, j, k, 1)*fmyd + sk(i, j, k&
&         , 2)*fmxd
        wbard = wbard + tauxz*tempd0
        tauxzd = tauxzd + wbar*tempd0 + sk(i, j, k, 1)*fmzd + sk(i, j, k&
&         , 3)*fmxd
        skd(i, j, k, 3) = skd(i, j, k, 3) + tauzz*fmzd + tauyz*fmyd + &
&         tauxz*fmxd
        skd(i, j, k, 2) = skd(i, j, k, 2) + tauyz*fmzd + tauyy*fmyd + &
&         tauxy*fmxd
        skd(i, j, k, 1) = skd(i, j, k, 1) + tauxz*fmzd + tauxy*fmyd + &
&         tauxx*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
        call popcontrol1b(branch)
        if (branch .eq. 0) then
          eyzd = -tauyzd
          exzd = -tauxzd
          tempd0 = fact*eyzd
          tauxzsd = mut*tauxzd + wyx*tempd0
          tauxysd = mut*tauxyd + wzx*tempd0
          tauzzsd = mut*tauzzd + wyz*tempd0
          tauyysd = mut*tauyyd + wzy*tempd0
          wyxd = tauxzs*tempd0
          wyzd = tauzzs*tempd0
          wzxd = tauxys*tempd0
          wzyd = tauyys*tempd0
          tempd0 = fact*exzd
          mutd = tauyzs*tauyzd + tauxzs*tauxzd + tauxys*tauxyd + tauzzs*&
&           tauzzd + tauyys*tauyyd + tauxxs*tauxxd
          tauyzsd = mut*tauyzd + wxy*tempd0
          exyd = -tauxyd
          ezzd = -tauzzd
          eyyd = -tauyyd
          tauxxsd = mut*tauxxd + wzx*tempd0
          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*tempd0
          wxzd = tauzzs*tempd0
          tauzzsd = tauzzsd + wxz*tempd0
          wzxd = wzxd + tauxxs*tempd0
          wzyd = wzyd + tauxys*tempd0
          tauxysd = tauxysd + wzy*tempd0
          tempd0 = fact*exyd
          wxyd = wxyd + tauyys*tempd0
          tauyysd = tauyysd + wxy*tempd0
          wxzd = wxzd + tauyzs*tempd0
          tauyzsd = tauyzsd + wxz*tempd0
          wyxd = wyxd + tauxxs*tempd0
          tauxxsd = tauxxsd + wyx*tempd0
          wyzd = wyzd + tauxzs*tempd0
          tauxzsd = tauxzsd + wyz*tempd0
          tempd0 = fact*two*ezzd
          wzxd = wzxd + tauxzs*tempd0
          tauxzsd = tauxzsd + wzx*tempd0
          wzyd = wzyd + tauyzs*tempd0
          tauyzsd = tauyzsd + wzy*tempd0
          tempd0 = fact*two*eyyd
          wyxd = wyxd + tauxys*tempd0
          tauxysd = tauxysd + wyx*tempd0
          wyzd = wyzd + tauyzs*tempd0 - wzyd
          tauyzsd = tauyzsd + wyz*tempd0
          tempd0 = fact*two*exxd
          wxyd = wxyd + tauxys*tempd0 - wyxd
          tauxysd = tauxysd + wxy*tempd0
          wxzd = wxzd + tauxzs*tempd0 - wzxd
          tauxzsd = tauxzsd + wxz*tempd0
          v_zd = wyzd
          w_yd = -wyzd
          u_zd = wxzd
          w_xd = -wxzd
          u_yd = wxyd
          v_xd = -wxyd
          tempd0 = ccr1*factd/den
          mued = mued + tempd0
          dend = -(mue*tempd0/den)
          call popcontrol1b(branch)
          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
            tempd0 = 0.0_8
          else
            tempd0 = 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*tempd0
          u_yd = u_yd + 2*u_y*tempd0
          u_zd = u_zd + 2*u_z*tempd0
          v_xd = v_xd + 2*v_x*tempd0
          v_yd = 2*v_y*tempd0
          v_zd = v_zd + 2*v_z*tempd0
          w_xd = w_xd + 2*w_x*tempd0
          w_yd = w_yd + 2*w_y*tempd0
          w_zd = 2*w_z*tempd0
        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
        tempd0 = twothird*fracdivd
        call popreal8(q_z)
        call popreal8(q_y)
        call popreal8(q_x)
        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 + tempd0
        v_yd = v_yd + two*tauyysd + tempd0
        u_xd = u_xd + two*tauxxsd + tempd0
        call popreal8(q_z)
        corrd = -(ssz*q_zd) - ssy*q_yd - ssx*q_xd
        sszd = q_z*corrd - corr*q_zd
        call popreal8(q_y)
        ssyd = q_y*corrd - corr*q_yd
        call popreal8(q_x)
        ssxd = q_x*corrd - corr*q_xd
        call popreal8(corr)
        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
        ssd = (aa(i, j, k+1)-aa(i, j, k))*corrd
        call popreal8(w_z)
        corrd = -(ssz*w_zd) - ssy*w_yd - ssx*w_xd
        sszd = sszd + w_z*corrd - corr*w_zd
        call popreal8(w_y)
        ssyd = ssyd + w_y*corrd - corr*w_yd
        call popreal8(w_x)
        ssxd = ssxd + w_x*corrd - corr*w_xd
        call popreal8(corr)
        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
        ssd = ssd - (w(i, j, k+1, ivz)-w(i, j, k, ivz))*corrd
        call popreal8(v_z)
        corrd = -(ssz*v_zd) - ssy*v_yd - ssx*v_xd
        sszd = sszd + v_z*corrd - corr*v_zd
        call popreal8(v_y)
        ssyd = ssyd + v_y*corrd - corr*v_yd
        call popreal8(v_x)
        ssxd = ssxd + v_x*corrd - corr*v_xd
        call popreal8(corr)
        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
        ssd = ssd - (w(i, j, k+1, ivy)-w(i, j, k, ivy))*corrd
        call popreal8(u_z)
        corrd = -(ssz*u_zd) - ssy*u_yd - ssx*u_xd
        sszd = sszd + u_z*corrd - corr*u_zd
        call popreal8(u_y)
        ssyd = ssyd + u_y*corrd - corr*u_yd
        call popreal8(u_x)
        ssxd = ssxd + u_x*corrd - corr*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
        call popreal8(ssz)
        call popreal8(ssy)
        call popreal8(ssx)
        ssd = ssd + ssz*sszd - (w(i, j, k+1, ivx)-w(i, j, k, ivx))*corrd&
&         + ssy*ssyd + ssx*ssxd
        temp = ssx*ssx + ssy*ssy + ssz*ssz
        temp0 = sqrt(temp)
        if (temp .eq. 0.0_8) then
          tempd = 0.0_8
        else
          tempd = -(one*ssd/(2.0*temp0**3))
        end if
        sszd = ss*sszd + 2*ssz*tempd
        ssyd = ss*ssyd + 2*ssy*tempd
        ssxd = ss*ssxd + 2*ssx*tempd
        tempd = eighth*sszd
        xd(i-1, j-1, k+1, 3) = xd(i-1, j-1, k+1, 3) + tempd
        xd(i-1, j-1, k-1, 3) = xd(i-1, j-1, k-1, 3) - tempd
        xd(i-1, j, k+1, 3) = xd(i-1, j, k+1, 3) + tempd
        xd(i-1, j, k-1, 3) = xd(i-1, j, k-1, 3) - tempd
        xd(i, j-1, k+1, 3) = xd(i, j-1, k+1, 3) + tempd
        xd(i, j-1, k-1, 3) = xd(i, j-1, k-1, 3) - tempd
        xd(i, j, k+1, 3) = xd(i, j, k+1, 3) + tempd
        xd(i, j, k-1, 3) = xd(i, j, k-1, 3) - tempd
        tempd = eighth*ssyd
        xd(i-1, j-1, k+1, 2) = xd(i-1, j-1, k+1, 2) + tempd
        xd(i-1, j-1, k-1, 2) = xd(i-1, j-1, k-1, 2) - tempd
        xd(i-1, j, k+1, 2) = xd(i-1, j, k+1, 2) + tempd
        xd(i-1, j, k-1, 2) = xd(i-1, j, k-1, 2) - tempd
        xd(i, j-1, k+1, 2) = xd(i, j-1, k+1, 2) + tempd
        xd(i, j-1, k-1, 2) = xd(i, j-1, k-1, 2) - tempd
        xd(i, j, k+1, 2) = xd(i, j, k+1, 2) + tempd
        xd(i, j, k-1, 2) = xd(i, j, k-1, 2) - tempd
        tempd = eighth*ssxd
        xd(i-1, j-1, k+1, 1) = xd(i-1, j-1, k+1, 1) + tempd
        xd(i-1, j-1, k-1, 1) = xd(i-1, j-1, k-1, 1) - tempd
        xd(i-1, j, k+1, 1) = xd(i-1, j, k+1, 1) + tempd
        xd(i-1, j, k-1, 1) = xd(i-1, j, k-1, 1) - tempd
        xd(i, j-1, k+1, 1) = xd(i, j-1, k+1, 1) + tempd
        xd(i, j-1, k-1, 1) = xd(i, j-1, k-1, 1) - tempd
        xd(i, j, k+1, 1) = xd(i, j, k+1, 1) + tempd
        xd(i, j, k-1, 1) = xd(i, j, k-1, 1) - tempd
        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
        call popcontrol1b(branch)
        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
      call popcontrol1b(branch)
    end if
  end subroutine viscousflux_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
 
!  differentiation of viscousfluxapprox in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: *w *x *fw
!   with respect to varying inputs: *rev *aa *w *x *rlv *si *sj
!                *sk *fw
!   rw status of diff variables: *rev:out *aa:out *w:incr *x:incr
!                *rlv:out *si:out *sj:out *sk:out *fw:in-out
!   plus diff mem management of: rev:in aa:in w:in x:in rlv:in
!                si:in sj:in sk:in fw:in
  subroutine viscousfluxapprox_b()
    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) :: 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) :: ssxd, ssyd, sszd, ssd, 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) :: fmx, fmy, fmz, frhoe
    real(kind=realtype) :: fmxd, fmyd, fmzd, frhoed
    real(kind=realtype) :: dd
    real(kind=realtype) :: ddd
    logical :: correctfork
    real(kind=realtype) :: temp
    real(kind=realtype) :: tempd
    real(kind=realtype) :: tempd0
    real(kind=realtype) :: temp0
    real(kind=realtype) :: tempd1
    integer :: branch
    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
          call pushreal8(ssx)
          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))
          call pushreal8(ssy)
          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))
          call pushreal8(ssz)
          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
          call pushreal8(ss)
          ss = one/(ssx*ssx+ssy*ssy+ssz*ssz)
          call pushreal8(ssx)
          ssx = ss*ssx
          call pushreal8(ssy)
          ssy = ss*ssy
          call pushreal8(ssz)
          ssz = ss*ssz
! now compute each gradient
          dd = w(i+1, j, k, ivx) - w(i, j, k, ivx)
          call pushreal8(u_x)
          u_x = dd*ssx
          call pushreal8(u_y)
          u_y = dd*ssy
          call pushreal8(u_z)
          u_z = dd*ssz
          dd = w(i+1, j, k, ivy) - w(i, j, k, ivy)
          call pushreal8(v_x)
          v_x = dd*ssx
          call pushreal8(v_y)
          v_y = dd*ssy
          call pushreal8(v_z)
          v_z = dd*ssz
          dd = w(i+1, j, k, ivz) - w(i, j, k, ivz)
          call pushreal8(w_x)
          w_x = dd*ssx
          call pushreal8(w_y)
          w_y = dd*ssy
          call pushreal8(w_z)
          w_z = dd*ssz
          dd = aa(i+1, j, k) - aa(i, j, k)
          call pushreal8(q_x)
          q_x = -(dd*ssx)
          call pushreal8(q_y)
          q_y = -(dd*ssy)
          call pushreal8(q_z)
          q_z = -(dd*ssz)
          call pushreal8(por)
          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) then
            mue = por*(rev(i, j, k)+rev(i+1, j, k))
            call pushcontrol1b(0)
          else
            call pushcontrol1b(1)
          end if
          call pushreal8(mut)
          mut = mul + mue
          gm1 = half*(gamma(i, j, k)+gamma(i+1, j, k)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          call pushreal8(heatcoef)
          heatcoef = mul*factlamheat + mue*factturbheat
! compute the stress tensor and the heat flux vector.
          call pushreal8(fracdiv)
          fracdiv = twothird*(u_x+v_y+w_z)
          call pushreal8(q_x)
          q_x = heatcoef*q_x
          call pushreal8(q_y)
          q_y = heatcoef*q_y
          call pushreal8(q_z)
          q_z = heatcoef*q_z
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
! compute the viscous fluxes for this i-face.
! update the residuals of cell i and i+1.
        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
          call pushreal8(ssx)
          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))
          call pushreal8(ssy)
          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))
          call pushreal8(ssz)
          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
          call pushreal8(ss)
          ss = one/(ssx*ssx+ssy*ssy+ssz*ssz)
          call pushreal8(ssx)
          ssx = ss*ssx
          call pushreal8(ssy)
          ssy = ss*ssy
          call pushreal8(ssz)
          ssz = ss*ssz
! now compute each gradient
          dd = w(i, j+1, k, ivx) - w(i, j, k, ivx)
          call pushreal8(u_x)
          u_x = dd*ssx
          call pushreal8(u_y)
          u_y = dd*ssy
          call pushreal8(u_z)
          u_z = dd*ssz
          dd = w(i, j+1, k, ivy) - w(i, j, k, ivy)
          call pushreal8(v_x)
          v_x = dd*ssx
          call pushreal8(v_y)
          v_y = dd*ssy
          call pushreal8(v_z)
          v_z = dd*ssz
          dd = w(i, j+1, k, ivz) - w(i, j, k, ivz)
          call pushreal8(w_x)
          w_x = dd*ssx
          call pushreal8(w_y)
          w_y = dd*ssy
          call pushreal8(w_z)
          w_z = dd*ssz
          dd = aa(i, j+1, k) - aa(i, j, k)
          call pushreal8(q_x)
          q_x = -(dd*ssx)
          call pushreal8(q_y)
          q_y = -(dd*ssy)
          call pushreal8(q_z)
          q_z = -(dd*ssz)
          call pushreal8(por)
          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))
            call pushcontrol1b(0)
          else
            call pushcontrol1b(1)
          end if
          call pushreal8(mut)
          mut = mul + mue
          gm1 = half*(gamma(i, j, k)+gamma(i, j+1, k)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          call pushreal8(heatcoef)
          heatcoef = mul*factlamheat + mue*factturbheat
! compute the stress tensor and the heat flux vector.
          call pushreal8(fracdiv)
          fracdiv = twothird*(u_x+v_y+w_z)
          call pushreal8(q_x)
          q_x = heatcoef*q_x
          call pushreal8(q_y)
          q_y = heatcoef*q_y
          call pushreal8(q_z)
          q_z = heatcoef*q_z
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
! compute the viscous fluxes for this j-face.
! update the residuals of cell j and j+1.
        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
          call pushreal8(ssx)
          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))
          call pushreal8(ssy)
          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))
          call pushreal8(ssz)
          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
          call pushreal8(ss)
          ss = one/(ssx*ssx+ssy*ssy+ssz*ssz)
          call pushreal8(ssx)
          ssx = ss*ssx
          call pushreal8(ssy)
          ssy = ss*ssy
          call pushreal8(ssz)
          ssz = ss*ssz
! now compute each gradient
          dd = w(i, j, k+1, ivx) - w(i, j, k, ivx)
          call pushreal8(u_x)
          u_x = dd*ssx
          call pushreal8(u_y)
          u_y = dd*ssy
          call pushreal8(u_z)
          u_z = dd*ssz
          dd = w(i, j, k+1, ivy) - w(i, j, k, ivy)
          call pushreal8(v_x)
          v_x = dd*ssx
          call pushreal8(v_y)
          v_y = dd*ssy
          call pushreal8(v_z)
          v_z = dd*ssz
          dd = w(i, j, k+1, ivz) - w(i, j, k, ivz)
          call pushreal8(w_x)
          w_x = dd*ssx
          call pushreal8(w_y)
          w_y = dd*ssy
          call pushreal8(w_z)
          w_z = dd*ssz
          dd = aa(i, j, k+1) - aa(i, j, k)
          call pushreal8(q_x)
          q_x = -(dd*ssx)
          call pushreal8(q_y)
          q_y = -(dd*ssy)
          call pushreal8(q_z)
          q_z = -(dd*ssz)
          call pushreal8(por)
          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))
            call pushcontrol1b(0)
          else
            call pushcontrol1b(1)
          end if
          call pushreal8(mut)
          mut = mul + mue
          gm1 = half*(gamma(i, j, k)+gamma(i, j, k+1)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          call pushreal8(heatcoef)
          heatcoef = mul*factlamheat + mue*factturbheat
! compute the stress tensor and the heat flux vector.
          call pushreal8(fracdiv)
          fracdiv = twothird*(u_x+v_y+w_z)
          call pushreal8(q_x)
          q_x = heatcoef*q_x
          call pushreal8(q_y)
          q_y = heatcoef*q_y
          call pushreal8(q_z)
          q_z = heatcoef*q_z
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
! compute the viscous fluxes for this j-face.
! update the residuals of cell j and j+1.
        end do
      end do
    end do
    if (associated(revd)) revd = 0.0_8
    if (associated(aad)) aad = 0.0_8
    if (associated(rlvd)) rlvd = 0.0_8
    if (associated(skd)) skd = 0.0_8
    mued = 0.0_8
    do k=kl,1,-1
      do j=jl,2,-1
        do i=il,2,-1
          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)
          tauzz = mut*(two*w_z-fracdiv)
          wbar = half*(w(i, j, k, ivz)+w(i, j, k+1, ivz))
          vbar = half*(w(i, j, k, ivy)+w(i, j, k+1, ivy))
          tauxx = mut*(two*u_x-fracdiv)
          tauxy = mut*(u_y+v_x)
          tauxz = mut*(u_z+w_x)
          ubar = half*(w(i, j, k, ivx)+w(i, j, k+1, ivx))
          tauyy = mut*(two*v_y-fracdiv)
          tauyz = mut*(v_z+w_y)
          tempd1 = sk(i, j, k, 1)*frhoed
          tempd0 = sk(i, j, k, 2)*frhoed
          tempd = sk(i, j, k, 3)*frhoed
          skd(i, j, k, 3) = skd(i, j, k, 3) + (ubar*tauxz+vbar*tauyz+&
&           wbar*tauzz-q_z)*frhoed + tauzz*fmzd + tauyz*fmyd + tauxz*&
&           fmxd
          skd(i, j, k, 2) = skd(i, j, k, 2) + (ubar*tauxy+vbar*tauyy+&
&           wbar*tauyz-q_y)*frhoed + tauyz*fmzd + tauyy*fmyd + tauxy*&
&           fmxd
          skd(i, j, k, 1) = skd(i, j, k, 1) + (ubar*tauxx+vbar*tauxy+&
&           wbar*tauxz-q_x)*frhoed + tauxz*fmzd + tauxy*fmyd + tauxx*&
&           fmxd
          q_xd = -(sk(i, j, k, 1)*frhoed)
          q_yd = -(sk(i, j, k, 2)*frhoed)
          q_zd = -(sk(i, j, k, 3)*frhoed)
          ubard = tauxz*tempd + tauxy*tempd0 + tauxx*tempd1
          tauxzd = ubar*tempd + wbar*tempd1 + sk(i, j, k, 1)*fmzd + sk(i&
&           , j, k, 3)*fmxd
          vbard = tauyz*tempd + tauyy*tempd0 + tauxy*tempd1
          tauyzd = vbar*tempd + wbar*tempd0 + sk(i, j, k, 2)*fmzd + sk(i&
&           , j, k, 3)*fmyd
          wbard = tauzz*tempd + tauyz*tempd0 + tauxz*tempd1
          tauzzd = wbar*tempd + sk(i, j, k, 3)*fmzd
          tauxyd = ubar*tempd0 + vbar*tempd1 + sk(i, j, k, 1)*fmyd + sk(&
&           i, j, k, 2)*fmxd
          tauyyd = vbar*tempd0 + sk(i, j, k, 2)*fmyd
          tauxxd = ubar*tempd1 + sk(i, j, k, 1)*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
          dd = aa(i, j, k+1) - aa(i, j, k)
          call popreal8(q_z)
          call popreal8(q_y)
          call popreal8(q_x)
          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
          mutd = (v_z+w_y)*tauyzd + (u_z+w_x)*tauxzd + (u_y+v_x)*tauxyd &
&           + (two*w_z-fracdiv)*tauzzd + (two*v_y-fracdiv)*tauyyd + (two&
&           *u_x-fracdiv)*tauxxd
          v_zd = mut*tauyzd
          w_yd = mut*tauyzd
          u_zd = mut*tauxzd
          w_xd = mut*tauxzd
          u_yd = mut*tauxyd
          v_xd = mut*tauxyd
          fracdivd = -(mut*tauzzd) - mut*tauyyd - mut*tauxxd
          call popreal8(fracdiv)
          tempd1 = twothird*fracdivd
          w_zd = two*mut*tauzzd + tempd1
          v_yd = two*mut*tauyyd + tempd1
          u_xd = two*mut*tauxxd + tempd1
          gm1 = half*(gamma(i, j, k)+gamma(i, j, k+1)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          call popreal8(heatcoef)
          muld = factlamheat*heatcoefd + mutd
          mued = mued + factturbheat*heatcoefd + mutd
          call popreal8(mut)
          call popcontrol1b(branch)
          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
          call popreal8(por)
          call popreal8(q_z)
          ddd = -(ssz*q_zd) - ssy*q_yd - ssx*q_xd
          sszd = -(dd*q_zd)
          call popreal8(q_y)
          ssyd = -(dd*q_yd)
          call popreal8(q_x)
          ssxd = -(dd*q_xd)
          aad(i, j, k+1) = aad(i, j, k+1) + ddd
          aad(i, j, k) = aad(i, j, k) - ddd
          dd = w(i, j, k+1, ivz) - w(i, j, k, ivz)
          call popreal8(w_z)
          ddd = ssz*w_zd + ssy*w_yd + ssx*w_xd
          sszd = sszd + dd*w_zd
          call popreal8(w_y)
          ssyd = ssyd + dd*w_yd
          call popreal8(w_x)
          ssxd = ssxd + dd*w_xd
          wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + ddd
          wd(i, j, k, ivz) = wd(i, j, k, ivz) - ddd
          dd = w(i, j, k+1, ivy) - w(i, j, k, ivy)
          call popreal8(v_z)
          ddd = ssz*v_zd + ssy*v_yd + ssx*v_xd
          sszd = sszd + dd*v_zd
          call popreal8(v_y)
          ssyd = ssyd + dd*v_yd
          call popreal8(v_x)
          ssxd = ssxd + dd*v_xd
          wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + ddd
          wd(i, j, k, ivy) = wd(i, j, k, ivy) - ddd
          dd = w(i, j, k+1, ivx) - w(i, j, k, ivx)
          call popreal8(u_z)
          ddd = ssz*u_zd + ssy*u_yd + ssx*u_xd
          sszd = sszd + dd*u_zd
          call popreal8(u_y)
          ssyd = ssyd + dd*u_yd
          call popreal8(u_x)
          ssxd = ssxd + dd*u_xd
          wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + ddd
          wd(i, j, k, ivx) = wd(i, j, k, ivx) - ddd
          call popreal8(ssz)
          call popreal8(ssy)
          call popreal8(ssx)
          ssd = ssz*sszd + ssy*ssyd + ssx*ssxd
          temp0 = ssx*ssx + ssy*ssy + ssz*ssz
          tempd1 = -(one*ssd/temp0**2)
          sszd = ss*sszd + 2*ssz*tempd1
          ssyd = ss*ssyd + 2*ssy*tempd1
          ssxd = ss*ssxd + 2*ssx*tempd1
          call popreal8(ss)
          call popreal8(ssz)
          tempd1 = eighth*sszd
          xd(i-1, j-1, k+1, 3) = xd(i-1, j-1, k+1, 3) + tempd1
          xd(i-1, j-1, k-1, 3) = xd(i-1, j-1, k-1, 3) - tempd1
          xd(i-1, j, k+1, 3) = xd(i-1, j, k+1, 3) + tempd1
          xd(i-1, j, k-1, 3) = xd(i-1, j, k-1, 3) - tempd1
          xd(i, j-1, k+1, 3) = xd(i, j-1, k+1, 3) + tempd1
          xd(i, j-1, k-1, 3) = xd(i, j-1, k-1, 3) - tempd1
          xd(i, j, k+1, 3) = xd(i, j, k+1, 3) + tempd1
          xd(i, j, k-1, 3) = xd(i, j, k-1, 3) - tempd1
          call popreal8(ssy)
          tempd1 = eighth*ssyd
          xd(i-1, j-1, k+1, 2) = xd(i-1, j-1, k+1, 2) + tempd1
          xd(i-1, j-1, k-1, 2) = xd(i-1, j-1, k-1, 2) - tempd1
          xd(i-1, j, k+1, 2) = xd(i-1, j, k+1, 2) + tempd1
          xd(i-1, j, k-1, 2) = xd(i-1, j, k-1, 2) - tempd1
          xd(i, j-1, k+1, 2) = xd(i, j-1, k+1, 2) + tempd1
          xd(i, j-1, k-1, 2) = xd(i, j-1, k-1, 2) - tempd1
          xd(i, j, k+1, 2) = xd(i, j, k+1, 2) + tempd1
          xd(i, j, k-1, 2) = xd(i, j, k-1, 2) - tempd1
          call popreal8(ssx)
          tempd1 = eighth*ssxd
          xd(i-1, j-1, k+1, 1) = xd(i-1, j-1, k+1, 1) + tempd1
          xd(i-1, j-1, k-1, 1) = xd(i-1, j-1, k-1, 1) - tempd1
          xd(i-1, j, k+1, 1) = xd(i-1, j, k+1, 1) + tempd1
          xd(i-1, j, k-1, 1) = xd(i-1, j, k-1, 1) - tempd1
          xd(i, j-1, k+1, 1) = xd(i, j-1, k+1, 1) + tempd1
          xd(i, j-1, k-1, 1) = xd(i, j-1, k-1, 1) - tempd1
          xd(i, j, k+1, 1) = xd(i, j, k+1, 1) + tempd1
          xd(i, j, k-1, 1) = xd(i, j, k-1, 1) - tempd1
        end do
      end do
    end do
    if (associated(sjd)) sjd = 0.0_8
    do k=kl,2,-1
      do j=jl,1,-1
        do i=il,2,-1
          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)
          tauzz = mut*(two*w_z-fracdiv)
          wbar = half*(w(i, j, k, ivz)+w(i, j+1, k, ivz))
          vbar = half*(w(i, j, k, ivy)+w(i, j+1, k, ivy))
          tauxx = mut*(two*u_x-fracdiv)
          tauxy = mut*(u_y+v_x)
          tauxz = mut*(u_z+w_x)
          ubar = half*(w(i, j, k, ivx)+w(i, j+1, k, ivx))
          tauyy = mut*(two*v_y-fracdiv)
          tauyz = mut*(v_z+w_y)
          tempd1 = sj(i, j, k, 1)*frhoed
          tempd0 = sj(i, j, k, 2)*frhoed
          tempd = sj(i, j, k, 3)*frhoed
          sjd(i, j, k, 3) = sjd(i, j, k, 3) + (ubar*tauxz+vbar*tauyz+&
&           wbar*tauzz-q_z)*frhoed + tauzz*fmzd + tauyz*fmyd + tauxz*&
&           fmxd
          sjd(i, j, k, 2) = sjd(i, j, k, 2) + (ubar*tauxy+vbar*tauyy+&
&           wbar*tauyz-q_y)*frhoed + tauyz*fmzd + tauyy*fmyd + tauxy*&
&           fmxd
          sjd(i, j, k, 1) = sjd(i, j, k, 1) + (ubar*tauxx+vbar*tauxy+&
&           wbar*tauxz-q_x)*frhoed + tauxz*fmzd + tauxy*fmyd + tauxx*&
&           fmxd
          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*tempd + tauxy*tempd0 + tauxx*tempd1
          tauxzd = ubar*tempd + wbar*tempd1 + sj(i, j, k, 1)*fmzd + sj(i&
&           , j, k, 3)*fmxd
          vbard = tauyz*tempd + tauyy*tempd0 + tauxy*tempd1
          tauyzd = vbar*tempd + wbar*tempd0 + sj(i, j, k, 2)*fmzd + sj(i&
&           , j, k, 3)*fmyd
          wbard = tauzz*tempd + tauyz*tempd0 + tauxz*tempd1
          tauzzd = wbar*tempd + sj(i, j, k, 3)*fmzd
          tauxyd = ubar*tempd0 + vbar*tempd1 + sj(i, j, k, 1)*fmyd + sj(&
&           i, j, k, 2)*fmxd
          tauyyd = vbar*tempd0 + sj(i, j, k, 2)*fmyd
          tauxxd = ubar*tempd1 + 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
          dd = aa(i, j+1, k) - aa(i, j, k)
          call popreal8(q_z)
          call popreal8(q_y)
          call popreal8(q_x)
          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
          mutd = (v_z+w_y)*tauyzd + (u_z+w_x)*tauxzd + (u_y+v_x)*tauxyd &
&           + (two*w_z-fracdiv)*tauzzd + (two*v_y-fracdiv)*tauyyd + (two&
&           *u_x-fracdiv)*tauxxd
          v_zd = mut*tauyzd
          w_yd = mut*tauyzd
          u_zd = mut*tauxzd
          w_xd = mut*tauxzd
          u_yd = mut*tauxyd
          v_xd = mut*tauxyd
          fracdivd = -(mut*tauzzd) - mut*tauyyd - mut*tauxxd
          call popreal8(fracdiv)
          tempd1 = twothird*fracdivd
          w_zd = two*mut*tauzzd + tempd1
          v_yd = two*mut*tauyyd + tempd1
          u_xd = two*mut*tauxxd + tempd1
          gm1 = half*(gamma(i, j, k)+gamma(i, j+1, k)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          call popreal8(heatcoef)
          muld = factlamheat*heatcoefd + mutd
          mued = mued + factturbheat*heatcoefd + mutd
          call popreal8(mut)
          call popcontrol1b(branch)
          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
          call popreal8(por)
          call popreal8(q_z)
          ddd = -(ssz*q_zd) - ssy*q_yd - ssx*q_xd
          sszd = -(dd*q_zd)
          call popreal8(q_y)
          ssyd = -(dd*q_yd)
          call popreal8(q_x)
          ssxd = -(dd*q_xd)
          aad(i, j+1, k) = aad(i, j+1, k) + ddd
          aad(i, j, k) = aad(i, j, k) - ddd
          dd = w(i, j+1, k, ivz) - w(i, j, k, ivz)
          call popreal8(w_z)
          ddd = ssz*w_zd + ssy*w_yd + ssx*w_xd
          sszd = sszd + dd*w_zd
          call popreal8(w_y)
          ssyd = ssyd + dd*w_yd
          call popreal8(w_x)
          ssxd = ssxd + dd*w_xd
          wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + ddd
          wd(i, j, k, ivz) = wd(i, j, k, ivz) - ddd
          dd = w(i, j+1, k, ivy) - w(i, j, k, ivy)
          call popreal8(v_z)
          ddd = ssz*v_zd + ssy*v_yd + ssx*v_xd
          sszd = sszd + dd*v_zd
          call popreal8(v_y)
          ssyd = ssyd + dd*v_yd
          call popreal8(v_x)
          ssxd = ssxd + dd*v_xd
          wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + ddd
          wd(i, j, k, ivy) = wd(i, j, k, ivy) - ddd
          dd = w(i, j+1, k, ivx) - w(i, j, k, ivx)
          call popreal8(u_z)
          ddd = ssz*u_zd + ssy*u_yd + ssx*u_xd
          sszd = sszd + dd*u_zd
          call popreal8(u_y)
          ssyd = ssyd + dd*u_yd
          call popreal8(u_x)
          ssxd = ssxd + dd*u_xd
          wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + ddd
          wd(i, j, k, ivx) = wd(i, j, k, ivx) - ddd
          call popreal8(ssz)
          call popreal8(ssy)
          call popreal8(ssx)
          ssd = ssz*sszd + ssy*ssyd + ssx*ssxd
          temp0 = ssx*ssx + ssy*ssy + ssz*ssz
          tempd1 = -(one*ssd/temp0**2)
          sszd = ss*sszd + 2*ssz*tempd1
          ssyd = ss*ssyd + 2*ssy*tempd1
          ssxd = ss*ssxd + 2*ssx*tempd1
          call popreal8(ss)
          call popreal8(ssz)
          tempd1 = eighth*sszd
          xd(i-1, j+1, k-1, 3) = xd(i-1, j+1, k-1, 3) + tempd1
          xd(i-1, j-1, k-1, 3) = xd(i-1, j-1, k-1, 3) - tempd1
          xd(i-1, j+1, k, 3) = xd(i-1, j+1, k, 3) + tempd1
          xd(i-1, j-1, k, 3) = xd(i-1, j-1, k, 3) - tempd1
          xd(i, j+1, k-1, 3) = xd(i, j+1, k-1, 3) + tempd1
          xd(i, j-1, k-1, 3) = xd(i, j-1, k-1, 3) - tempd1
          xd(i, j+1, k, 3) = xd(i, j+1, k, 3) + tempd1
          xd(i, j-1, k, 3) = xd(i, j-1, k, 3) - tempd1
          call popreal8(ssy)
          tempd1 = eighth*ssyd
          xd(i-1, j+1, k-1, 2) = xd(i-1, j+1, k-1, 2) + tempd1
          xd(i-1, j-1, k-1, 2) = xd(i-1, j-1, k-1, 2) - tempd1
          xd(i-1, j+1, k, 2) = xd(i-1, j+1, k, 2) + tempd1
          xd(i-1, j-1, k, 2) = xd(i-1, j-1, k, 2) - tempd1
          xd(i, j+1, k-1, 2) = xd(i, j+1, k-1, 2) + tempd1
          xd(i, j-1, k-1, 2) = xd(i, j-1, k-1, 2) - tempd1
          xd(i, j+1, k, 2) = xd(i, j+1, k, 2) + tempd1
          xd(i, j-1, k, 2) = xd(i, j-1, k, 2) - tempd1
          call popreal8(ssx)
          tempd1 = eighth*ssxd
          xd(i-1, j+1, k-1, 1) = xd(i-1, j+1, k-1, 1) + tempd1
          xd(i-1, j-1, k-1, 1) = xd(i-1, j-1, k-1, 1) - tempd1
          xd(i-1, j+1, k, 1) = xd(i-1, j+1, k, 1) + tempd1
          xd(i-1, j-1, k, 1) = xd(i-1, j-1, k, 1) - tempd1
          xd(i, j+1, k-1, 1) = xd(i, j+1, k-1, 1) + tempd1
          xd(i, j-1, k-1, 1) = xd(i, j-1, k-1, 1) - tempd1
          xd(i, j+1, k, 1) = xd(i, j+1, k, 1) + tempd1
          xd(i, j-1, k, 1) = xd(i, j-1, k, 1) - tempd1
        end do
      end do
    end do
    if (associated(sid)) sid = 0.0_8
    do k=kl,2,-1
      do j=jl,2,-1
        do i=il,1,-1
          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)
          tauzz = mut*(two*w_z-fracdiv)
          wbar = half*(w(i, j, k, ivz)+w(i+1, j, k, ivz))
          vbar = half*(w(i, j, k, ivy)+w(i+1, j, k, ivy))
          tauxx = mut*(two*u_x-fracdiv)
          tauxy = mut*(u_y+v_x)
          tauxz = mut*(u_z+w_x)
          ubar = half*(w(i, j, k, ivx)+w(i+1, j, k, ivx))
          tauyy = mut*(two*v_y-fracdiv)
          tauyz = mut*(v_z+w_y)
          tempd = si(i, j, k, 1)*frhoed
          tempd0 = si(i, j, k, 2)*frhoed
          tempd1 = si(i, j, k, 3)*frhoed
          sid(i, j, k, 3) = sid(i, j, k, 3) + (ubar*tauxz+vbar*tauyz+&
&           wbar*tauzz-q_z)*frhoed + tauzz*fmzd + tauyz*fmyd + tauxz*&
&           fmxd
          sid(i, j, k, 2) = sid(i, j, k, 2) + (ubar*tauxy+vbar*tauyy+&
&           wbar*tauyz-q_y)*frhoed + tauyz*fmzd + tauyy*fmyd + tauxy*&
&           fmxd
          sid(i, j, k, 1) = sid(i, j, k, 1) + (ubar*tauxx+vbar*tauxy+&
&           wbar*tauxz-q_x)*frhoed + tauxz*fmzd + tauxy*fmyd + tauxx*&
&           fmxd
          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*tempd1 + tauxy*tempd0 + tauxx*tempd
          tauxzd = ubar*tempd1 + wbar*tempd + si(i, j, k, 1)*fmzd + si(i&
&           , j, k, 3)*fmxd
          vbard = tauyz*tempd1 + tauyy*tempd0 + tauxy*tempd
          tauyzd = vbar*tempd1 + wbar*tempd0 + si(i, j, k, 2)*fmzd + si(&
&           i, j, k, 3)*fmyd
          wbard = tauzz*tempd1 + tauyz*tempd0 + tauxz*tempd
          tauzzd = wbar*tempd1 + si(i, j, k, 3)*fmzd
          tauxyd = ubar*tempd0 + vbar*tempd + si(i, j, k, 1)*fmyd + si(i&
&           , j, k, 2)*fmxd
          tauyyd = vbar*tempd0 + si(i, j, k, 2)*fmyd
          tauxxd = ubar*tempd + 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
          dd = aa(i+1, j, k) - aa(i, j, k)
          call popreal8(q_z)
          call popreal8(q_y)
          call popreal8(q_x)
          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
          mutd = (v_z+w_y)*tauyzd + (u_z+w_x)*tauxzd + (u_y+v_x)*tauxyd &
&           + (two*w_z-fracdiv)*tauzzd + (two*v_y-fracdiv)*tauyyd + (two&
&           *u_x-fracdiv)*tauxxd
          v_zd = mut*tauyzd
          w_yd = mut*tauyzd
          u_zd = mut*tauxzd
          w_xd = mut*tauxzd
          u_yd = mut*tauxyd
          v_xd = mut*tauxyd
          fracdivd = -(mut*tauzzd) - mut*tauyyd - mut*tauxxd
          call popreal8(fracdiv)
          tempd = twothird*fracdivd
          w_zd = two*mut*tauzzd + tempd
          v_yd = two*mut*tauyyd + tempd
          u_xd = two*mut*tauxxd + tempd
          gm1 = half*(gamma(i, j, k)+gamma(i+1, j, k)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          call popreal8(heatcoef)
          muld = factlamheat*heatcoefd + mutd
          mued = mued + factturbheat*heatcoefd + mutd
          call popreal8(mut)
          call popcontrol1b(branch)
          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
          call popreal8(por)
          call popreal8(q_z)
          ddd = -(ssz*q_zd) - ssy*q_yd - ssx*q_xd
          sszd = -(dd*q_zd)
          call popreal8(q_y)
          ssyd = -(dd*q_yd)
          call popreal8(q_x)
          ssxd = -(dd*q_xd)
          aad(i+1, j, k) = aad(i+1, j, k) + ddd
          aad(i, j, k) = aad(i, j, k) - ddd
          dd = w(i+1, j, k, ivz) - w(i, j, k, ivz)
          call popreal8(w_z)
          ddd = ssz*w_zd + ssy*w_yd + ssx*w_xd
          sszd = sszd + dd*w_zd
          call popreal8(w_y)
          ssyd = ssyd + dd*w_yd
          call popreal8(w_x)
          ssxd = ssxd + dd*w_xd
          wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + ddd
          wd(i, j, k, ivz) = wd(i, j, k, ivz) - ddd
          dd = w(i+1, j, k, ivy) - w(i, j, k, ivy)
          call popreal8(v_z)
          ddd = ssz*v_zd + ssy*v_yd + ssx*v_xd
          sszd = sszd + dd*v_zd
          call popreal8(v_y)
          ssyd = ssyd + dd*v_yd
          call popreal8(v_x)
          ssxd = ssxd + dd*v_xd
          wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + ddd
          wd(i, j, k, ivy) = wd(i, j, k, ivy) - ddd
          dd = w(i+1, j, k, ivx) - w(i, j, k, ivx)
          call popreal8(u_z)
          ddd = ssz*u_zd + ssy*u_yd + ssx*u_xd
          sszd = sszd + dd*u_zd
          call popreal8(u_y)
          ssyd = ssyd + dd*u_yd
          call popreal8(u_x)
          ssxd = ssxd + dd*u_xd
          wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + ddd
          wd(i, j, k, ivx) = wd(i, j, k, ivx) - ddd
          call popreal8(ssz)
          call popreal8(ssy)
          call popreal8(ssx)
          ssd = ssz*sszd + ssy*ssyd + ssx*ssxd
          temp = ssx*ssx + ssy*ssy + ssz*ssz
          tempd = -(one*ssd/temp**2)
          sszd = ss*sszd + 2*ssz*tempd
          ssyd = ss*ssyd + 2*ssy*tempd
          ssxd = ss*ssxd + 2*ssx*tempd
          call popreal8(ss)
          call popreal8(ssz)
          tempd = eighth*sszd
          xd(i+1, j-1, k-1, 3) = xd(i+1, j-1, k-1, 3) + tempd
          xd(i-1, j-1, k-1, 3) = xd(i-1, j-1, k-1, 3) - tempd
          xd(i+1, j-1, k, 3) = xd(i+1, j-1, k, 3) + tempd
          xd(i-1, j-1, k, 3) = xd(i-1, j-1, k, 3) - tempd
          xd(i+1, j, k-1, 3) = xd(i+1, j, k-1, 3) + tempd
          xd(i-1, j, k-1, 3) = xd(i-1, j, k-1, 3) - tempd
          xd(i+1, j, k, 3) = xd(i+1, j, k, 3) + tempd
          xd(i-1, j, k, 3) = xd(i-1, j, k, 3) - tempd
          call popreal8(ssy)
          tempd = eighth*ssyd
          xd(i+1, j-1, k-1, 2) = xd(i+1, j-1, k-1, 2) + tempd
          xd(i-1, j-1, k-1, 2) = xd(i-1, j-1, k-1, 2) - tempd
          xd(i+1, j-1, k, 2) = xd(i+1, j-1, k, 2) + tempd
          xd(i-1, j-1, k, 2) = xd(i-1, j-1, k, 2) - tempd
          xd(i+1, j, k-1, 2) = xd(i+1, j, k-1, 2) + tempd
          xd(i-1, j, k-1, 2) = xd(i-1, j, k-1, 2) - tempd
          xd(i+1, j, k, 2) = xd(i+1, j, k, 2) + tempd
          xd(i-1, j, k, 2) = xd(i-1, j, k, 2) - tempd
          call popreal8(ssx)
          tempd = eighth*ssxd
          xd(i+1, j-1, k-1, 1) = xd(i+1, j-1, k-1, 1) + tempd
          xd(i-1, j-1, k-1, 1) = xd(i-1, j-1, k-1, 1) - tempd
          xd(i+1, j-1, k, 1) = xd(i+1, j-1, k, 1) + tempd
          xd(i-1, j-1, k, 1) = xd(i-1, j-1, k, 1) - tempd
          xd(i+1, j, k-1, 1) = xd(i+1, j, k-1, 1) + tempd
          xd(i-1, j, k-1, 1) = xd(i-1, j, k-1, 1) - tempd
          xd(i+1, j, k, 1) = xd(i+1, j, k, 1) + tempd
          xd(i-1, j, k, 1) = xd(i-1, j, k, 1) - tempd
        end do
      end do
    end do
  end subroutine viscousfluxapprox_b
 
  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
 
!  differentiation of invisciddissfluxscalarapprox in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: *p *w *fw
!   with respect to varying inputs: rhoinf pinfcorr *p *w *fw *radi
!                *radj *radk
!   rw status of diff variables: rhoinf:out pinfcorr:out *p:incr
!                *w:in-out *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 invisciddissfluxscalarapprox_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 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) :: sslimd, rhoid
    real(kind=realtype) :: sfil, fis2, fis4
    real(kind=realtype) :: ppor, rrad, dis2
    real(kind=realtype) :: rradd, dis2d
    real(kind=realtype) :: dss1, dss2, ddw, fs
    real(kind=realtype) :: dss1d, dss2d, ddwd, fsd
    intrinsic abs
    intrinsic log10
    intrinsic exp
    intrinsic max
    intrinsic min
    real(kind=realtype) :: x1
    real(kind=realtype) :: x1d
    real(kind=realtype) :: x2
    real(kind=realtype) :: x2d
    real(kind=realtype) :: y1
    real(kind=realtype) :: y1d
    real(kind=realtype) :: x3
    real(kind=realtype) :: x3d
    real(kind=realtype) :: x4
    real(kind=realtype) :: x4d
    real(kind=realtype) :: y2
    real(kind=realtype) :: y2d
    real(kind=realtype) :: x5
    real(kind=realtype) :: x5d
    real(kind=realtype) :: x6
    real(kind=realtype) :: x6d
    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) :: temp
    real(kind=realtype) :: temp0
    real(kind=realtype) :: tempd
    real(kind=realtype) :: tmp
    real(kind=realtype) :: tmpd
    real(kind=realtype) :: tmp0
    real(kind=realtype) :: tmpd0
    real(kind=realtype) :: tmp1
    real(kind=realtype) :: tmpd1
    real(kind=realtype) :: tmp2
    real(kind=realtype) :: tmpd2
    real(kind=realtype) :: tmp3
    real(kind=realtype) :: tmpd3
    real(kind=realtype) :: tmp4
    real(kind=realtype) :: tmpd4
    real(kind=realtype) :: tmp5
    real(kind=realtype) :: tmpd5
    real(kind=realtype) :: tmp6
    real(kind=realtype) :: tmpd6
    real(kind=realtype) :: tmp7
    real(kind=realtype) :: tmpd7
    real(kind=realtype) :: tmp8
    real(kind=realtype) :: tmpd8
    real(kind=realtype) :: tmp9
    real(kind=realtype) :: tmpd9
    real(kind=realtype) :: tmp10
    real(kind=realtype) :: tmpd10
    real(kind=realtype) :: tmp11
    real(kind=realtype) :: tmpd11
    real(kind=realtype) :: tmp12
    real(kind=realtype) :: tmpd12
    real(kind=realtype) :: tmp13
    real(kind=realtype) :: tmpd13
    real(kind=realtype) :: tmp14
    real(kind=realtype) :: tmpd14
    real(kind=realtype) :: tmp15
    real(kind=realtype) :: tmpd15
    real(kind=realtype) :: tmp16
    real(kind=realtype) :: tmpd16
    real(kind=realtype) :: tmp17
    real(kind=realtype) :: tmpd17
    real(kind=realtype) :: tmp18
    real(kind=realtype) :: tmpd18
    real(kind=realtype) :: tmp19
    real(kind=realtype) :: tmpd19
    real(kind=realtype) :: tmp20
    real(kind=realtype) :: tmpd20
    real(kind=realtype) :: tmp21
    real(kind=realtype) :: tmpd21
    real(kind=realtype) :: tmp22
    real(kind=realtype) :: tmpd22
    real(kind=realtype) :: tmp23
    real(kind=realtype) :: tmpd23
    real(kind=realtype) :: tmp24
    real(kind=realtype) :: tmpd24
    real(kind=realtype) :: tmp25
    real(kind=realtype) :: tmpd25
    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 .lt. thresholdreal) then
      rhoinfd = 0.0_8
      pinfcorrd = 0.0_8
      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
!===============================================================
        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
        call pushcontrol2b(2)
      case default
        call pushcontrol2b(0)
      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
            tmp = w(i, j, k, irho)*w(i, j, k, ivx)
            call pushreal8(w(i, j, k, ivx))
            w(i, j, k, ivx) = tmp
            tmp0 = w(i, j, k, irho)*w(i, j, k, ivy)
            call pushreal8(w(i, j, k, ivy))
            w(i, j, k, ivy) = tmp0
            tmp1 = w(i, j, k, irho)*w(i, j, k, ivz)
            call pushreal8(w(i, j, k, ivz))
            w(i, j, k, ivz) = tmp1
            call pushreal8(w(i, j, k, irhoe))
            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
          tmp2 = w(0, j, k, irho)*w(0, j, k, ivx)
          call pushreal8(w(0, j, k, ivx))
          w(0, j, k, ivx) = tmp2
          tmp3 = w(0, j, k, irho)*w(0, j, k, ivy)
          call pushreal8(w(0, j, k, ivy))
          w(0, j, k, ivy) = tmp3
          tmp4 = w(0, j, k, irho)*w(0, j, k, ivz)
          call pushreal8(w(0, j, k, ivz))
          w(0, j, k, ivz) = tmp4
          call pushreal8(w(0, j, k, irhoe))
          w(0, j, k, irhoe) = w(0, j, k, irhoe) + p(0, j, k)
          tmp5 = w(1, j, k, irho)*w(1, j, k, ivx)
          call pushreal8(w(1, j, k, ivx))
          w(1, j, k, ivx) = tmp5
          tmp6 = w(1, j, k, irho)*w(1, j, k, ivy)
          call pushreal8(w(1, j, k, ivy))
          w(1, j, k, ivy) = tmp6
          tmp7 = w(1, j, k, irho)*w(1, j, k, ivz)
          call pushreal8(w(1, j, k, ivz))
          w(1, j, k, ivz) = tmp7
          call pushreal8(w(1, j, k, irhoe))
          w(1, j, k, irhoe) = w(1, j, k, irhoe) + p(1, j, k)
          tmp8 = w(ie, j, k, irho)*w(ie, j, k, ivx)
          call pushreal8(w(ie, j, k, ivx))
          w(ie, j, k, ivx) = tmp8
          tmp9 = w(ie, j, k, irho)*w(ie, j, k, ivy)
          call pushreal8(w(ie, j, k, ivy))
          w(ie, j, k, ivy) = tmp9
          tmp10 = w(ie, j, k, irho)*w(ie, j, k, ivz)
          call pushreal8(w(ie, j, k, ivz))
          w(ie, j, k, ivz) = tmp10
          call pushreal8(w(ie, j, k, irhoe))
          w(ie, j, k, irhoe) = w(ie, j, k, irhoe) + p(ie, j, k)
          tmp11 = w(ib, j, k, irho)*w(ib, j, k, ivx)
          call pushreal8(w(ib, j, k, ivx))
          w(ib, j, k, ivx) = tmp11
          tmp12 = w(ib, j, k, irho)*w(ib, j, k, ivy)
          call pushreal8(w(ib, j, k, ivy))
          w(ib, j, k, ivy) = tmp12
          tmp13 = w(ib, j, k, irho)*w(ib, j, k, ivz)
          call pushreal8(w(ib, j, k, ivz))
          w(ib, j, k, ivz) = tmp13
          call pushreal8(w(ib, j, k, irhoe))
          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
          tmp14 = w(i, 0, k, irho)*w(i, 0, k, ivx)
          call pushreal8(w(i, 0, k, ivx))
          w(i, 0, k, ivx) = tmp14
          tmp15 = w(i, 0, k, irho)*w(i, 0, k, ivy)
          call pushreal8(w(i, 0, k, ivy))
          w(i, 0, k, ivy) = tmp15
          tmp16 = w(i, 0, k, irho)*w(i, 0, k, ivz)
          call pushreal8(w(i, 0, k, ivz))
          w(i, 0, k, ivz) = tmp16
          call pushreal8(w(i, 0, k, irhoe))
          w(i, 0, k, irhoe) = w(i, 0, k, irhoe) + p(i, 0, k)
          tmp17 = w(i, 1, k, irho)*w(i, 1, k, ivx)
          call pushreal8(w(i, 1, k, ivx))
          w(i, 1, k, ivx) = tmp17
          tmp18 = w(i, 1, k, irho)*w(i, 1, k, ivy)
          call pushreal8(w(i, 1, k, ivy))
          w(i, 1, k, ivy) = tmp18
          tmp19 = w(i, 1, k, irho)*w(i, 1, k, ivz)
          call pushreal8(w(i, 1, k, ivz))
          w(i, 1, k, ivz) = tmp19
          call pushreal8(w(i, 1, k, irhoe))
          w(i, 1, k, irhoe) = w(i, 1, k, irhoe) + p(i, 1, k)
          tmp20 = w(i, je, k, irho)*w(i, je, k, ivx)
          call pushreal8(w(i, je, k, ivx))
          w(i, je, k, ivx) = tmp20
          tmp21 = w(i, je, k, irho)*w(i, je, k, ivy)
          call pushreal8(w(i, je, k, ivy))
          w(i, je, k, ivy) = tmp21
          tmp22 = w(i, je, k, irho)*w(i, je, k, ivz)
          call pushreal8(w(i, je, k, ivz))
          w(i, je, k, ivz) = tmp22
          call pushreal8(w(i, je, k, irhoe))
          w(i, je, k, irhoe) = w(i, je, k, irhoe) + p(i, je, k)
          tmp23 = w(i, jb, k, irho)*w(i, jb, k, ivx)
          call pushreal8(w(i, jb, k, ivx))
          w(i, jb, k, ivx) = tmp23
          tmp24 = w(i, jb, k, irho)*w(i, jb, k, ivy)
          call pushreal8(w(i, jb, k, ivy))
          w(i, jb, k, ivy) = tmp24
          tmp25 = w(i, jb, k, irho)*w(i, jb, k, ivz)
          call pushreal8(w(i, jb, k, ivz))
          w(i, jb, k, ivz) = tmp25
          call pushreal8(w(i, jb, k, irhoe))
          w(i, jb, k, irhoe) = w(i, jb, k, irhoe) + p(i, jb, k)
        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
            call pushcontrol1b(0)
          else
            dss1 = -x1
            call pushcontrol1b(1)
          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
              call pushcontrol1b(0)
            else
              dss2 = -x2
              call pushcontrol1b(1)
            end if
! compute the dissipation coefficients for this face.
            call pushreal8(ppor)
            ppor = zero
            if (pori(i, j, k) .eq. normalflux) ppor = half
            if (dss1 .lt. dss2) then
              y1 = dss2
              call pushcontrol1b(0)
            else
              y1 = dss1
              call pushcontrol1b(1)
            end if
            if (dssmax .gt. y1) then
              call pushreal8(min1)
              min1 = y1
              call pushcontrol1b(0)
            else
              call pushreal8(min1)
              min1 = dssmax
              call pushcontrol1b(1)
            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
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
! x-momentum.
! y-momentum.
! z-momentum.
! energy.
! 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
            call pushcontrol1b(0)
          else
            dss1 = -x3
            call pushcontrol1b(1)
          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
              call pushcontrol1b(0)
            else
              dss2 = -x4
              call pushcontrol1b(1)
            end if
! compute the dissipation coefficients for this face.
            call pushreal8(ppor)
            ppor = zero
            if (porj(i, j, k) .eq. normalflux) ppor = half
            if (dss1 .lt. dss2) then
              y2 = dss2
              call pushcontrol1b(0)
            else
              y2 = dss1
              call pushcontrol1b(1)
            end if
            if (dssmax .gt. y2) then
              call pushreal8(min2)
              min2 = y2
              call pushcontrol1b(0)
            else
              call pushreal8(min2)
              min2 = dssmax
              call pushcontrol1b(1)
            end if
! modification for fd preconditioner
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
! x-momentum.
! y-momentum.
! z-momentum.
! energy.
! 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
            call pushcontrol1b(0)
          else
            dss1 = -x5
            call pushcontrol1b(1)
          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
              call pushcontrol1b(0)
            else
              dss2 = -x6
              call pushcontrol1b(1)
            end if
! compute the dissipation coefficients for this face.
            call pushreal8(ppor)
            ppor = zero
            if (pork(i, j, k) .eq. normalflux) ppor = half
            if (dss1 .lt. dss2) then
              y3 = dss2
              call pushcontrol1b(0)
            else
              y3 = dss1
              call pushcontrol1b(1)
            end if
            if (dssmax .gt. y3) then
              call pushreal8(min3)
              min3 = y3
              call pushcontrol1b(0)
            else
              call pushreal8(min3)
              min3 = dssmax
              call pushcontrol1b(1)
            end if
! modification for fd preconditioner
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
! x-momentum.
! y-momentum.
! z-momentum.
! energy.
! 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
            call pushreal8(rhoi)
            rhoi = one/w(i, j, k, irho)
            call pushreal8(w(i, j, k, ivx))
            w(i, j, k, ivx) = w(i, j, k, ivx)*rhoi
            call pushreal8(w(i, j, k, ivy))
            w(i, j, k, ivy) = w(i, j, k, ivy)*rhoi
            call pushreal8(w(i, j, k, ivz))
            w(i, j, k, ivz) = w(i, j, k, ivz)*rhoi
            call pushreal8(w(i, j, k, irhoe))
            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
          call pushreal8(rhoi)
          rhoi = one/w(0, j, k, irho)
          call pushreal8(w(0, j, k, ivx))
          w(0, j, k, ivx) = w(0, j, k, ivx)*rhoi
          call pushreal8(w(0, j, k, ivy))
          w(0, j, k, ivy) = w(0, j, k, ivy)*rhoi
          call pushreal8(w(0, j, k, ivz))
          w(0, j, k, ivz) = w(0, j, k, ivz)*rhoi
          call pushreal8(w(0, j, k, irhoe))
          w(0, j, k, irhoe) = w(0, j, k, irhoe) - p(0, j, k)
          call pushreal8(rhoi)
          rhoi = one/w(1, j, k, irho)
          call pushreal8(w(1, j, k, ivx))
          w(1, j, k, ivx) = w(1, j, k, ivx)*rhoi
          call pushreal8(w(1, j, k, ivy))
          w(1, j, k, ivy) = w(1, j, k, ivy)*rhoi
          call pushreal8(w(1, j, k, ivz))
          w(1, j, k, ivz) = w(1, j, k, ivz)*rhoi
          call pushreal8(w(1, j, k, irhoe))
          w(1, j, k, irhoe) = w(1, j, k, irhoe) - p(1, j, k)
          call pushreal8(rhoi)
          rhoi = one/w(ie, j, k, irho)
          call pushreal8(w(ie, j, k, ivx))
          w(ie, j, k, ivx) = w(ie, j, k, ivx)*rhoi
          call pushreal8(w(ie, j, k, ivy))
          w(ie, j, k, ivy) = w(ie, j, k, ivy)*rhoi
          call pushreal8(w(ie, j, k, ivz))
          w(ie, j, k, ivz) = w(ie, j, k, ivz)*rhoi
          call pushreal8(w(ie, j, k, irhoe))
          w(ie, j, k, irhoe) = w(ie, j, k, irhoe) - p(ie, j, k)
          call pushreal8(rhoi)
          rhoi = one/w(ib, j, k, irho)
          call pushreal8(w(ib, j, k, ivx))
          w(ib, j, k, ivx) = w(ib, j, k, ivx)*rhoi
          call pushreal8(w(ib, j, k, ivy))
          w(ib, j, k, ivy) = w(ib, j, k, ivy)*rhoi
          call pushreal8(w(ib, j, k, ivz))
          w(ib, j, k, ivz) = w(ib, j, k, ivz)*rhoi
          call pushreal8(w(ib, j, k, irhoe))
          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
          call pushreal8(rhoi)
          rhoi = one/w(i, 0, k, irho)
          call pushreal8(w(i, 0, k, ivx))
          w(i, 0, k, ivx) = w(i, 0, k, ivx)*rhoi
          call pushreal8(w(i, 0, k, ivy))
          w(i, 0, k, ivy) = w(i, 0, k, ivy)*rhoi
          call pushreal8(w(i, 0, k, ivz))
          w(i, 0, k, ivz) = w(i, 0, k, ivz)*rhoi
          call pushreal8(w(i, 0, k, irhoe))
          w(i, 0, k, irhoe) = w(i, 0, k, irhoe) - p(i, 0, k)
          call pushreal8(rhoi)
          rhoi = one/w(i, 1, k, irho)
          call pushreal8(w(i, 1, k, ivx))
          w(i, 1, k, ivx) = w(i, 1, k, ivx)*rhoi
          call pushreal8(w(i, 1, k, ivy))
          w(i, 1, k, ivy) = w(i, 1, k, ivy)*rhoi
          call pushreal8(w(i, 1, k, ivz))
          w(i, 1, k, ivz) = w(i, 1, k, ivz)*rhoi
          call pushreal8(w(i, 1, k, irhoe))
          w(i, 1, k, irhoe) = w(i, 1, k, irhoe) - p(i, 1, k)
          call pushreal8(rhoi)
          rhoi = one/w(i, je, k, irho)
          call pushreal8(w(i, je, k, ivx))
          w(i, je, k, ivx) = w(i, je, k, ivx)*rhoi
          call pushreal8(w(i, je, k, ivy))
          w(i, je, k, ivy) = w(i, je, k, ivy)*rhoi
          call pushreal8(w(i, je, k, ivz))
          w(i, je, k, ivz) = w(i, je, k, ivz)*rhoi
          call pushreal8(w(i, je, k, irhoe))
          w(i, je, k, irhoe) = w(i, je, k, irhoe) - p(i, je, k)
          call pushreal8(rhoi)
          rhoi = one/w(i, jb, k, irho)
          call pushreal8(w(i, jb, k, ivx))
          w(i, jb, k, ivx) = w(i, jb, k, ivx)*rhoi
          call pushreal8(w(i, jb, k, ivy))
          w(i, jb, k, ivy) = w(i, jb, k, ivy)*rhoi
          call pushreal8(w(i, jb, k, ivz))
          w(i, jb, k, ivz) = w(i, jb, k, ivz)*rhoi
          call pushreal8(w(i, jb, k, irhoe))
          w(i, jb, k, irhoe) = w(i, jb, k, irhoe) - p(i, jb, k)
        end do
      end do
      do k=kl,2,-1
        do i=il,2,-1
          call popreal8(w(i, jb, k, irhoe))
          pd(i, jb, k) = pd(i, jb, k) - wd(i, jb, k, irhoe)
          call popreal8(w(i, jb, k, ivz))
          rhoid = w(i, jb, k, ivz)*wd(i, jb, k, ivz)
          wd(i, jb, k, ivz) = rhoi*wd(i, jb, k, ivz)
          call popreal8(w(i, jb, k, ivy))
          rhoid = rhoid + w(i, jb, k, ivy)*wd(i, jb, k, ivy)
          wd(i, jb, k, ivy) = rhoi*wd(i, jb, k, ivy)
          call popreal8(w(i, jb, k, ivx))
          rhoid = rhoid + w(i, jb, k, ivx)*wd(i, jb, k, ivx)
          wd(i, jb, k, ivx) = rhoi*wd(i, jb, k, ivx)
          call popreal8(rhoi)
          temp0 = w(i, jb, k, irho)
          wd(i, jb, k, irho) = wd(i, jb, k, irho) - one*rhoid/temp0**2
          call popreal8(w(i, je, k, irhoe))
          pd(i, je, k) = pd(i, je, k) - wd(i, je, k, irhoe)
          call popreal8(w(i, je, k, ivz))
          rhoid = w(i, je, k, ivz)*wd(i, je, k, ivz)
          wd(i, je, k, ivz) = rhoi*wd(i, je, k, ivz)
          call popreal8(w(i, je, k, ivy))
          rhoid = rhoid + w(i, je, k, ivy)*wd(i, je, k, ivy)
          wd(i, je, k, ivy) = rhoi*wd(i, je, k, ivy)
          call popreal8(w(i, je, k, ivx))
          rhoid = rhoid + w(i, je, k, ivx)*wd(i, je, k, ivx)
          wd(i, je, k, ivx) = rhoi*wd(i, je, k, ivx)
          call popreal8(rhoi)
          temp0 = w(i, je, k, irho)
          wd(i, je, k, irho) = wd(i, je, k, irho) - one*rhoid/temp0**2
          call popreal8(w(i, 1, k, irhoe))
          pd(i, 1, k) = pd(i, 1, k) - wd(i, 1, k, irhoe)
          call popreal8(w(i, 1, k, ivz))
          rhoid = w(i, 1, k, ivz)*wd(i, 1, k, ivz)
          wd(i, 1, k, ivz) = rhoi*wd(i, 1, k, ivz)
          call popreal8(w(i, 1, k, ivy))
          rhoid = rhoid + w(i, 1, k, ivy)*wd(i, 1, k, ivy)
          wd(i, 1, k, ivy) = rhoi*wd(i, 1, k, ivy)
          call popreal8(w(i, 1, k, ivx))
          rhoid = rhoid + w(i, 1, k, ivx)*wd(i, 1, k, ivx)
          wd(i, 1, k, ivx) = rhoi*wd(i, 1, k, ivx)
          call popreal8(rhoi)
          temp0 = w(i, 1, k, irho)
          wd(i, 1, k, irho) = wd(i, 1, k, irho) - one*rhoid/temp0**2
          call popreal8(w(i, 0, k, irhoe))
          pd(i, 0, k) = pd(i, 0, k) - wd(i, 0, k, irhoe)
          call popreal8(w(i, 0, k, ivz))
          rhoid = w(i, 0, k, ivz)*wd(i, 0, k, ivz)
          wd(i, 0, k, ivz) = rhoi*wd(i, 0, k, ivz)
          call popreal8(w(i, 0, k, ivy))
          rhoid = rhoid + w(i, 0, k, ivy)*wd(i, 0, k, ivy)
          wd(i, 0, k, ivy) = rhoi*wd(i, 0, k, ivy)
          call popreal8(w(i, 0, k, ivx))
          rhoid = rhoid + w(i, 0, k, ivx)*wd(i, 0, k, ivx)
          wd(i, 0, k, ivx) = rhoi*wd(i, 0, k, ivx)
          call popreal8(rhoi)
          temp0 = w(i, 0, k, irho)
          wd(i, 0, k, irho) = wd(i, 0, k, irho) - one*rhoid/temp0**2
        end do
      end do
      do k=kl,2,-1
        do j=jl,2,-1
          call popreal8(w(ib, j, k, irhoe))
          pd(ib, j, k) = pd(ib, j, k) - wd(ib, j, k, irhoe)
          call popreal8(w(ib, j, k, ivz))
          rhoid = w(ib, j, k, ivz)*wd(ib, j, k, ivz)
          wd(ib, j, k, ivz) = rhoi*wd(ib, j, k, ivz)
          call popreal8(w(ib, j, k, ivy))
          rhoid = rhoid + w(ib, j, k, ivy)*wd(ib, j, k, ivy)
          wd(ib, j, k, ivy) = rhoi*wd(ib, j, k, ivy)
          call popreal8(w(ib, j, k, ivx))
          rhoid = rhoid + w(ib, j, k, ivx)*wd(ib, j, k, ivx)
          wd(ib, j, k, ivx) = rhoi*wd(ib, j, k, ivx)
          call popreal8(rhoi)
          temp0 = w(ib, j, k, irho)
          wd(ib, j, k, irho) = wd(ib, j, k, irho) - one*rhoid/temp0**2
          call popreal8(w(ie, j, k, irhoe))
          pd(ie, j, k) = pd(ie, j, k) - wd(ie, j, k, irhoe)
          call popreal8(w(ie, j, k, ivz))
          rhoid = w(ie, j, k, ivz)*wd(ie, j, k, ivz)
          wd(ie, j, k, ivz) = rhoi*wd(ie, j, k, ivz)
          call popreal8(w(ie, j, k, ivy))
          rhoid = rhoid + w(ie, j, k, ivy)*wd(ie, j, k, ivy)
          wd(ie, j, k, ivy) = rhoi*wd(ie, j, k, ivy)
          call popreal8(w(ie, j, k, ivx))
          rhoid = rhoid + w(ie, j, k, ivx)*wd(ie, j, k, ivx)
          wd(ie, j, k, ivx) = rhoi*wd(ie, j, k, ivx)
          call popreal8(rhoi)
          temp0 = w(ie, j, k, irho)
          wd(ie, j, k, irho) = wd(ie, j, k, irho) - one*rhoid/temp0**2
          call popreal8(w(1, j, k, irhoe))
          pd(1, j, k) = pd(1, j, k) - wd(1, j, k, irhoe)
          call popreal8(w(1, j, k, ivz))
          rhoid = w(1, j, k, ivz)*wd(1, j, k, ivz)
          wd(1, j, k, ivz) = rhoi*wd(1, j, k, ivz)
          call popreal8(w(1, j, k, ivy))
          rhoid = rhoid + w(1, j, k, ivy)*wd(1, j, k, ivy)
          wd(1, j, k, ivy) = rhoi*wd(1, j, k, ivy)
          call popreal8(w(1, j, k, ivx))
          rhoid = rhoid + w(1, j, k, ivx)*wd(1, j, k, ivx)
          wd(1, j, k, ivx) = rhoi*wd(1, j, k, ivx)
          call popreal8(rhoi)
          temp0 = w(1, j, k, irho)
          wd(1, j, k, irho) = wd(1, j, k, irho) - one*rhoid/temp0**2
          call popreal8(w(0, j, k, irhoe))
          pd(0, j, k) = pd(0, j, k) - wd(0, j, k, irhoe)
          call popreal8(w(0, j, k, ivz))
          rhoid = w(0, j, k, ivz)*wd(0, j, k, ivz)
          wd(0, j, k, ivz) = rhoi*wd(0, j, k, ivz)
          call popreal8(w(0, j, k, ivy))
          rhoid = rhoid + w(0, j, k, ivy)*wd(0, j, k, ivy)
          wd(0, j, k, ivy) = rhoi*wd(0, j, k, ivy)
          call popreal8(w(0, j, k, ivx))
          rhoid = rhoid + w(0, j, k, ivx)*wd(0, j, k, ivx)
          wd(0, j, k, ivx) = rhoi*wd(0, j, k, ivx)
          call popreal8(rhoi)
          temp0 = w(0, j, k, irho)
          wd(0, j, k, irho) = wd(0, j, k, irho) - one*rhoid/temp0**2
        end do
      end do
      do k=kb,0,-1
        do j=jl,2,-1
          do i=il,2,-1
            call popreal8(w(i, j, k, irhoe))
            pd(i, j, k) = pd(i, j, k) - wd(i, j, k, irhoe)
            call popreal8(w(i, j, k, ivz))
            rhoid = w(i, j, k, ivz)*wd(i, j, k, ivz)
            wd(i, j, k, ivz) = rhoi*wd(i, j, k, ivz)
            call popreal8(w(i, j, k, ivy))
            rhoid = rhoid + w(i, j, k, ivy)*wd(i, j, k, ivy)
            wd(i, j, k, ivy) = rhoi*wd(i, j, k, ivy)
            call popreal8(w(i, j, k, ivx))
            rhoid = rhoid + w(i, j, k, ivx)*wd(i, j, k, ivx)
            wd(i, j, k, ivx) = rhoi*wd(i, j, k, ivx)
            call popreal8(rhoi)
            temp0 = w(i, j, k, irho)
            wd(i, j, k, irho) = wd(i, j, k, irho) - one*rhoid/temp0**2
          end do
        end do
      end do
      if (associated(radkd)) radkd = 0.0_8
      sslimd = 0.0_8
      do j=jl,2,-1
        do i=il,2,-1
          dss1d = 0.0_8
          do k=kl,1,-1
            dss2d = dss1d
            fsd = fwd(i, j, k+1, irhoe) - fwd(i, j, k, irhoe)
            ddw = w(i, j, k+1, irhoe) - w(i, j, k, irhoe)
            rrad = ppor*(radk(i, j, k)+radk(i, j, k+1))
            dis2 = fis2*rrad*min3 + sigma*fis4*rrad
            dis2d = ddw*fsd
            ddwd = dis2*fsd
            wd(i, j, k+1, irhoe) = wd(i, j, k+1, irhoe) + ddwd
            wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddwd
            fsd = fwd(i, j, k+1, imz) - fwd(i, j, k, imz)
            ddw = w(i, j, k+1, ivz) - w(i, j, k, ivz)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + ddwd
            wd(i, j, k, ivz) = wd(i, j, k, ivz) - ddwd
            fsd = fwd(i, j, k+1, imy) - fwd(i, j, k, imy)
            ddw = w(i, j, k+1, ivy) - w(i, j, k, ivy)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + ddwd
            wd(i, j, k, ivy) = wd(i, j, k, ivy) - ddwd
            fsd = fwd(i, j, k+1, imx) - fwd(i, j, k, imx)
            ddw = w(i, j, k+1, ivx) - w(i, j, k, ivx)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + ddwd
            wd(i, j, k, ivx) = wd(i, j, k, ivx) - ddwd
            fsd = fwd(i, j, k+1, irho) - fwd(i, j, k, irho)
            ddw = w(i, j, k+1, irho) - w(i, j, k, irho)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - ddwd
            rradd = (min3*fis2+sigma*fis4)*dis2d
            min3d = rrad*fis2*dis2d
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(min3)
              y3d = min3d
            else
              call popreal8(min3)
              y3d = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              dss2d = dss2d + y3d
              dss1d = 0.0_8
            else
              dss1d = 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
            call popreal8(ppor)
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              x6d = dss2d
            else
              x6d = -dss2d
            end if
            temp0 = shocksensor(i, j, k+2) + two*shocksensor(i, j, k+1) &
&             + shocksensor(i, j, k) + sslim
            sslimd = sslimd - (shocksensor(i, j, k+2)-two*shocksensor(i&
&             , j, k+1)+shocksensor(i, j, k))*x6d/temp0**2
          end do
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            x5d = dss1d
          else
            x5d = -dss1d
          end if
          temp0 = shocksensor(i, j, 2) + two*shocksensor(i, j, 1) + &
&           shocksensor(i, j, 0) + sslim
          sslimd = sslimd - (shocksensor(i, j, 2)-two*shocksensor(i, j, &
&           1)+shocksensor(i, j, 0))*x5d/temp0**2
        end do
      end do
      if (associated(radjd)) radjd = 0.0_8
      do k=kl,2,-1
        do i=il,2,-1
          dss1d = 0.0_8
          do j=jl,1,-1
            dss2d = dss1d
            fsd = fwd(i, j+1, k, irhoe) - fwd(i, j, k, irhoe)
            ddw = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
            rrad = ppor*(radj(i, j, k)+radj(i, j+1, k))
            dis2 = fis2*rrad*min2 + sigma*fis4*rrad
            dis2d = ddw*fsd
            ddwd = dis2*fsd
            wd(i, j+1, k, irhoe) = wd(i, j+1, k, irhoe) + ddwd
            wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddwd
            fsd = fwd(i, j+1, k, imz) - fwd(i, j, k, imz)
            ddw = w(i, j+1, k, ivz) - w(i, j, k, ivz)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + ddwd
            wd(i, j, k, ivz) = wd(i, j, k, ivz) - ddwd
            fsd = fwd(i, j+1, k, imy) - fwd(i, j, k, imy)
            ddw = w(i, j+1, k, ivy) - w(i, j, k, ivy)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + ddwd
            wd(i, j, k, ivy) = wd(i, j, k, ivy) - ddwd
            fsd = fwd(i, j+1, k, imx) - fwd(i, j, k, imx)
            ddw = w(i, j+1, k, ivx) - w(i, j, k, ivx)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + ddwd
            wd(i, j, k, ivx) = wd(i, j, k, ivx) - ddwd
            fsd = fwd(i, j+1, k, irho) - fwd(i, j, k, irho)
            ddw = w(i, j+1, k, irho) - w(i, j, k, irho)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - ddwd
            rradd = (min2*fis2+sigma*fis4)*dis2d
            min2d = rrad*fis2*dis2d
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(min2)
              y2d = min2d
            else
              call popreal8(min2)
              y2d = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              dss2d = dss2d + y2d
              dss1d = 0.0_8
            else
              dss1d = 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
            call popreal8(ppor)
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              x4d = dss2d
            else
              x4d = -dss2d
            end if
            temp0 = shocksensor(i, j+2, k) + two*shocksensor(i, j+1, k) &
&             + shocksensor(i, j, k) + sslim
            sslimd = sslimd - (shocksensor(i, j+2, k)-two*shocksensor(i&
&             , j+1, k)+shocksensor(i, j, k))*x4d/temp0**2
          end do
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            x3d = dss1d
          else
            x3d = -dss1d
          end if
          temp0 = shocksensor(i, 2, k) + two*shocksensor(i, 1, k) + &
&           shocksensor(i, 0, k) + sslim
          sslimd = sslimd - (shocksensor(i, 2, k)-two*shocksensor(i, 1, &
&           k)+shocksensor(i, 0, k))*x3d/temp0**2
        end do
      end do
      if (associated(radid)) radid = 0.0_8
      do k=kl,2,-1
        do j=jl,2,-1
          dss1d = 0.0_8
          do i=il,1,-1
            dss2d = dss1d
            fsd = fwd(i+1, j, k, irhoe) - fwd(i, j, k, irhoe)
            ddw = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
            rrad = ppor*(radi(i, j, k)+radi(i+1, j, k))
            dis2 = fis2*rrad*min1 + sigma*fis4*rrad
            dis2d = ddw*fsd
            ddwd = dis2*fsd
            wd(i+1, j, k, irhoe) = wd(i+1, j, k, irhoe) + ddwd
            wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddwd
            fsd = fwd(i+1, j, k, imz) - fwd(i, j, k, imz)
            ddw = w(i+1, j, k, ivz) - w(i, j, k, ivz)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + ddwd
            wd(i, j, k, ivz) = wd(i, j, k, ivz) - ddwd
            fsd = fwd(i+1, j, k, imy) - fwd(i, j, k, imy)
            ddw = w(i+1, j, k, ivy) - w(i, j, k, ivy)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + ddwd
            wd(i, j, k, ivy) = wd(i, j, k, ivy) - ddwd
            fsd = fwd(i+1, j, k, imx) - fwd(i, j, k, imx)
            ddw = w(i+1, j, k, ivx) - w(i, j, k, ivx)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + ddwd
            wd(i, j, k, ivx) = wd(i, j, k, ivx) - ddwd
            fsd = fwd(i+1, j, k, irho) - fwd(i, j, k, irho)
            ddw = w(i+1, j, k, irho) - w(i, j, k, irho)
            dis2d = dis2d + ddw*fsd
            ddwd = dis2*fsd
            wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - ddwd
            rradd = (min1*fis2+sigma*fis4)*dis2d
            min1d = rrad*fis2*dis2d
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(min1)
              y1d = min1d
            else
              call popreal8(min1)
              y1d = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              dss2d = dss2d + y1d
              dss1d = 0.0_8
            else
              dss1d = 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
            call popreal8(ppor)
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              x2d = dss2d
            else
              x2d = -dss2d
            end if
            temp0 = shocksensor(i+2, j, k) + two*shocksensor(i+1, j, k) &
&             + shocksensor(i, j, k) + sslim
            sslimd = sslimd - (shocksensor(i+2, j, k)-two*shocksensor(i+&
&             1, j, k)+shocksensor(i, j, k))*x2d/temp0**2
          end do
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            x1d = dss1d
          else
            x1d = -dss1d
          end if
          temp0 = shocksensor(2, j, k) + two*shocksensor(1, j, k) + &
&           shocksensor(0, j, k) + sslim
          sslimd = sslimd - (shocksensor(2, j, k)-two*shocksensor(1, j, &
&           k)+shocksensor(0, j, k))*x1d/temp0**2
        end do
      end do
      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
      do k=kl,2,-1
        do i=il,2,-1
          call popreal8(w(i, jb, k, irhoe))
          pd(i, jb, k) = pd(i, jb, k) + wd(i, jb, k, irhoe)
          call popreal8(w(i, jb, k, ivz))
          tmpd25 = wd(i, jb, k, ivz)
          wd(i, jb, k, ivz) = 0.0_8
          wd(i, jb, k, irho) = wd(i, jb, k, irho) + w(i, jb, k, ivz)*&
&           tmpd25
          wd(i, jb, k, ivz) = wd(i, jb, k, ivz) + w(i, jb, k, irho)*&
&           tmpd25
          call popreal8(w(i, jb, k, ivy))
          tmpd24 = wd(i, jb, k, ivy)
          wd(i, jb, k, ivy) = 0.0_8
          wd(i, jb, k, irho) = wd(i, jb, k, irho) + w(i, jb, k, ivy)*&
&           tmpd24
          wd(i, jb, k, ivy) = wd(i, jb, k, ivy) + w(i, jb, k, irho)*&
&           tmpd24
          call popreal8(w(i, jb, k, ivx))
          tmpd23 = wd(i, jb, k, ivx)
          wd(i, jb, k, ivx) = 0.0_8
          wd(i, jb, k, irho) = wd(i, jb, k, irho) + w(i, jb, k, ivx)*&
&           tmpd23
          wd(i, jb, k, ivx) = wd(i, jb, k, ivx) + w(i, jb, k, irho)*&
&           tmpd23
          call popreal8(w(i, je, k, irhoe))
          pd(i, je, k) = pd(i, je, k) + wd(i, je, k, irhoe)
          call popreal8(w(i, je, k, ivz))
          tmpd22 = wd(i, je, k, ivz)
          wd(i, je, k, ivz) = 0.0_8
          wd(i, je, k, irho) = wd(i, je, k, irho) + w(i, je, k, ivz)*&
&           tmpd22
          wd(i, je, k, ivz) = wd(i, je, k, ivz) + w(i, je, k, irho)*&
&           tmpd22
          call popreal8(w(i, je, k, ivy))
          tmpd21 = wd(i, je, k, ivy)
          wd(i, je, k, ivy) = 0.0_8
          wd(i, je, k, irho) = wd(i, je, k, irho) + w(i, je, k, ivy)*&
&           tmpd21
          wd(i, je, k, ivy) = wd(i, je, k, ivy) + w(i, je, k, irho)*&
&           tmpd21
          call popreal8(w(i, je, k, ivx))
          tmpd20 = wd(i, je, k, ivx)
          wd(i, je, k, ivx) = 0.0_8
          wd(i, je, k, irho) = wd(i, je, k, irho) + w(i, je, k, ivx)*&
&           tmpd20
          wd(i, je, k, ivx) = wd(i, je, k, ivx) + w(i, je, k, irho)*&
&           tmpd20
          call popreal8(w(i, 1, k, irhoe))
          pd(i, 1, k) = pd(i, 1, k) + wd(i, 1, k, irhoe)
          call popreal8(w(i, 1, k, ivz))
          tmpd19 = wd(i, 1, k, ivz)
          wd(i, 1, k, ivz) = 0.0_8
          wd(i, 1, k, irho) = wd(i, 1, k, irho) + w(i, 1, k, ivz)*tmpd19
          wd(i, 1, k, ivz) = wd(i, 1, k, ivz) + w(i, 1, k, irho)*tmpd19
          call popreal8(w(i, 1, k, ivy))
          tmpd18 = wd(i, 1, k, ivy)
          wd(i, 1, k, ivy) = 0.0_8
          wd(i, 1, k, irho) = wd(i, 1, k, irho) + w(i, 1, k, ivy)*tmpd18
          wd(i, 1, k, ivy) = wd(i, 1, k, ivy) + w(i, 1, k, irho)*tmpd18
          call popreal8(w(i, 1, k, ivx))
          tmpd17 = wd(i, 1, k, ivx)
          wd(i, 1, k, ivx) = 0.0_8
          wd(i, 1, k, irho) = wd(i, 1, k, irho) + w(i, 1, k, ivx)*tmpd17
          wd(i, 1, k, ivx) = wd(i, 1, k, ivx) + w(i, 1, k, irho)*tmpd17
          call popreal8(w(i, 0, k, irhoe))
          pd(i, 0, k) = pd(i, 0, k) + wd(i, 0, k, irhoe)
          call popreal8(w(i, 0, k, ivz))
          tmpd16 = wd(i, 0, k, ivz)
          wd(i, 0, k, ivz) = 0.0_8
          wd(i, 0, k, irho) = wd(i, 0, k, irho) + w(i, 0, k, ivz)*tmpd16
          wd(i, 0, k, ivz) = wd(i, 0, k, ivz) + w(i, 0, k, irho)*tmpd16
          call popreal8(w(i, 0, k, ivy))
          tmpd15 = wd(i, 0, k, ivy)
          wd(i, 0, k, ivy) = 0.0_8
          wd(i, 0, k, irho) = wd(i, 0, k, irho) + w(i, 0, k, ivy)*tmpd15
          wd(i, 0, k, ivy) = wd(i, 0, k, ivy) + w(i, 0, k, irho)*tmpd15
          call popreal8(w(i, 0, k, ivx))
          tmpd14 = wd(i, 0, k, ivx)
          wd(i, 0, k, ivx) = 0.0_8
          wd(i, 0, k, irho) = wd(i, 0, k, irho) + w(i, 0, k, ivx)*tmpd14
          wd(i, 0, k, ivx) = wd(i, 0, k, ivx) + w(i, 0, k, irho)*tmpd14
        end do
      end do
      do k=kl,2,-1
        do j=jl,2,-1
          call popreal8(w(ib, j, k, irhoe))
          pd(ib, j, k) = pd(ib, j, k) + wd(ib, j, k, irhoe)
          call popreal8(w(ib, j, k, ivz))
          tmpd13 = wd(ib, j, k, ivz)
          wd(ib, j, k, ivz) = 0.0_8
          wd(ib, j, k, irho) = wd(ib, j, k, irho) + w(ib, j, k, ivz)*&
&           tmpd13
          wd(ib, j, k, ivz) = wd(ib, j, k, ivz) + w(ib, j, k, irho)*&
&           tmpd13
          call popreal8(w(ib, j, k, ivy))
          tmpd12 = wd(ib, j, k, ivy)
          wd(ib, j, k, ivy) = 0.0_8
          wd(ib, j, k, irho) = wd(ib, j, k, irho) + w(ib, j, k, ivy)*&
&           tmpd12
          wd(ib, j, k, ivy) = wd(ib, j, k, ivy) + w(ib, j, k, irho)*&
&           tmpd12
          call popreal8(w(ib, j, k, ivx))
          tmpd11 = wd(ib, j, k, ivx)
          wd(ib, j, k, ivx) = 0.0_8
          wd(ib, j, k, irho) = wd(ib, j, k, irho) + w(ib, j, k, ivx)*&
&           tmpd11
          wd(ib, j, k, ivx) = wd(ib, j, k, ivx) + w(ib, j, k, irho)*&
&           tmpd11
          call popreal8(w(ie, j, k, irhoe))
          pd(ie, j, k) = pd(ie, j, k) + wd(ie, j, k, irhoe)
          call popreal8(w(ie, j, k, ivz))
          tmpd10 = wd(ie, j, k, ivz)
          wd(ie, j, k, ivz) = 0.0_8
          wd(ie, j, k, irho) = wd(ie, j, k, irho) + w(ie, j, k, ivz)*&
&           tmpd10
          wd(ie, j, k, ivz) = wd(ie, j, k, ivz) + w(ie, j, k, irho)*&
&           tmpd10
          call popreal8(w(ie, j, k, ivy))
          tmpd9 = wd(ie, j, k, ivy)
          wd(ie, j, k, ivy) = 0.0_8
          wd(ie, j, k, irho) = wd(ie, j, k, irho) + w(ie, j, k, ivy)*&
&           tmpd9
          wd(ie, j, k, ivy) = wd(ie, j, k, ivy) + w(ie, j, k, irho)*&
&           tmpd9
          call popreal8(w(ie, j, k, ivx))
          tmpd8 = wd(ie, j, k, ivx)
          wd(ie, j, k, ivx) = 0.0_8
          wd(ie, j, k, irho) = wd(ie, j, k, irho) + w(ie, j, k, ivx)*&
&           tmpd8
          wd(ie, j, k, ivx) = wd(ie, j, k, ivx) + w(ie, j, k, irho)*&
&           tmpd8
          call popreal8(w(1, j, k, irhoe))
          pd(1, j, k) = pd(1, j, k) + wd(1, j, k, irhoe)
          call popreal8(w(1, j, k, ivz))
          tmpd7 = wd(1, j, k, ivz)
          wd(1, j, k, ivz) = 0.0_8
          wd(1, j, k, irho) = wd(1, j, k, irho) + w(1, j, k, ivz)*tmpd7
          wd(1, j, k, ivz) = wd(1, j, k, ivz) + w(1, j, k, irho)*tmpd7
          call popreal8(w(1, j, k, ivy))
          tmpd6 = wd(1, j, k, ivy)
          wd(1, j, k, ivy) = 0.0_8
          wd(1, j, k, irho) = wd(1, j, k, irho) + w(1, j, k, ivy)*tmpd6
          wd(1, j, k, ivy) = wd(1, j, k, ivy) + w(1, j, k, irho)*tmpd6
          call popreal8(w(1, j, k, ivx))
          tmpd5 = wd(1, j, k, ivx)
          wd(1, j, k, ivx) = 0.0_8
          wd(1, j, k, irho) = wd(1, j, k, irho) + w(1, j, k, ivx)*tmpd5
          wd(1, j, k, ivx) = wd(1, j, k, ivx) + w(1, j, k, irho)*tmpd5
          call popreal8(w(0, j, k, irhoe))
          pd(0, j, k) = pd(0, j, k) + wd(0, j, k, irhoe)
          call popreal8(w(0, j, k, ivz))
          tmpd4 = wd(0, j, k, ivz)
          wd(0, j, k, ivz) = 0.0_8
          wd(0, j, k, irho) = wd(0, j, k, irho) + w(0, j, k, ivz)*tmpd4
          wd(0, j, k, ivz) = wd(0, j, k, ivz) + w(0, j, k, irho)*tmpd4
          call popreal8(w(0, j, k, ivy))
          tmpd3 = wd(0, j, k, ivy)
          wd(0, j, k, ivy) = 0.0_8
          wd(0, j, k, irho) = wd(0, j, k, irho) + w(0, j, k, ivy)*tmpd3
          wd(0, j, k, ivy) = wd(0, j, k, ivy) + w(0, j, k, irho)*tmpd3
          call popreal8(w(0, j, k, ivx))
          tmpd2 = wd(0, j, k, ivx)
          wd(0, j, k, ivx) = 0.0_8
          wd(0, j, k, irho) = wd(0, j, k, irho) + w(0, j, k, ivx)*tmpd2
          wd(0, j, k, ivx) = wd(0, j, k, ivx) + w(0, j, k, irho)*tmpd2
        end do
      end do
      do k=kb,0,-1
        do j=jl,2,-1
          do i=il,2,-1
            call popreal8(w(i, j, k, irhoe))
            pd(i, j, k) = pd(i, j, k) + wd(i, j, k, irhoe)
            call popreal8(w(i, j, k, ivz))
            tmpd1 = wd(i, j, k, ivz)
            wd(i, j, k, ivz) = 0.0_8
            wd(i, j, k, irho) = wd(i, j, k, irho) + w(i, j, k, ivz)*&
&             tmpd1
            wd(i, j, k, ivz) = wd(i, j, k, ivz) + w(i, j, k, irho)*tmpd1
            call popreal8(w(i, j, k, ivy))
            tmpd0 = wd(i, j, k, ivy)
            wd(i, j, k, ivy) = 0.0_8
            wd(i, j, k, irho) = wd(i, j, k, irho) + w(i, j, k, ivy)*&
&             tmpd0
            wd(i, j, k, ivy) = wd(i, j, k, ivy) + w(i, j, k, irho)*tmpd0
            call popreal8(w(i, j, k, ivx))
            tmpd = wd(i, j, k, ivx)
            wd(i, j, k, ivx) = 0.0_8
            wd(i, j, k, irho) = wd(i, j, k, irho) + w(i, j, k, ivx)*tmpd
            wd(i, j, k, ivx) = wd(i, j, k, ivx) + w(i, j, k, irho)*tmpd
          end do
        end do
      end do
      call popcontrol2b(branch)
      if (branch .eq. 0) then
        rhoinfd = 0.0_8
        pinfcorrd = 0.0_8
      else if (branch .eq. 1) then
        pinfcorrd = 0.001_realtype*sslimd
        rhoinfd = 0.0_8
      else
        temp = rhoinf**gammainf
        tempd = 0.001_realtype*sslimd/temp
        pinfcorrd = tempd
        if (rhoinf .le. 0.0_8 .and. (gammainf .eq. 0.0_8 .or. gammainf &
&           .ne. int(gammainf))) then
          rhoinfd = 0.0_8
        else
          rhoinfd = -(gammainf*rhoinf**(gammainf-1)*pinfcorr*tempd/temp)
        end if
      end if
    end if
  end subroutine invisciddissfluxscalarapprox_b
 
  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
 
!  differentiation of invisciddissfluxmatrixapprox in reverse (adjoint) mode (with options noisize i4 dr8 r8):
!   gradient     of useful results: pinfcorr *p *sfacei *sfacej
!                *sfacek *w *si *sj *sk *fw
!   with respect to varying inputs: pinfcorr *p *sfacei *sfacej
!                *sfacek *w *si *sj *sk *fw
!   rw status of diff variables: pinfcorr:incr *p:incr *sfacei:incr
!                *sfacej:incr *sfacek:incr *w:incr *si:incr *sj:incr
!                *sk:incr *fw:in-out
!   plus diff mem management of: p:in sfacei:in sfacej:in sfacek:in
!                w:in si:in sj:in sk:in fw:in
  subroutine invisciddissfluxmatrixapprox_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 blockpointers
    use cgnsgrid
    use constants
    use flowvarrefstate
    use inputdiscretization
    use inputphysics
    use iteration
    use utils_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) :: plimd, sfaced
    real(kind=realtype) :: sfil, fis2, fis4
    real(kind=realtype) :: gammaavg, gm1, ovgm1, gm53
    real(kind=realtype) :: ppor, rrad, dis2
    real(kind=realtype) :: rradd, dis2d
    real(kind=realtype) :: dp1, dp2, ddw, tmp, fs
    real(kind=realtype) :: dp1d, dp2d, ddwd, tmpd, fsd
    real(kind=realtype) :: dr, dru, drv, drw, dre, drk, sx, sy, sz
    real(kind=realtype) :: drd, drud, drvd, drwd, dred, drkd, sxd, syd, &
&   szd
    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, aread
    real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
    real(kind=realtype) :: abv1d, abv2d, abv3d, abv4d, abv5d, abv6d, &
&   abv7d
    logical :: correctfork
    intrinsic abs
    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) :: y1
    real(kind=realtype) :: y1d
    real(kind=realtype) :: x3
    real(kind=realtype) :: x3d
    real(kind=realtype) :: x4
    real(kind=realtype) :: x4d
    real(kind=realtype) :: y2
    real(kind=realtype) :: y2d
    real(kind=realtype) :: x5
    real(kind=realtype) :: x5d
    real(kind=realtype) :: x6
    real(kind=realtype) :: x6d
    real(kind=realtype) :: y3
    real(kind=realtype) :: y3d
    real(kind=realtype) :: abs0
    real(kind=realtype) :: min1
    real(kind=realtype) :: min1d
    real(realtype) :: max1
    real(realtype) :: max1d
    real(kind=realtype) :: min2
    real(kind=realtype) :: min2d
    real(realtype) :: max2
    real(realtype) :: max2d
    real(kind=realtype) :: min3
    real(kind=realtype) :: min3d
    real(realtype) :: max3
    real(realtype) :: max3d
    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
    real(kind=realtype) :: temp
    real(kind=realtype) :: temp0
    real(kind=realtype) :: tempd
    real(kind=realtype) :: temp1
    real(kind=realtype) :: temp2
    real(kind=realtype) :: tempd0
    real(kind=realtype) :: tempd1
    real(kind=realtype) :: tempd2
    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
! 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
!
!       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
            call pushreal8(abs1)
            abs1 = shocksensor(2, j, k) - shocksensor(1, j, k)
            call pushcontrol1b(1)
          else
            call pushreal8(abs1)
            abs1 = -(shocksensor(2, j, k)-shocksensor(1, j, k))
            call pushcontrol1b(0)
          end if
          if (shocksensor(1, j, k) - shocksensor(0, j, k) .ge. 0.) then
            call pushreal8(abs7)
            abs7 = shocksensor(1, j, k) - shocksensor(0, j, k)
            call pushcontrol1b(0)
          else
            call pushreal8(abs7)
            abs7 = -(shocksensor(1, j, k)-shocksensor(0, j, k))
            call pushcontrol1b(1)
          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
            call pushcontrol1b(0)
          else
            dp1 = -x1
            call pushcontrol1b(1)
          end if
! loop in i-direction.
          do i=1,il
            if (shocksensor(i+2, j, k) - shocksensor(i+1, j, k) .ge. 0.&
&           ) then
              call pushreal8(abs2)
              abs2 = shocksensor(i+2, j, k) - shocksensor(i+1, j, k)
              call pushcontrol1b(1)
            else
              call pushreal8(abs2)
              abs2 = -(shocksensor(i+2, j, k)-shocksensor(i+1, j, k))
              call pushcontrol1b(0)
            end if
            if (shocksensor(i+1, j, k) - shocksensor(i, j, k) .ge. 0.) &
&           then
              call pushreal8(abs8)
              abs8 = shocksensor(i+1, j, k) - shocksensor(i, j, k)
              call pushcontrol1b(0)
            else
              call pushreal8(abs8)
              abs8 = -(shocksensor(i+1, j, k)-shocksensor(i, j, k))
              call pushcontrol1b(1)
            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
              call pushcontrol1b(0)
            else
              dp2 = -x2
              call pushcontrol1b(1)
            end if
! compute the dissipation coefficients for this face.
            call pushreal8(ppor)
            ppor = zero
            if (pori(i, j, k) .eq. normalflux) ppor = one
            if (dp1 .lt. dp2) then
              y1 = dp2
              call pushcontrol1b(0)
            else
              y1 = dp1
              call pushcontrol1b(1)
            end if
            if (dpmax .gt. y1) then
              min1 = y1
              call pushcontrol1b(0)
            else
              min1 = dpmax
              call pushcontrol1b(1)
            end if
            call pushreal8(dis2)
            dis2 = fis2*ppor*min1 + sigma*fis4*ppor
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            call pushreal8(ddw)
            ddw = w(i+1, j, k, irho) - w(i, j, k, irho)
            call pushreal8(dr)
            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)
            call pushreal8(dru)
            dru = dis2*ddw
            call pushreal8(ddw)
            ddw = w(i+1, j, k, irho)*w(i+1, j, k, ivy) - w(i, j, k, irho&
&             )*w(i, j, k, ivy)
            call pushreal8(drv)
            drv = dis2*ddw
            call pushreal8(ddw)
            ddw = w(i+1, j, k, irho)*w(i+1, j, k, ivz) - w(i, j, k, irho&
&             )*w(i, j, k, ivz)
            call pushreal8(drw)
            drw = dis2*ddw
            call pushreal8(ddw)
            ddw = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
            call pushreal8(dre)
            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))
              call pushcontrol1b(1)
            else
              drk = zero
              kavg = zero
              call pushcontrol1b(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))
            call pushreal8(a2avg)
            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))
            call pushreal8(sx)
            sx = si(i, j, k, 1)
            call pushreal8(sy)
            sy = si(i, j, k, 2)
            call pushreal8(sz)
            sz = si(i, j, k, 3)
            call pushreal8(area)
            area = sqrt(sx**2 + sy**2 + sz**2)
            if (1.e-25_realtype .lt. area) then
              call pushreal8(max1)
              max1 = area
              call pushcontrol1b(0)
            else
              call pushreal8(max1)
              max1 = 1.e-25_realtype
              call pushcontrol1b(1)
            end if
            tmp = one/max1
            call pushreal8(sx)
            sx = sx*tmp
            call pushreal8(sy)
            sy = sy*tmp
            call pushreal8(sz)
            sz = sz*tmp
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            call pushreal8(havg)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            call pushreal8(aavg)
            aavg = sqrt(a2avg)
            unavg = uavg*sx + vavg*sy + wavg*sz
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
            if (addgridvelocities) then
              sface = sfacei(i, j, k)*tmp
              call pushcontrol1b(1)
            else
              call pushcontrol1b(0)
            end if
            if (unavg - sface + aavg .ge. 0.) then
              lam1 = unavg - sface + aavg
              call pushcontrol1b(0)
            else
              lam1 = -(unavg-sface+aavg)
              call pushcontrol1b(1)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2 = unavg - sface - aavg
              call pushcontrol1b(0)
            else
              lam2 = -(unavg-sface-aavg)
              call pushcontrol1b(1)
            end if
            if (unavg - sface .ge. 0.) then
              call pushreal8(lam3)
              lam3 = unavg - sface
              call pushcontrol1b(0)
            else
              call pushreal8(lam3)
              lam3 = -(unavg-sface)
              call pushcontrol1b(1)
            end if
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              lam1 = epsacoustic*rrad
              call pushcontrol1b(0)
            else
              call pushcontrol1b(1)
              lam1 = lam1
            end if
            if (lam2 .lt. epsacoustic*rrad) then
              lam2 = epsacoustic*rrad
              call pushcontrol1b(0)
            else
              call pushcontrol1b(1)
              lam2 = lam2
            end if
            if (lam3 .lt. epsshear*rrad) then
              lam3 = epsshear*rrad
              call pushcontrol1b(0)
            else
              lam3 = lam3
              call pushcontrol1b(1)
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            call pushreal8(lam1)
            lam1 = lam1*area
            call pushreal8(lam2)
            lam2 = lam2*area
            call pushreal8(lam3)
            lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1 = half*(lam1+lam2)
            call pushreal8(abv2)
            abv2 = half*(lam1-lam2)
            call pushreal8(abv3)
            abv3 = abv1 - lam3
            call pushreal8(abv4)
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
! compute and scatter the dissipative flux.
! density.
! x-momentum.
! y-momentum.
! z-momentum.
! energy.
! 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
            call pushreal8(abs3)
            abs3 = shocksensor(i, 2, k) - shocksensor(i, 1, k)
            call pushcontrol1b(1)
          else
            call pushreal8(abs3)
            abs3 = -(shocksensor(i, 2, k)-shocksensor(i, 1, k))
            call pushcontrol1b(0)
          end if
          if (shocksensor(i, 1, k) - shocksensor(i, 0, k) .ge. 0.) then
            call pushreal8(abs9)
            abs9 = shocksensor(i, 1, k) - shocksensor(i, 0, k)
            call pushcontrol1b(0)
          else
            call pushreal8(abs9)
            abs9 = -(shocksensor(i, 1, k)-shocksensor(i, 0, k))
            call pushcontrol1b(1)
          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
            call pushcontrol1b(0)
          else
            dp1 = -x3
            call pushcontrol1b(1)
          end if
! loop in j-direction.
          do j=1,jl
            if (shocksensor(i, j+2, k) - shocksensor(i, j+1, k) .ge. 0.&
&           ) then
              call pushreal8(abs4)
              abs4 = shocksensor(i, j+2, k) - shocksensor(i, j+1, k)
              call pushcontrol1b(1)
            else
              call pushreal8(abs4)
              abs4 = -(shocksensor(i, j+2, k)-shocksensor(i, j+1, k))
              call pushcontrol1b(0)
            end if
            if (shocksensor(i, j+1, k) - shocksensor(i, j, k) .ge. 0.) &
&           then
              call pushreal8(abs10)
              abs10 = shocksensor(i, j+1, k) - shocksensor(i, j, k)
              call pushcontrol1b(0)
            else
              call pushreal8(abs10)
              abs10 = -(shocksensor(i, j+1, k)-shocksensor(i, j, k))
              call pushcontrol1b(1)
            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
              call pushcontrol1b(0)
            else
              dp2 = -x4
              call pushcontrol1b(1)
            end if
! compute the dissipation coefficients for this face.
            call pushreal8(ppor)
            ppor = zero
            if (porj(i, j, k) .eq. normalflux) ppor = one
            if (dp1 .lt. dp2) then
              y2 = dp2
              call pushcontrol1b(0)
            else
              y2 = dp1
              call pushcontrol1b(1)
            end if
            if (dpmax .gt. y2) then
              min2 = y2
              call pushcontrol1b(0)
            else
              min2 = dpmax
              call pushcontrol1b(1)
            end if
            call pushreal8(dis2)
            dis2 = fis2*ppor*min2 + sigma*fis4*ppor
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            call pushreal8(ddw)
            ddw = w(i, j+1, k, irho) - w(i, j, k, irho)
            call pushreal8(dr)
            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)
            call pushreal8(dru)
            dru = dis2*ddw
            call pushreal8(ddw)
            ddw = w(i, j+1, k, irho)*w(i, j+1, k, ivy) - w(i, j, k, irho&
&             )*w(i, j, k, ivy)
            call pushreal8(drv)
            drv = dis2*ddw
            call pushreal8(ddw)
            ddw = w(i, j+1, k, irho)*w(i, j+1, k, ivz) - w(i, j, k, irho&
&             )*w(i, j, k, ivz)
            call pushreal8(drw)
            drw = dis2*ddw
            call pushreal8(ddw)
            ddw = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
            call pushreal8(dre)
            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))
              call pushcontrol1b(1)
            else
              drk = zero
              kavg = zero
              call pushcontrol1b(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))
            call pushreal8(a2avg)
            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))
            call pushreal8(sx)
            sx = sj(i, j, k, 1)
            call pushreal8(sy)
            sy = sj(i, j, k, 2)
            call pushreal8(sz)
            sz = sj(i, j, k, 3)
            call pushreal8(area)
            area = sqrt(sx**2 + sy**2 + sz**2)
            if (1.e-25_realtype .lt. area) then
              call pushreal8(max2)
              max2 = area
              call pushcontrol1b(0)
            else
              call pushreal8(max2)
              max2 = 1.e-25_realtype
              call pushcontrol1b(1)
            end if
            tmp = one/max2
            call pushreal8(sx)
            sx = sx*tmp
            call pushreal8(sy)
            sy = sy*tmp
            call pushreal8(sz)
            sz = sz*tmp
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            call pushreal8(havg)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            call pushreal8(aavg)
            aavg = sqrt(a2avg)
            unavg = uavg*sx + vavg*sy + wavg*sz
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
            if (addgridvelocities) then
              sface = sfacej(i, j, k)*tmp
              call pushcontrol1b(1)
            else
              call pushcontrol1b(0)
            end if
            if (unavg - sface + aavg .ge. 0.) then
              lam1 = unavg - sface + aavg
              call pushcontrol1b(0)
            else
              lam1 = -(unavg-sface+aavg)
              call pushcontrol1b(1)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2 = unavg - sface - aavg
              call pushcontrol1b(0)
            else
              lam2 = -(unavg-sface-aavg)
              call pushcontrol1b(1)
            end if
            if (unavg - sface .ge. 0.) then
              call pushreal8(lam3)
              lam3 = unavg - sface
              call pushcontrol1b(0)
            else
              call pushreal8(lam3)
              lam3 = -(unavg-sface)
              call pushcontrol1b(1)
            end if
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              lam1 = epsacoustic*rrad
              call pushcontrol1b(0)
            else
              call pushcontrol1b(1)
              lam1 = lam1
            end if
            if (lam2 .lt. epsacoustic*rrad) then
              lam2 = epsacoustic*rrad
              call pushcontrol1b(0)
            else
              call pushcontrol1b(1)
              lam2 = lam2
            end if
            if (lam3 .lt. epsshear*rrad) then
              lam3 = epsshear*rrad
              call pushcontrol1b(0)
            else
              lam3 = lam3
              call pushcontrol1b(1)
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            call pushreal8(lam1)
            lam1 = lam1*area
            call pushreal8(lam2)
            lam2 = lam2*area
            call pushreal8(lam3)
            lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1 = half*(lam1+lam2)
            call pushreal8(abv2)
            abv2 = half*(lam1-lam2)
            call pushreal8(abv3)
            abv3 = abv1 - lam3
            call pushreal8(abv4)
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
! compute and scatter the dissipative flux.
! density.
! x-momentum.
! y-momentum.
! z-momentum.
! energy.
! 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
            call pushreal8(abs5)
            abs5 = shocksensor(i, j, 2) - shocksensor(i, j, 1)
            call pushcontrol1b(1)
          else
            call pushreal8(abs5)
            abs5 = -(shocksensor(i, j, 2)-shocksensor(i, j, 1))
            call pushcontrol1b(0)
          end if
          if (shocksensor(i, j, 1) - shocksensor(i, j, 0) .ge. 0.) then
            call pushreal8(abs11)
            abs11 = shocksensor(i, j, 1) - shocksensor(i, j, 0)
            call pushcontrol1b(0)
          else
            call pushreal8(abs11)
            abs11 = -(shocksensor(i, j, 1)-shocksensor(i, j, 0))
            call pushcontrol1b(1)
          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
            call pushcontrol1b(0)
          else
            dp1 = -x5
            call pushcontrol1b(1)
          end if
! loop in k-direction.
          do k=1,kl
            if (shocksensor(i, j, k+2) - shocksensor(i, j, k+1) .ge. 0.&
&           ) then
              call pushreal8(abs6)
              abs6 = shocksensor(i, j, k+2) - shocksensor(i, j, k+1)
              call pushcontrol1b(1)
            else
              call pushreal8(abs6)
              abs6 = -(shocksensor(i, j, k+2)-shocksensor(i, j, k+1))
              call pushcontrol1b(0)
            end if
            if (shocksensor(i, j, k+1) - shocksensor(i, j, k) .ge. 0.) &
&           then
              call pushreal8(abs12)
              abs12 = shocksensor(i, j, k+1) - shocksensor(i, j, k)
              call pushcontrol1b(0)
            else
              call pushreal8(abs12)
              abs12 = -(shocksensor(i, j, k+1)-shocksensor(i, j, k))
              call pushcontrol1b(1)
            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
              call pushcontrol1b(0)
            else
              dp2 = -x6
              call pushcontrol1b(1)
            end if
! compute the dissipation coefficients for this face.
            call pushreal8(ppor)
            ppor = zero
            if (pork(i, j, k) .eq. normalflux) ppor = one
            if (dp1 .lt. dp2) then
              y3 = dp2
              call pushcontrol1b(0)
            else
              y3 = dp1
              call pushcontrol1b(1)
            end if
            if (dpmax .gt. y3) then
              min3 = y3
              call pushcontrol1b(0)
            else
              min3 = dpmax
              call pushcontrol1b(1)
            end if
            call pushreal8(dis2)
            dis2 = fis2*ppor*min3 + sigma*fis4*ppor
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            call pushreal8(ddw)
            ddw = w(i, j, k+1, irho) - w(i, j, k, irho)
            call pushreal8(dr)
            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)
            call pushreal8(dru)
            dru = dis2*ddw
            call pushreal8(ddw)
            ddw = w(i, j, k+1, irho)*w(i, j, k+1, ivy) - w(i, j, k, irho&
&             )*w(i, j, k, ivy)
            call pushreal8(drv)
            drv = dis2*ddw
            call pushreal8(ddw)
            ddw = w(i, j, k+1, irho)*w(i, j, k+1, ivz) - w(i, j, k, irho&
&             )*w(i, j, k, ivz)
            call pushreal8(drw)
            drw = dis2*ddw
            call pushreal8(ddw)
            ddw = w(i, j, k+1, irhoe) - w(i, j, k, irhoe)
            call pushreal8(dre)
            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))
              call pushcontrol1b(1)
            else
              drk = zero
              kavg = zero
              call pushcontrol1b(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))
            call pushreal8(a2avg)
            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))
            call pushreal8(sx)
            sx = sk(i, j, k, 1)
            call pushreal8(sy)
            sy = sk(i, j, k, 2)
            call pushreal8(sz)
            sz = sk(i, j, k, 3)
            call pushreal8(area)
            area = sqrt(sx**2 + sy**2 + sz**2)
            if (1.e-25_realtype .lt. area) then
              call pushreal8(max3)
              max3 = area
              call pushcontrol1b(0)
            else
              call pushreal8(max3)
              max3 = 1.e-25_realtype
              call pushcontrol1b(1)
            end if
            tmp = one/max3
            call pushreal8(sx)
            sx = sx*tmp
            call pushreal8(sy)
            sy = sy*tmp
            call pushreal8(sz)
            sz = sz*tmp
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            call pushreal8(havg)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            call pushreal8(aavg)
            aavg = sqrt(a2avg)
            unavg = uavg*sx + vavg*sy + wavg*sz
! the mesh velocity if the face is moving. it must be
! divided by the area to obtain a true velocity.
            if (addgridvelocities) then
              sface = sfacek(i, j, k)*tmp
              call pushcontrol1b(1)
            else
              call pushcontrol1b(0)
            end if
            if (unavg - sface + aavg .ge. 0.) then
              lam1 = unavg - sface + aavg
              call pushcontrol1b(0)
            else
              lam1 = -(unavg-sface+aavg)
              call pushcontrol1b(1)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2 = unavg - sface - aavg
              call pushcontrol1b(0)
            else
              lam2 = -(unavg-sface-aavg)
              call pushcontrol1b(1)
            end if
            if (unavg - sface .ge. 0.) then
              call pushreal8(lam3)
              lam3 = unavg - sface
              call pushcontrol1b(0)
            else
              call pushreal8(lam3)
              lam3 = -(unavg-sface)
              call pushcontrol1b(1)
            end if
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              lam1 = epsacoustic*rrad
              call pushcontrol1b(0)
            else
              call pushcontrol1b(1)
              lam1 = lam1
            end if
            if (lam2 .lt. epsacoustic*rrad) then
              lam2 = epsacoustic*rrad
              call pushcontrol1b(0)
            else
              call pushcontrol1b(1)
              lam2 = lam2
            end if
            if (lam3 .lt. epsshear*rrad) then
              lam3 = epsshear*rrad
              call pushcontrol1b(0)
            else
              lam3 = lam3
              call pushcontrol1b(1)
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            call pushreal8(lam1)
            lam1 = lam1*area
            call pushreal8(lam2)
            lam2 = lam2*area
            call pushreal8(lam3)
            lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1 = half*(lam1+lam2)
            call pushreal8(abv2)
            abv2 = half*(lam1-lam2)
            call pushreal8(abv3)
            abv3 = abv1 - lam3
            call pushreal8(abv4)
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
! compute and scatter the dissipative flux.
! density.
! x-momentum.
! y-momentum.
! z-momentum.
! energy.
! set dp1 to dp2 for the next face.
            dp1 = dp2
          end do
        end do
      end do
      plimd = 0.0_8
      sfaced = 0.0_8
      do j=jl,2,-1
        do i=il,2,-1
          dp1d = 0.0_8
          do k=kl,1,-1
            dp2d = dp1d
            fsd = fwd(i, j, k+1, irhoe) - fwd(i, j, k, irhoe)
            wavg = half*(w(i, j, k+1, ivz)+w(i, j, k, ivz))
            vavg = half*(w(i, j, k+1, ivy)+w(i, j, k, ivy))
            uavg = half*(w(i, j, k+1, ivx)+w(i, j, k, ivx))
            unavg = uavg*sx + vavg*sy + wavg*sz
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            ovaavg = one/aavg
            ova2avg = one/a2avg
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7 = abv2*abv4*ovaavg + abv3*abv5
            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
            szd = abv7*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
            syd = abv7*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
            sxd = abv7*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
            sxd = sxd + dru*abv5d
            syd = syd + drv*abv5d
            szd = szd + drw*abv5d
            unavgd = unavgd - dr*abv5d
            gammaavg = half*(gamma(i, j, k+1)+gamma(i, j, k))
            gm1 = gammaavg - one
            gm53 = gammaavg - five*third
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            call popreal8(abv4)
            tempd0 = gm1*abv4d
            drd = lam3*fsd + alphaavg*tempd0 - unavg*abv5d
            drud = drud + sx*abv5d - uavg*tempd0
            drvd = drvd + sy*abv5d - vavg*tempd0
            drwd = drwd + sz*abv5d - wavg*tempd0
            drkd = -(gm53*abv4d)
            alphaavgd = dr*tempd0
            uavgd = uavgd - dru*tempd0
            vavgd = vavgd - drv*tempd0
            dred = dred + tempd0
            wavgd = wavgd - drw*tempd0
            call popreal8(abv3)
            abv1d = abv3d
            call popreal8(abv2)
            lam1d = half*abv2d + half*abv1d
            lam2d = half*abv1d - half*abv2d
            call popreal8(lam3)
            call popreal8(lam2)
            call popreal8(lam1)
            aread = lam3*lam3d + lam2*lam2d + lam1*lam1d
            lam3d = area*lam3d
            lam2d = area*lam2d
            lam1d = area*lam1d
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              rradd = epsshear*lam3d
              lam3d = 0.0_8
            else
              rradd = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              rradd = rradd + epsacoustic*lam2d
              lam2d = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              rradd = rradd + epsacoustic*lam1d
              lam1d = 0.0_8
            end if
            lam3d = lam3d + rradd
            aavgd = rradd
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(lam3)
              unavgd = unavgd + lam3d
              sfaced = sfaced - lam3d
            else
              call popreal8(lam3)
              sfaced = sfaced + lam3d
              unavgd = unavgd - lam3d
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              unavgd = unavgd + lam2d
              sfaced = sfaced - lam2d
              aavgd = aavgd - lam2d
            else
              sfaced = sfaced + lam2d
              unavgd = unavgd - lam2d
              aavgd = aavgd + lam2d
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              unavgd = unavgd + lam1d
              sfaced = sfaced - lam1d
              aavgd = aavgd + lam1d
            else
              sfaced = sfaced + lam1d
              unavgd = unavgd - lam1d
              aavgd = aavgd - lam1d
            end if
            tmp = one/max3
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              tmpd = 0.0_8
            else
              sfacekd(i, j, k) = sfacekd(i, j, k) + tmp*sfaced
              tmpd = sfacek(i, j, k)*sfaced
              sfaced = 0.0_8
            end if
            alphaavgd = alphaavgd + havgd
            tempd0 = half*alphaavgd
            ovgm1 = one/gm1
            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*tempd0
            sxd = sxd + uavg*unavgd
            vavgd = vavgd + sy*unavgd + 2*vavg*tempd0
            syd = syd + vavg*unavgd
            wavgd = wavgd + sz*unavgd + 2*wavg*tempd0
            szd = szd + wavg*unavgd
            call popreal8(aavg)
            call popreal8(havg)
            kavgd = -(gm53*ovgm1*havgd)
            call popreal8(sz)
            call popreal8(sy)
            call popreal8(sx)
            tmpd = tmpd + sz*szd + sy*syd + sx*sxd
            szd = tmp*szd
            syd = tmp*syd
            sxd = tmp*sxd
            max3d = -(one*tmpd/max3**2)
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(max3)
              aread = aread + max3d
            else
              call popreal8(max3)
            end if
            call popreal8(area)
            if (sx**2 + sy**2 + sz**2 .eq. 0.0_8) then
              tempd0 = 0.0_8
            else
              tempd0 = aread/(2.0*sqrt(sx**2+sy**2+sz**2))
            end if
            sxd = sxd + 2*sx*tempd0
            syd = syd + 2*sy*tempd0
            szd = szd + 2*sz*tempd0
            call popreal8(sz)
            skd(i, j, k, 3) = skd(i, j, k, 3) + szd
            call popreal8(sy)
            skd(i, j, k, 2) = skd(i, j, k, 2) + syd
            call popreal8(sx)
            skd(i, j, k, 1) = skd(i, j, k, 1) + sxd
            call popreal8(a2avg)
            temp2 = w(i, j, k+1, irho)
            temp0 = w(i, j, k, irho)
            tempd1 = gamma(i, j, k+1)*half*a2avgd/temp2
            tempd2 = gamma(i, j, k)*half*a2avgd/temp0
            pd(i, j, k) = pd(i, j, k) + tempd2
            wd(i, j, k, irho) = wd(i, j, k, irho) - p(i, j, k)*tempd2/&
&             temp0
            pd(i, j, k+1) = pd(i, j, k+1) + tempd1
            wd(i, j, k+1, irho) = wd(i, j, k+1, irho) - p(i, j, k+1)*&
&             tempd1/temp2
            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
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              dis2d = 0.0_8
            else
              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
              dis2d = ddw*drkd
              ddwd = dis2*drkd
              wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, &
&               itu1)*ddwd
              wd(i, j, k+1, itu1) = wd(i, j, k+1, itu1) + w(i, j, k+1, &
&               irho)*ddwd
              wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, itu1)*&
&               ddwd
              wd(i, j, k, itu1) = wd(i, j, k, itu1) - w(i, j, k, irho)*&
&               ddwd
              ddw = w(i, j, k+1, irhoe) - w(i, j, k, irhoe)
            end if
            call popreal8(dre)
            dis2d = dis2d + ddw*dred
            ddwd = dis2*dred
            call popreal8(ddw)
            wd(i, j, k+1, irhoe) = wd(i, j, k+1, irhoe) + ddwd
            wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddwd
            call popreal8(drw)
            dis2d = dis2d + ddw*drwd
            ddwd = dis2*drwd
            call popreal8(ddw)
            wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, ivz&
&             )*ddwd
            wd(i, j, k+1, ivz) = wd(i, j, k+1, ivz) + w(i, j, k+1, irho)&
&             *ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivz)*ddwd
            wd(i, j, k, ivz) = wd(i, j, k, ivz) - w(i, j, k, irho)*ddwd
            call popreal8(drv)
            dis2d = dis2d + ddw*drvd
            ddwd = dis2*drvd
            call popreal8(ddw)
            wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, ivy&
&             )*ddwd
            wd(i, j, k+1, ivy) = wd(i, j, k+1, ivy) + w(i, j, k+1, irho)&
&             *ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivy)*ddwd
            wd(i, j, k, ivy) = wd(i, j, k, ivy) - w(i, j, k, irho)*ddwd
            call popreal8(dru)
            dis2d = dis2d + ddw*drud
            ddwd = dis2*drud
            wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + w(i, j, k+1, ivx&
&             )*ddwd
            wd(i, j, k+1, ivx) = wd(i, j, k+1, ivx) + w(i, j, k+1, irho)&
&             *ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivx)*ddwd
            wd(i, j, k, ivx) = wd(i, j, k, ivx) - w(i, j, k, irho)*ddwd
            ddw = w(i, j, k+1, irho) - w(i, j, k, irho)
            call popreal8(dr)
            dis2d = dis2d + ddw*drd
            ddwd = dis2*drd
            call popreal8(ddw)
            wd(i, j, k+1, irho) = wd(i, j, k+1, irho) + ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - ddwd
            call popreal8(dis2)
            min3d = fis2*ppor*dis2d
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              y3d = min3d
            else
              y3d = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              dp2d = dp2d + y3d
              dp1d = 0.0_8
            else
              dp1d = y3d
            end if
            call popreal8(ppor)
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              x6d = dp2d
            else
              x6d = -dp2d
            end if
            temp2 = omega*(shocksensor(i, j, k+2)+two*shocksensor(i, j, &
&             k+1)+shocksensor(i, j, k)) + oneminomega*(abs6+abs12) + &
&             plim
            plimd = plimd - (shocksensor(i, j, k+2)-two*shocksensor(i, j&
&             , k+1)+shocksensor(i, j, k))*x6d/temp2**2
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(abs12)
            else
              call popreal8(abs12)
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(abs6)
            else
              call popreal8(abs6)
            end if
          end do
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            x5d = dp1d
          else
            x5d = -dp1d
          end if
          temp2 = omega*(shocksensor(i, j, 2)+two*shocksensor(i, j, 1)+&
&           shocksensor(i, j, 0)) + oneminomega*(abs5+abs11) + plim
          plimd = plimd - (shocksensor(i, j, 2)-two*shocksensor(i, j, 1)&
&           +shocksensor(i, j, 0))*x5d/temp2**2
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(abs11)
          else
            call popreal8(abs11)
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(abs5)
          else
            call popreal8(abs5)
          end if
        end do
      end do
      do k=kl,2,-1
        do i=il,2,-1
          dp1d = 0.0_8
          do j=jl,1,-1
            dp2d = dp1d
            fsd = fwd(i, j+1, k, irhoe) - fwd(i, j, k, irhoe)
            wavg = half*(w(i, j+1, k, ivz)+w(i, j, k, ivz))
            vavg = half*(w(i, j+1, k, ivy)+w(i, j, k, ivy))
            uavg = half*(w(i, j+1, k, ivx)+w(i, j, k, ivx))
            unavg = uavg*sx + vavg*sy + wavg*sz
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            ovaavg = one/aavg
            ova2avg = one/a2avg
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7 = abv2*abv4*ovaavg + abv3*abv5
            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
            szd = abv7*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
            syd = abv7*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
            sxd = abv7*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
            sxd = sxd + dru*abv5d
            syd = syd + drv*abv5d
            szd = szd + drw*abv5d
            unavgd = unavgd - dr*abv5d
            gammaavg = half*(gamma(i, j+1, k)+gamma(i, j, k))
            gm1 = gammaavg - one
            gm53 = gammaavg - five*third
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            call popreal8(abv4)
            tempd0 = gm1*abv4d
            drd = lam3*fsd + alphaavg*tempd0 - unavg*abv5d
            drud = drud + sx*abv5d - uavg*tempd0
            drvd = drvd + sy*abv5d - vavg*tempd0
            drwd = drwd + sz*abv5d - wavg*tempd0
            drkd = -(gm53*abv4d)
            alphaavgd = dr*tempd0
            uavgd = uavgd - dru*tempd0
            vavgd = vavgd - drv*tempd0
            dred = dred + tempd0
            wavgd = wavgd - drw*tempd0
            call popreal8(abv3)
            abv1d = abv3d
            call popreal8(abv2)
            lam1d = half*abv2d + half*abv1d
            lam2d = half*abv1d - half*abv2d
            call popreal8(lam3)
            call popreal8(lam2)
            call popreal8(lam1)
            aread = lam3*lam3d + lam2*lam2d + lam1*lam1d
            lam3d = area*lam3d
            lam2d = area*lam2d
            lam1d = area*lam1d
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              rradd = epsshear*lam3d
              lam3d = 0.0_8
            else
              rradd = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              rradd = rradd + epsacoustic*lam2d
              lam2d = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              rradd = rradd + epsacoustic*lam1d
              lam1d = 0.0_8
            end if
            lam3d = lam3d + rradd
            aavgd = rradd
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(lam3)
              unavgd = unavgd + lam3d
              sfaced = sfaced - lam3d
            else
              call popreal8(lam3)
              sfaced = sfaced + lam3d
              unavgd = unavgd - lam3d
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              unavgd = unavgd + lam2d
              sfaced = sfaced - lam2d
              aavgd = aavgd - lam2d
            else
              sfaced = sfaced + lam2d
              unavgd = unavgd - lam2d
              aavgd = aavgd + lam2d
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              unavgd = unavgd + lam1d
              sfaced = sfaced - lam1d
              aavgd = aavgd + lam1d
            else
              sfaced = sfaced + lam1d
              unavgd = unavgd - lam1d
              aavgd = aavgd - lam1d
            end if
            tmp = one/max2
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              tmpd = 0.0_8
            else
              sfacejd(i, j, k) = sfacejd(i, j, k) + tmp*sfaced
              tmpd = sfacej(i, j, k)*sfaced
              sfaced = 0.0_8
            end if
            alphaavgd = alphaavgd + havgd
            tempd0 = half*alphaavgd
            ovgm1 = one/gm1
            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*tempd0
            sxd = sxd + uavg*unavgd
            vavgd = vavgd + sy*unavgd + 2*vavg*tempd0
            syd = syd + vavg*unavgd
            wavgd = wavgd + sz*unavgd + 2*wavg*tempd0
            szd = szd + wavg*unavgd
            call popreal8(aavg)
            call popreal8(havg)
            kavgd = -(gm53*ovgm1*havgd)
            call popreal8(sz)
            call popreal8(sy)
            call popreal8(sx)
            tmpd = tmpd + sz*szd + sy*syd + sx*sxd
            szd = tmp*szd
            syd = tmp*syd
            sxd = tmp*sxd
            max2d = -(one*tmpd/max2**2)
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(max2)
              aread = aread + max2d
            else
              call popreal8(max2)
            end if
            call popreal8(area)
            if (sx**2 + sy**2 + sz**2 .eq. 0.0_8) then
              tempd0 = 0.0_8
            else
              tempd0 = aread/(2.0*sqrt(sx**2+sy**2+sz**2))
            end if
            sxd = sxd + 2*sx*tempd0
            syd = syd + 2*sy*tempd0
            szd = szd + 2*sz*tempd0
            call popreal8(sz)
            sjd(i, j, k, 3) = sjd(i, j, k, 3) + szd
            call popreal8(sy)
            sjd(i, j, k, 2) = sjd(i, j, k, 2) + syd
            call popreal8(sx)
            sjd(i, j, k, 1) = sjd(i, j, k, 1) + sxd
            call popreal8(a2avg)
            temp2 = w(i, j+1, k, irho)
            temp0 = w(i, j, k, irho)
            tempd1 = gamma(i, j+1, k)*half*a2avgd/temp2
            tempd2 = gamma(i, j, k)*half*a2avgd/temp0
            pd(i, j, k) = pd(i, j, k) + tempd2
            wd(i, j, k, irho) = wd(i, j, k, irho) - p(i, j, k)*tempd2/&
&             temp0
            pd(i, j+1, k) = pd(i, j+1, k) + tempd1
            wd(i, j+1, k, irho) = wd(i, j+1, k, irho) - p(i, j+1, k)*&
&             tempd1/temp2
            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
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              dis2d = 0.0_8
            else
              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
              dis2d = ddw*drkd
              ddwd = dis2*drkd
              wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, &
&               itu1)*ddwd
              wd(i, j+1, k, itu1) = wd(i, j+1, k, itu1) + w(i, j+1, k, &
&               irho)*ddwd
              wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, itu1)*&
&               ddwd
              wd(i, j, k, itu1) = wd(i, j, k, itu1) - w(i, j, k, irho)*&
&               ddwd
              ddw = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
            end if
            call popreal8(dre)
            dis2d = dis2d + ddw*dred
            ddwd = dis2*dred
            call popreal8(ddw)
            wd(i, j+1, k, irhoe) = wd(i, j+1, k, irhoe) + ddwd
            wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddwd
            call popreal8(drw)
            dis2d = dis2d + ddw*drwd
            ddwd = dis2*drwd
            call popreal8(ddw)
            wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, ivz&
&             )*ddwd
            wd(i, j+1, k, ivz) = wd(i, j+1, k, ivz) + w(i, j+1, k, irho)&
&             *ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivz)*ddwd
            wd(i, j, k, ivz) = wd(i, j, k, ivz) - w(i, j, k, irho)*ddwd
            call popreal8(drv)
            dis2d = dis2d + ddw*drvd
            ddwd = dis2*drvd
            call popreal8(ddw)
            wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, ivy&
&             )*ddwd
            wd(i, j+1, k, ivy) = wd(i, j+1, k, ivy) + w(i, j+1, k, irho)&
&             *ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivy)*ddwd
            wd(i, j, k, ivy) = wd(i, j, k, ivy) - w(i, j, k, irho)*ddwd
            call popreal8(dru)
            dis2d = dis2d + ddw*drud
            ddwd = dis2*drud
            wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + w(i, j+1, k, ivx&
&             )*ddwd
            wd(i, j+1, k, ivx) = wd(i, j+1, k, ivx) + w(i, j+1, k, irho)&
&             *ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivx)*ddwd
            wd(i, j, k, ivx) = wd(i, j, k, ivx) - w(i, j, k, irho)*ddwd
            ddw = w(i, j+1, k, irho) - w(i, j, k, irho)
            call popreal8(dr)
            dis2d = dis2d + ddw*drd
            ddwd = dis2*drd
            call popreal8(ddw)
            wd(i, j+1, k, irho) = wd(i, j+1, k, irho) + ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - ddwd
            call popreal8(dis2)
            min2d = fis2*ppor*dis2d
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              y2d = min2d
            else
              y2d = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              dp2d = dp2d + y2d
              dp1d = 0.0_8
            else
              dp1d = y2d
            end if
            call popreal8(ppor)
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              x4d = dp2d
            else
              x4d = -dp2d
            end if
            temp2 = omega*(shocksensor(i, j+2, k)+two*shocksensor(i, j+1&
&             , k)+shocksensor(i, j, k)) + oneminomega*(abs4+abs10) + &
&             plim
            plimd = plimd - (shocksensor(i, j+2, k)-two*shocksensor(i, j&
&             +1, k)+shocksensor(i, j, k))*x4d/temp2**2
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(abs10)
            else
              call popreal8(abs10)
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(abs4)
            else
              call popreal8(abs4)
            end if
          end do
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            x3d = dp1d
          else
            x3d = -dp1d
          end if
          temp2 = omega*(shocksensor(i, 2, k)+two*shocksensor(i, 1, k)+&
&           shocksensor(i, 0, k)) + oneminomega*(abs3+abs9) + plim
          plimd = plimd - (shocksensor(i, 2, k)-two*shocksensor(i, 1, k)&
&           +shocksensor(i, 0, k))*x3d/temp2**2
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(abs9)
          else
            call popreal8(abs9)
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(abs3)
          else
            call popreal8(abs3)
          end if
        end do
      end do
      do k=kl,2,-1
        do j=jl,2,-1
          dp1d = 0.0_8
          do i=il,1,-1
            dp2d = dp1d
            fsd = fwd(i+1, j, k, irhoe) - fwd(i, j, k, irhoe)
            wavg = half*(w(i+1, j, k, ivz)+w(i, j, k, ivz))
            vavg = half*(w(i+1, j, k, ivy)+w(i, j, k, ivy))
            uavg = half*(w(i+1, j, k, ivx)+w(i, j, k, ivx))
            unavg = uavg*sx + vavg*sy + wavg*sz
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            ovaavg = one/aavg
            ova2avg = one/a2avg
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7 = abv2*abv4*ovaavg + abv3*abv5
            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
            szd = abv7*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
            syd = abv7*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
            sxd = abv7*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
            sxd = sxd + dru*abv5d
            syd = syd + drv*abv5d
            szd = szd + drw*abv5d
            unavgd = unavgd - dr*abv5d
            gammaavg = half*(gamma(i+1, j, k)+gamma(i, j, k))
            gm1 = gammaavg - one
            gm53 = gammaavg - five*third
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            call popreal8(abv4)
            tempd0 = gm1*abv4d
            drd = lam3*fsd + alphaavg*tempd0 - unavg*abv5d
            drud = drud + sx*abv5d - uavg*tempd0
            drvd = drvd + sy*abv5d - vavg*tempd0
            drwd = drwd + sz*abv5d - wavg*tempd0
            drkd = -(gm53*abv4d)
            alphaavgd = dr*tempd0
            uavgd = uavgd - dru*tempd0
            vavgd = vavgd - drv*tempd0
            dred = dred + tempd0
            wavgd = wavgd - drw*tempd0
            call popreal8(abv3)
            abv1d = abv3d
            call popreal8(abv2)
            lam1d = half*abv2d + half*abv1d
            lam2d = half*abv1d - half*abv2d
            call popreal8(lam3)
            call popreal8(lam2)
            call popreal8(lam1)
            aread = lam3*lam3d + lam2*lam2d + lam1*lam1d
            lam3d = area*lam3d
            lam2d = area*lam2d
            lam1d = area*lam1d
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              rradd = epsshear*lam3d
              lam3d = 0.0_8
            else
              rradd = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              rradd = rradd + epsacoustic*lam2d
              lam2d = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              rradd = rradd + epsacoustic*lam1d
              lam1d = 0.0_8
            end if
            lam3d = lam3d + rradd
            aavgd = rradd
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(lam3)
              unavgd = unavgd + lam3d
              sfaced = sfaced - lam3d
            else
              call popreal8(lam3)
              sfaced = sfaced + lam3d
              unavgd = unavgd - lam3d
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              unavgd = unavgd + lam2d
              sfaced = sfaced - lam2d
              aavgd = aavgd - lam2d
            else
              sfaced = sfaced + lam2d
              unavgd = unavgd - lam2d
              aavgd = aavgd + lam2d
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              unavgd = unavgd + lam1d
              sfaced = sfaced - lam1d
              aavgd = aavgd + lam1d
            else
              sfaced = sfaced + lam1d
              unavgd = unavgd - lam1d
              aavgd = aavgd - lam1d
            end if
            tmp = one/max1
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              tmpd = 0.0_8
            else
              sfaceid(i, j, k) = sfaceid(i, j, k) + tmp*sfaced
              tmpd = sfacei(i, j, k)*sfaced
              sfaced = 0.0_8
            end if
            alphaavgd = alphaavgd + havgd
            tempd0 = half*alphaavgd
            ovgm1 = one/gm1
            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*tempd0
            sxd = sxd + uavg*unavgd
            vavgd = vavgd + sy*unavgd + 2*vavg*tempd0
            syd = syd + vavg*unavgd
            wavgd = wavgd + sz*unavgd + 2*wavg*tempd0
            szd = szd + wavg*unavgd
            call popreal8(aavg)
            call popreal8(havg)
            kavgd = -(gm53*ovgm1*havgd)
            call popreal8(sz)
            call popreal8(sy)
            call popreal8(sx)
            tmpd = tmpd + sz*szd + sy*syd + sx*sxd
            szd = tmp*szd
            syd = tmp*syd
            sxd = tmp*sxd
            max1d = -(one*tmpd/max1**2)
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(max1)
              aread = aread + max1d
            else
              call popreal8(max1)
            end if
            call popreal8(area)
            if (sx**2 + sy**2 + sz**2 .eq. 0.0_8) then
              tempd0 = 0.0_8
            else
              tempd0 = aread/(2.0*sqrt(sx**2+sy**2+sz**2))
            end if
            sxd = sxd + 2*sx*tempd0
            syd = syd + 2*sy*tempd0
            szd = szd + 2*sz*tempd0
            call popreal8(sz)
            sid(i, j, k, 3) = sid(i, j, k, 3) + szd
            call popreal8(sy)
            sid(i, j, k, 2) = sid(i, j, k, 2) + syd
            call popreal8(sx)
            sid(i, j, k, 1) = sid(i, j, k, 1) + sxd
            call popreal8(a2avg)
            temp = w(i+1, j, k, irho)
            temp1 = w(i, j, k, irho)
            tempd = gamma(i+1, j, k)*half*a2avgd/temp
            tempd0 = gamma(i, j, k)*half*a2avgd/temp1
            pd(i, j, k) = pd(i, j, k) + tempd0
            wd(i, j, k, irho) = wd(i, j, k, irho) - p(i, j, k)*tempd0/&
&             temp1
            pd(i+1, j, k) = pd(i+1, j, k) + tempd
            wd(i+1, j, k, irho) = wd(i+1, j, k, irho) - p(i+1, j, k)*&
&             tempd/temp
            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
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              dis2d = 0.0_8
            else
              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
              dis2d = ddw*drkd
              ddwd = dis2*drkd
              wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, &
&               itu1)*ddwd
              wd(i+1, j, k, itu1) = wd(i+1, j, k, itu1) + w(i+1, j, k, &
&               irho)*ddwd
              wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, itu1)*&
&               ddwd
              wd(i, j, k, itu1) = wd(i, j, k, itu1) - w(i, j, k, irho)*&
&               ddwd
              ddw = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
            end if
            call popreal8(dre)
            dis2d = dis2d + ddw*dred
            ddwd = dis2*dred
            call popreal8(ddw)
            wd(i+1, j, k, irhoe) = wd(i+1, j, k, irhoe) + ddwd
            wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - ddwd
            call popreal8(drw)
            dis2d = dis2d + ddw*drwd
            ddwd = dis2*drwd
            call popreal8(ddw)
            wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, ivz&
&             )*ddwd
            wd(i+1, j, k, ivz) = wd(i+1, j, k, ivz) + w(i+1, j, k, irho)&
&             *ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivz)*ddwd
            wd(i, j, k, ivz) = wd(i, j, k, ivz) - w(i, j, k, irho)*ddwd
            call popreal8(drv)
            dis2d = dis2d + ddw*drvd
            ddwd = dis2*drvd
            call popreal8(ddw)
            wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, ivy&
&             )*ddwd
            wd(i+1, j, k, ivy) = wd(i+1, j, k, ivy) + w(i+1, j, k, irho)&
&             *ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivy)*ddwd
            wd(i, j, k, ivy) = wd(i, j, k, ivy) - w(i, j, k, irho)*ddwd
            call popreal8(dru)
            dis2d = dis2d + ddw*drud
            ddwd = dis2*drud
            wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + w(i+1, j, k, ivx&
&             )*ddwd
            wd(i+1, j, k, ivx) = wd(i+1, j, k, ivx) + w(i+1, j, k, irho)&
&             *ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - w(i, j, k, ivx)*ddwd
            wd(i, j, k, ivx) = wd(i, j, k, ivx) - w(i, j, k, irho)*ddwd
            ddw = w(i+1, j, k, irho) - w(i, j, k, irho)
            call popreal8(dr)
            dis2d = dis2d + ddw*drd
            ddwd = dis2*drd
            call popreal8(ddw)
            wd(i+1, j, k, irho) = wd(i+1, j, k, irho) + ddwd
            wd(i, j, k, irho) = wd(i, j, k, irho) - ddwd
            call popreal8(dis2)
            min1d = fis2*ppor*dis2d
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              y1d = min1d
            else
              y1d = 0.0_8
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              dp2d = dp2d + y1d
              dp1d = 0.0_8
            else
              dp1d = y1d
            end if
            call popreal8(ppor)
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              x2d = dp2d
            else
              x2d = -dp2d
            end if
            temp = omega*(shocksensor(i+2, j, k)+two*shocksensor(i+1, j&
&             , k)+shocksensor(i, j, k)) + oneminomega*(abs2+abs8) + &
&             plim
            plimd = plimd - (shocksensor(i+2, j, k)-two*shocksensor(i+1&
&             , j, k)+shocksensor(i, j, k))*x2d/temp**2
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(abs8)
            else
              call popreal8(abs8)
            end if
            call popcontrol1b(branch)
            if (branch .eq. 0) then
              call popreal8(abs2)
            else
              call popreal8(abs2)
            end if
          end do
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            x1d = dp1d
          else
            x1d = -dp1d
          end if
          temp = omega*(shocksensor(2, j, k)+two*shocksensor(1, j, k)+&
&           shocksensor(0, j, k)) + oneminomega*(abs1+abs7) + plim
          plimd = plimd - (shocksensor(2, j, k)-two*shocksensor(1, j, k)&
&           +shocksensor(0, j, k))*x1d/temp**2
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(abs7)
          else
            call popreal8(abs7)
          end if
          call popcontrol1b(branch)
          if (branch .eq. 0) then
            call popreal8(abs1)
          else
            call popreal8(abs1)
          end if
        end do
      end do
      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
      pinfcorrd = pinfcorrd + 0.001_realtype*plimd
    end if
  end subroutine invisciddissfluxmatrixapprox_b
 
  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_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_b