fluxes_d.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_d
  implicit none
 
contains
!  differentiation of inviscidcentralflux in forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: *dw
!   with respect to varying inputs: timeref *p *sfacei *sfacej
!                *sfacek *w *dw *vol *si *sj *sk
!   rw status of diff variables: timeref:in *p:in *sfacei:in *sfacej:in
!                *sfacek:in *w:in *dw:in-out *vol:in *si:in *sj:in
!                *sk:in
!   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_d()
!
!       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) :: temp0
    real(kind=realtype) :: temp1
    real(kind=realtype) :: temp2
    real(kind=realtype) :: temp3
    real(kind=realtype) :: temp4
! initialize sface to zero. this value will be used if the
! block is not moving.
    sface = zero
    sfaced = 0.0_8
!
!       advective fluxes in the i-direction.
!
    do k=2,kl
      do j=2,jl
        do i=1,il
! set the dot product of the grid velocity and the
! normal in i-direction for a moving face.
          if (addgridvelocities) then
            sfaced = sfaceid(i, j, k)
            sface = sfacei(i, j, k)
          end if
! compute the normal velocities of the left and right state.
          temp = si(i, j, k, 1)
          temp0 = w(i+1, j, k, ivx)
          temp1 = si(i, j, k, 2)
          temp2 = w(i+1, j, k, ivy)
          temp3 = si(i, j, k, 3)
          temp4 = w(i+1, j, k, ivz)
          vnpd = temp*wd(i+1, j, k, ivx) + temp0*sid(i, j, k, 1) + temp1&
&           *wd(i+1, j, k, ivy) + temp2*sid(i, j, k, 2) + temp3*wd(i+1, &
&           j, k, ivz) + temp4*sid(i, j, k, 3)
          vnp = temp0*temp + temp2*temp1 + temp4*temp3
          temp4 = si(i, j, k, 1)
          temp3 = w(i, j, k, ivx)
          temp2 = si(i, j, k, 2)
          temp1 = w(i, j, k, ivy)
          temp0 = si(i, j, k, 3)
          temp = w(i, j, k, ivz)
          vnmd = temp4*wd(i, j, k, ivx) + temp3*sid(i, j, k, 1) + temp2*&
&           wd(i, j, k, ivy) + temp1*sid(i, j, k, 2) + temp0*wd(i, j, k&
&           , ivz) + temp*sid(i, j, k, 3)
          vnm = temp3*temp4 + temp1*temp2 + temp*temp0
! 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
            vnpd = sfaced
            vnp = sface
            vnmd = sfaced
            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.
          qspd = porvel*(vnpd-sfaced)
          qsp = (vnp-sface)*porvel
          qsmd = porvel*(vnmd-sfaced)
          qsm = (vnm-sface)*porvel
          temp4 = w(i+1, j, k, irho)
          rqspd = temp4*qspd + qsp*wd(i+1, j, k, irho)
          rqsp = qsp*temp4
          temp4 = w(i, j, k, irho)
          rqsmd = temp4*qsmd + qsm*wd(i, j, k, irho)
          rqsm = qsm*temp4
! compute the sum of the pressure multiplied by porflux.
! for the default value of porflux, 0.5, this leads to
! the average pressure.
          pad = porflux*(pd(i+1, j, k)+pd(i, j, k))
          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 = rqspd + rqsmd
          fs = rqsp + rqsm
          dwd(i+1, j, k, irho) = dwd(i+1, j, k, irho) - fsd
          dw(i+1, j, k, irho) = dw(i+1, j, k, irho) - fs
          dwd(i, j, k, irho) = dwd(i, j, k, irho) + fsd
          dw(i, j, k, irho) = dw(i, j, k, irho) + fs
          temp4 = w(i+1, j, k, ivx)
          temp3 = w(i, j, k, ivx)
          temp2 = si(i, j, k, 1)
          fsd = temp4*rqspd + rqsp*wd(i+1, j, k, ivx) + temp3*rqsmd + &
&           rqsm*wd(i, j, k, ivx) + temp2*pad + pa*sid(i, j, k, 1)
          fs = rqsp*temp4 + rqsm*temp3 + pa*temp2
          dwd(i+1, j, k, imx) = dwd(i+1, j, k, imx) - fsd
          dw(i+1, j, k, imx) = dw(i+1, j, k, imx) - fs
          dwd(i, j, k, imx) = dwd(i, j, k, imx) + fsd
          dw(i, j, k, imx) = dw(i, j, k, imx) + fs
          temp4 = w(i+1, j, k, ivy)
          temp3 = w(i, j, k, ivy)
          temp2 = si(i, j, k, 2)
          fsd = temp4*rqspd + rqsp*wd(i+1, j, k, ivy) + temp3*rqsmd + &
&           rqsm*wd(i, j, k, ivy) + temp2*pad + pa*sid(i, j, k, 2)
          fs = rqsp*temp4 + rqsm*temp3 + pa*temp2
          dwd(i+1, j, k, imy) = dwd(i+1, j, k, imy) - fsd
          dw(i+1, j, k, imy) = dw(i+1, j, k, imy) - fs
          dwd(i, j, k, imy) = dwd(i, j, k, imy) + fsd
          dw(i, j, k, imy) = dw(i, j, k, imy) + fs
          temp4 = w(i+1, j, k, ivz)
          temp3 = w(i, j, k, ivz)
          temp2 = si(i, j, k, 3)
          fsd = temp4*rqspd + rqsp*wd(i+1, j, k, ivz) + temp3*rqsmd + &
&           rqsm*wd(i, j, k, ivz) + temp2*pad + pa*sid(i, j, k, 3)
          fs = rqsp*temp4 + rqsm*temp3 + pa*temp2
          dwd(i+1, j, k, imz) = dwd(i+1, j, k, imz) - fsd
          dw(i+1, j, k, imz) = dw(i+1, j, k, imz) - fs
          dwd(i, j, k, imz) = dwd(i, j, k, imz) + fsd
          dw(i, j, k, imz) = dw(i, j, k, imz) + fs
          temp4 = w(i+1, j, k, irhoe)
          temp3 = w(i, j, k, irhoe)
          temp2 = p(i+1, j, k)
          fsd = temp4*qspd + qsp*wd(i+1, j, k, irhoe) + temp3*qsmd + qsm&
&           *wd(i, j, k, irhoe) + porflux*(temp2*vnpd+vnp*pd(i+1, j, k)+&
&           p(i, j, k)*vnmd+vnm*pd(i, j, k))
          fs = qsp*temp4 + qsm*temp3 + porflux*(vnp*temp2+vnm*p(i, j, k)&
&           )
          dwd(i+1, j, k, irhoe) = dwd(i+1, j, k, irhoe) - fsd
          dw(i+1, j, k, irhoe) = dw(i+1, j, k, irhoe) - fs
          dwd(i, j, k, irhoe) = dwd(i, j, k, irhoe) + fsd
          dw(i, j, k, irhoe) = dw(i, j, k, irhoe) + fs
        end do
      end do
    end do
!
!       advective fluxes in the j-direction.
!
    sface = zero
    sfaced = 0.0_8
    do k=2,kl
      do j=1,jl
        do i=2,il
! set the dot product of the grid velocity and the
! normal in j-direction for a moving face.
          if (addgridvelocities) then
            sfaced = sfacejd(i, j, k)
            sface = sfacej(i, j, k)
          end if
! compute the normal velocities of the left and right state.
          temp4 = sj(i, j, k, 1)
          temp3 = w(i, j+1, k, ivx)
          temp2 = sj(i, j, k, 2)
          temp1 = w(i, j+1, k, ivy)
          temp0 = sj(i, j, k, 3)
          temp = w(i, j+1, k, ivz)
          vnpd = temp4*wd(i, j+1, k, ivx) + temp3*sjd(i, j, k, 1) + &
&           temp2*wd(i, j+1, k, ivy) + temp1*sjd(i, j, k, 2) + temp0*wd(&
&           i, j+1, k, ivz) + temp*sjd(i, j, k, 3)
          vnp = temp3*temp4 + temp1*temp2 + temp*temp0
          temp4 = sj(i, j, k, 1)
          temp3 = w(i, j, k, ivx)
          temp2 = sj(i, j, k, 2)
          temp1 = w(i, j, k, ivy)
          temp0 = sj(i, j, k, 3)
          temp = w(i, j, k, ivz)
          vnmd = temp4*wd(i, j, k, ivx) + temp3*sjd(i, j, k, 1) + temp2*&
&           wd(i, j, k, ivy) + temp1*sjd(i, j, k, 2) + temp0*wd(i, j, k&
&           , ivz) + temp*sjd(i, j, k, 3)
          vnm = temp3*temp4 + temp1*temp2 + temp*temp0
! 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
            vnpd = sfaced
            vnp = sface
            vnmd = sfaced
            vnm = sface
          end if
! incorporate porflux in porvel.
          porvel = porvel*porflux
! compute the normal velocities for the face as well as the
! mass fluxes.
          qspd = porvel*(vnpd-sfaced)
          qsp = (vnp-sface)*porvel
          qsmd = porvel*(vnmd-sfaced)
          qsm = (vnm-sface)*porvel
          temp4 = w(i, j+1, k, irho)
          rqspd = temp4*qspd + qsp*wd(i, j+1, k, irho)
          rqsp = qsp*temp4
          temp4 = w(i, j, k, irho)
          rqsmd = temp4*qsmd + qsm*wd(i, j, k, irho)
          rqsm = qsm*temp4
! compute the sum of the pressure multiplied by porflux.
! for the default value of porflux, 0.5, this leads to
! the average pressure.
          pad = porflux*(pd(i, j+1, k)+pd(i, j, k))
          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 = rqspd + rqsmd
          fs = rqsp + rqsm
          dwd(i, j+1, k, irho) = dwd(i, j+1, k, irho) - fsd
          dw(i, j+1, k, irho) = dw(i, j+1, k, irho) - fs
          dwd(i, j, k, irho) = dwd(i, j, k, irho) + fsd
          dw(i, j, k, irho) = dw(i, j, k, irho) + fs
          temp4 = w(i, j+1, k, ivx)
          temp3 = w(i, j, k, ivx)
          temp2 = sj(i, j, k, 1)
          fsd = temp4*rqspd + rqsp*wd(i, j+1, k, ivx) + temp3*rqsmd + &
&           rqsm*wd(i, j, k, ivx) + temp2*pad + pa*sjd(i, j, k, 1)
          fs = rqsp*temp4 + rqsm*temp3 + pa*temp2
          dwd(i, j+1, k, imx) = dwd(i, j+1, k, imx) - fsd
          dw(i, j+1, k, imx) = dw(i, j+1, k, imx) - fs
          dwd(i, j, k, imx) = dwd(i, j, k, imx) + fsd
          dw(i, j, k, imx) = dw(i, j, k, imx) + fs
          temp4 = w(i, j+1, k, ivy)
          temp3 = w(i, j, k, ivy)
          temp2 = sj(i, j, k, 2)
          fsd = temp4*rqspd + rqsp*wd(i, j+1, k, ivy) + temp3*rqsmd + &
&           rqsm*wd(i, j, k, ivy) + temp2*pad + pa*sjd(i, j, k, 2)
          fs = rqsp*temp4 + rqsm*temp3 + pa*temp2
          dwd(i, j+1, k, imy) = dwd(i, j+1, k, imy) - fsd
          dw(i, j+1, k, imy) = dw(i, j+1, k, imy) - fs
          dwd(i, j, k, imy) = dwd(i, j, k, imy) + fsd
          dw(i, j, k, imy) = dw(i, j, k, imy) + fs
          temp4 = w(i, j+1, k, ivz)
          temp3 = w(i, j, k, ivz)
          temp2 = sj(i, j, k, 3)
          fsd = temp4*rqspd + rqsp*wd(i, j+1, k, ivz) + temp3*rqsmd + &
&           rqsm*wd(i, j, k, ivz) + temp2*pad + pa*sjd(i, j, k, 3)
          fs = rqsp*temp4 + rqsm*temp3 + pa*temp2
          dwd(i, j+1, k, imz) = dwd(i, j+1, k, imz) - fsd
          dw(i, j+1, k, imz) = dw(i, j+1, k, imz) - fs
          dwd(i, j, k, imz) = dwd(i, j, k, imz) + fsd
          dw(i, j, k, imz) = dw(i, j, k, imz) + fs
          temp4 = w(i, j+1, k, irhoe)
          temp3 = w(i, j, k, irhoe)
          temp2 = p(i, j+1, k)
          fsd = temp4*qspd + qsp*wd(i, j+1, k, irhoe) + temp3*qsmd + qsm&
&           *wd(i, j, k, irhoe) + porflux*(temp2*vnpd+vnp*pd(i, j+1, k)+&
&           p(i, j, k)*vnmd+vnm*pd(i, j, k))
          fs = qsp*temp4 + qsm*temp3 + porflux*(vnp*temp2+vnm*p(i, j, k)&
&           )
          dwd(i, j+1, k, irhoe) = dwd(i, j+1, k, irhoe) - fsd
          dw(i, j+1, k, irhoe) = dw(i, j+1, k, irhoe) - fs
          dwd(i, j, k, irhoe) = dwd(i, j, k, irhoe) + fsd
          dw(i, j, k, irhoe) = dw(i, j, k, irhoe) + fs
        end do
      end do
    end do
!
!       advective fluxes in the k-direction.
    sface = zero
    sfaced = 0.0_8
    do k=1,kl
      do j=2,jl
        do i=2,il
! set the dot product of the grid velocity and the
! normal in k-direction for a moving face.
          if (addgridvelocities) then
            sfaced = sfacekd(i, j, k)
            sface = sfacek(i, j, k)
          end if
! compute the normal velocities of the left and right state.
          temp4 = sk(i, j, k, 1)
          temp3 = w(i, j, k+1, ivx)
          temp2 = sk(i, j, k, 2)
          temp1 = w(i, j, k+1, ivy)
          temp0 = sk(i, j, k, 3)
          temp = w(i, j, k+1, ivz)
          vnpd = temp4*wd(i, j, k+1, ivx) + temp3*skd(i, j, k, 1) + &
&           temp2*wd(i, j, k+1, ivy) + temp1*skd(i, j, k, 2) + temp0*wd(&
&           i, j, k+1, ivz) + temp*skd(i, j, k, 3)
          vnp = temp3*temp4 + temp1*temp2 + temp*temp0
          temp4 = sk(i, j, k, 1)
          temp3 = w(i, j, k, ivx)
          temp2 = sk(i, j, k, 2)
          temp1 = w(i, j, k, ivy)
          temp0 = sk(i, j, k, 3)
          temp = w(i, j, k, ivz)
          vnmd = temp4*wd(i, j, k, ivx) + temp3*skd(i, j, k, 1) + temp2*&
&           wd(i, j, k, ivy) + temp1*skd(i, j, k, 2) + temp0*wd(i, j, k&
&           , ivz) + temp*skd(i, j, k, 3)
          vnm = temp3*temp4 + temp1*temp2 + temp*temp0
! 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
            vnpd = sfaced
            vnp = sface
            vnmd = sfaced
            vnm = sface
          end if
! incorporate porflux in porvel.
          porvel = porvel*porflux
! compute the normal velocities for the face as well as the
! mass fluxes.
          qspd = porvel*(vnpd-sfaced)
          qsp = (vnp-sface)*porvel
          qsmd = porvel*(vnmd-sfaced)
          qsm = (vnm-sface)*porvel
          temp4 = w(i, j, k+1, irho)
          rqspd = temp4*qspd + qsp*wd(i, j, k+1, irho)
          rqsp = qsp*temp4
          temp4 = w(i, j, k, irho)
          rqsmd = temp4*qsmd + qsm*wd(i, j, k, irho)
          rqsm = qsm*temp4
! compute the sum of the pressure multiplied by porflux.
! for the default value of porflux, 0.5, this leads to
! the average pressure.
          pad = porflux*(pd(i, j, k+1)+pd(i, j, k))
          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 = rqspd + rqsmd
          fs = rqsp + rqsm
          dwd(i, j, k+1, irho) = dwd(i, j, k+1, irho) - fsd
          dw(i, j, k+1, irho) = dw(i, j, k+1, irho) - fs
          dwd(i, j, k, irho) = dwd(i, j, k, irho) + fsd
          dw(i, j, k, irho) = dw(i, j, k, irho) + fs
          temp4 = w(i, j, k+1, ivx)
          temp3 = w(i, j, k, ivx)
          temp2 = sk(i, j, k, 1)
          fsd = temp4*rqspd + rqsp*wd(i, j, k+1, ivx) + temp3*rqsmd + &
&           rqsm*wd(i, j, k, ivx) + temp2*pad + pa*skd(i, j, k, 1)
          fs = rqsp*temp4 + rqsm*temp3 + pa*temp2
          dwd(i, j, k+1, imx) = dwd(i, j, k+1, imx) - fsd
          dw(i, j, k+1, imx) = dw(i, j, k+1, imx) - fs
          dwd(i, j, k, imx) = dwd(i, j, k, imx) + fsd
          dw(i, j, k, imx) = dw(i, j, k, imx) + fs
          temp4 = w(i, j, k+1, ivy)
          temp3 = w(i, j, k, ivy)
          temp2 = sk(i, j, k, 2)
          fsd = temp4*rqspd + rqsp*wd(i, j, k+1, ivy) + temp3*rqsmd + &
&           rqsm*wd(i, j, k, ivy) + temp2*pad + pa*skd(i, j, k, 2)
          fs = rqsp*temp4 + rqsm*temp3 + pa*temp2
          dwd(i, j, k+1, imy) = dwd(i, j, k+1, imy) - fsd
          dw(i, j, k+1, imy) = dw(i, j, k+1, imy) - fs
          dwd(i, j, k, imy) = dwd(i, j, k, imy) + fsd
          dw(i, j, k, imy) = dw(i, j, k, imy) + fs
          temp4 = w(i, j, k+1, ivz)
          temp3 = w(i, j, k, ivz)
          temp2 = sk(i, j, k, 3)
          fsd = temp4*rqspd + rqsp*wd(i, j, k+1, ivz) + temp3*rqsmd + &
&           rqsm*wd(i, j, k, ivz) + temp2*pad + pa*skd(i, j, k, 3)
          fs = rqsp*temp4 + rqsm*temp3 + pa*temp2
          dwd(i, j, k+1, imz) = dwd(i, j, k+1, imz) - fsd
          dw(i, j, k+1, imz) = dw(i, j, k+1, imz) - fs
          dwd(i, j, k, imz) = dwd(i, j, k, imz) + fsd
          dw(i, j, k, imz) = dw(i, j, k, imz) + fs
          temp4 = w(i, j, k+1, irhoe)
          temp3 = w(i, j, k, irhoe)
          temp2 = p(i, j, k+1)
          fsd = temp4*qspd + qsp*wd(i, j, k+1, irhoe) + temp3*qsmd + qsm&
&           *wd(i, j, k, irhoe) + porflux*(temp2*vnpd+vnp*pd(i, j, k+1)+&
&           p(i, j, k)*vnmd+vnm*pd(i, j, k))
          fs = qsp*temp4 + qsm*temp3 + porflux*(vnp*temp2+vnm*p(i, j, k)&
&           )
          dwd(i, j, k+1, irhoe) = dwd(i, j, k+1, irhoe) - fsd
          dw(i, j, k+1, irhoe) = dw(i, j, k+1, irhoe) - fs
          dwd(i, j, k, irhoe) = dwd(i, j, k, irhoe) + fsd
          dw(i, j, k, irhoe) = dw(i, j, k, irhoe) + fs
        end do
      end do
    end do
! 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.
    if (blockismoving .and. equationmode .eq. steady) then
! compute the three nondimensional angular velocities.
      wwxd = cgnsdoms(nbkglobal)%rotrate(1)*timerefd
      wwx = timeref*cgnsdoms(nbkglobal)%rotrate(1)
      wwyd = cgnsdoms(nbkglobal)%rotrate(2)*timerefd
      wwy = timeref*cgnsdoms(nbkglobal)%rotrate(2)
      wwzd = cgnsdoms(nbkglobal)%rotrate(3)*timerefd
      wwz = timeref*cgnsdoms(nbkglobal)%rotrate(3)
! 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
        temp4 = w(i, j, k, irho)
        rvold = vol(i, j, k)*wd(i, j, k, irho) + temp4*vold(i, j, k)
        rvol = temp4*vol(i, j, k)
        temp4 = w(i, j, k, ivy)
        temp3 = w(i, j, k, ivz)
        temp2 = wwy*temp3 - wwz*temp4
        dwd(i, j, k, imx) = dwd(i, j, k, imx) + temp2*rvold + rvol*(&
&         temp3*wwyd+wwy*wd(i, j, k, ivz)-temp4*wwzd-wwz*wd(i, j, k, ivy&
&         ))
        dw(i, j, k, imx) = dw(i, j, k, imx) + rvol*temp2
        temp4 = w(i, j, k, ivz)
        temp3 = w(i, j, k, ivx)
        temp2 = wwz*temp3 - wwx*temp4
        dwd(i, j, k, imy) = dwd(i, j, k, imy) + temp2*rvold + rvol*(&
&         temp3*wwzd+wwz*wd(i, j, k, ivx)-temp4*wwxd-wwx*wd(i, j, k, ivz&
&         ))
        dw(i, j, k, imy) = dw(i, j, k, imy) + rvol*temp2
        temp4 = w(i, j, k, ivx)
        temp3 = w(i, j, k, ivy)
        temp2 = wwx*temp3 - wwy*temp4
        dwd(i, j, k, imz) = dwd(i, j, k, imz) + temp2*rvold + rvol*(&
&         temp3*wwxd+wwx*wd(i, j, k, ivy)-temp4*wwyd-wwy*wd(i, j, k, ivx&
&         ))
        dw(i, j, k, imz) = dw(i, j, k, imz) + rvol*temp2
      end do
    end if
  end subroutine inviscidcentralflux_d
 
  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
!
!       advective fluxes in the i-direction.
!
    do k=2,kl
      do j=2,jl
        do i=1,il
! 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
      end do
    end do
!$ad checkpoint-end
!
!       advective fluxes in the j-direction.
!
    continue
!$ad checkpoint-start
    sface = zero
    do k=2,kl
      do j=1,jl
        do i=2,il
! 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
      end do
    end do
!$ad checkpoint-end
!
!       advective fluxes in the k-direction.
    continue
!$ad checkpoint-start
    sface = zero
    do k=1,kl
      do j=2,jl
        do i=2,il
! 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
      end do
    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 forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: *fw
!   with respect to varying inputs: pinfcorr *p *sfacei *sfacej
!                *sfacek *w *si *sj *sk *fw
!   rw status of diff variables: pinfcorr:in *p:in *sfacei:in *sfacej:in
!                *sfacek:in *w:in *si:in *sj:in *sk:in *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_d()
!
!       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_d, only : getcorrectfork, mydim, mydim_d
    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 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) :: temp1
    real(kind=realtype) :: temp2
    real(kind=realtype) :: temp3
    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.
      plimd = 0.001_realtype*pinfcorrd
      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 = sfil*fwd
      fw = sfil*fw
      dssd = 0.0_8
! compute the pressure sensor for each cell, in each direction:
      do k=1,ke
        do j=1,je
          do i=1,ie
            if (p(i+1, j, k) - p(i, j, k) .ge. 0.) then
              abs1d = pd(i+1, j, k) - pd(i, j, k)
              abs1 = p(i+1, j, k) - p(i, j, k)
            else
              abs1d = pd(i, j, k) - pd(i+1, j, k)
              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
              abs4d = pd(i, j, k) - pd(i-1, j, k)
              abs4 = p(i, j, k) - p(i-1, j, k)
            else
              abs4d = pd(i-1, j, k) - pd(i, j, k)
              abs4 = -(p(i, j, k)-p(i-1, j, k))
            end if
            temp = omega*(p(i+1, j, k)+two*p(i, j, k)+p(i-1, j, k)) + &
&             oneminomega*(abs1+abs4) + plim
            temp0 = (p(i+1, j, k)-two*p(i, j, k)+p(i-1, j, k))/temp
            x1d = (pd(i+1, j, k)-two*pd(i, j, k)+pd(i-1, j, k)-temp0*(&
&             omega*(pd(i+1, j, k)+two*pd(i, j, k)+pd(i-1, j, k))+&
&             oneminomega*(abs1d+abs4d)+plimd))/temp
            x1 = temp0
            if (x1 .ge. 0.) then
              dssd(i, j, k, 1) = x1d
              dss(i, j, k, 1) = x1
            else
              dssd(i, j, k, 1) = -x1d
              dss(i, j, k, 1) = -x1
            end if
            if (p(i, j+1, k) - p(i, j, k) .ge. 0.) then
              abs2d = pd(i, j+1, k) - pd(i, j, k)
              abs2 = p(i, j+1, k) - p(i, j, k)
            else
              abs2d = pd(i, j, k) - pd(i, j+1, k)
              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
              abs5d = pd(i, j, k) - pd(i, j-1, k)
              abs5 = p(i, j, k) - p(i, j-1, k)
            else
              abs5d = pd(i, j-1, k) - pd(i, j, k)
              abs5 = -(p(i, j, k)-p(i, j-1, k))
            end if
            temp0 = omega*(p(i, j+1, k)+two*p(i, j, k)+p(i, j-1, k)) + &
&             oneminomega*(abs2+abs5) + plim
            temp = (p(i, j+1, k)-two*p(i, j, k)+p(i, j-1, k))/temp0
            x2d = (pd(i, j+1, k)-two*pd(i, j, k)+pd(i, j-1, k)-temp*(&
&             omega*(pd(i, j+1, k)+two*pd(i, j, k)+pd(i, j-1, k))+&
&             oneminomega*(abs2d+abs5d)+plimd))/temp0
            x2 = temp
            if (x2 .ge. 0.) then
              dssd(i, j, k, 2) = x2d
              dss(i, j, k, 2) = x2
            else
              dssd(i, j, k, 2) = -x2d
              dss(i, j, k, 2) = -x2
            end if
            if (p(i, j, k+1) - p(i, j, k) .ge. 0.) then
              abs3d = pd(i, j, k+1) - pd(i, j, k)
              abs3 = p(i, j, k+1) - p(i, j, k)
            else
              abs3d = pd(i, j, k) - pd(i, j, k+1)
              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
              abs6d = pd(i, j, k) - pd(i, j, k-1)
              abs6 = p(i, j, k) - p(i, j, k-1)
            else
              abs6d = pd(i, j, k-1) - pd(i, j, k)
              abs6 = -(p(i, j, k)-p(i, j, k-1))
            end if
            temp0 = omega*(p(i, j, k+1)+two*p(i, j, k)+p(i, j, k-1)) + &
&             oneminomega*(abs3+abs6) + plim
            temp = (p(i, j, k+1)-two*p(i, j, k)+p(i, j, k-1))/temp0
            x3d = (pd(i, j, k+1)-two*pd(i, j, k)+pd(i, j, k-1)-temp*(&
&             omega*(pd(i, j, k+1)+two*pd(i, j, k)+pd(i, j, k-1))+&
&             oneminomega*(abs3d+abs6d)+plimd))/temp0
            x3 = temp
            if (x3 .ge. 0.) then
              dssd(i, j, k, 3) = x3d
              dss(i, j, k, 3) = x3
            else
              dssd(i, j, k, 3) = -x3d
              dss(i, j, k, 3) = -x3
            end if
          end do
        end do
      end do
      sfaced = 0.0_8
!
!       dissipative fluxes in the i-direction.
!
      do k=2,kl
        do j=2,jl
          do i=1,il
! 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
              y1d = dssd(i+1, j, k, 1)
              y1 = dss(i+1, j, k, 1)
            else
              y1d = dssd(i, j, k, 1)
              y1 = dss(i, j, k, 1)
            end if
            if (dpmax .gt. y1) then
              min1d = y1d
              min1 = y1
            else
              min1 = dpmax
              min1d = 0.0_8
            end if
            dis2d = ppor*fis2*min1d
            dis2 = ppor*fis2*min1
            dis4d = mydim_d(ppor*fis4, 0.0_8, dis2, dis2d, dis4)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            ddw1d = wd(i+1, j, k, irho) - wd(i, j, k, irho)
            ddw1 = w(i+1, j, k, irho) - w(i, j, k, irho)
            temp0 = w(i+2, j, k, irho) - w(i-1, j, k, irho) - three*ddw1
            drd = ddw1*dis2d + dis2*ddw1d - temp0*dis4d - dis4*(wd(i+2, &
&             j, k, irho)-wd(i-1, j, k, irho)-three*ddw1d)
            dr = dis2*ddw1 - dis4*temp0
            temp0 = w(i+1, j, k, ivx)
            temp = w(i+1, j, k, irho)
            temp1 = w(i, j, k, ivx)
            temp2 = w(i, j, k, irho)
            ddw2d = temp0*wd(i+1, j, k, irho) + temp*wd(i+1, j, k, ivx) &
&             - temp1*wd(i, j, k, irho) - temp2*wd(i, j, k, ivx)
            ddw2 = temp*temp0 - temp2*temp1
            temp2 = w(i-1, j, k, ivx)
            temp1 = w(i-1, j, k, irho)
            temp0 = w(i+2, j, k, ivx)
            temp = w(i+2, j, k, irho)
            temp3 = temp*temp0 - temp1*temp2 - three*ddw2
            drud = ddw2*dis2d + dis2*ddw2d - temp3*dis4d - dis4*(temp0*&
&             wd(i+2, j, k, irho)+temp*wd(i+2, j, k, ivx)-temp2*wd(i-1, &
&             j, k, irho)-temp1*wd(i-1, j, k, ivx)-three*ddw2d)
            dru = dis2*ddw2 - dis4*temp3
            temp3 = w(i+1, j, k, ivy)
            temp2 = w(i+1, j, k, irho)
            temp1 = w(i, j, k, ivy)
            temp0 = w(i, j, k, irho)
            ddw3d = temp3*wd(i+1, j, k, irho) + temp2*wd(i+1, j, k, ivy)&
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivy)
            ddw3 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw3
            drvd = ddw3*dis2d + dis2*ddw3d - temp*dis4d - dis4*(temp1*wd&
&             (i+2, j, k, irho)+temp0*wd(i+2, j, k, ivy)-temp3*wd(i-1, j&
&             , k, irho)-temp2*wd(i-1, j, k, ivy)-three*ddw3d)
            drv = dis2*ddw3 - dis4*temp
            temp3 = w(i+1, j, k, ivz)
            temp2 = w(i+1, j, k, irho)
            temp1 = w(i, j, k, ivz)
            temp0 = w(i, j, k, irho)
            ddw4d = temp3*wd(i+1, j, k, irho) + temp2*wd(i+1, j, k, ivz)&
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivz)
            ddw4 = temp2*temp3 - temp0*temp1
            temp3 = w(i-1, j, k, ivz)
            temp2 = w(i-1, j, k, irho)
            temp1 = w(i+2, j, k, ivz)
            temp0 = w(i+2, j, k, irho)
            temp = temp0*temp1 - temp2*temp3 - three*ddw4
            drwd = ddw4*dis2d + dis2*ddw4d - temp*dis4d - dis4*(temp1*wd&
&             (i+2, j, k, irho)+temp0*wd(i+2, j, k, ivz)-temp3*wd(i-1, j&
&             , k, irho)-temp2*wd(i-1, j, k, ivz)-three*ddw4d)
            drw = dis2*ddw4 - dis4*temp
            ddw5d = wd(i+1, j, k, irhoe) - wd(i, j, k, irhoe)
            ddw5 = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
            temp3 = w(i+2, j, k, irhoe) - w(i-1, j, k, irhoe) - three*&
&             ddw5
            dred = ddw5*dis2d + dis2*ddw5d - temp3*dis4d - dis4*(wd(i+2&
&             , j, k, irhoe)-wd(i-1, j, k, irhoe)-three*ddw5d)
            dre = dis2*ddw5 - dis4*temp3
! 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
              temp3 = w(i+1, j, k, itu1)
              temp2 = w(i+1, j, k, irho)
              temp1 = w(i, j, k, itu1)
              temp0 = w(i, j, k, irho)
              ddw6d = temp3*wd(i+1, j, k, irho) + temp2*wd(i+1, j, k, &
&               itu1) - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, itu1&
&               )
              ddw6 = temp2*temp3 - temp0*temp1
              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)
              temp = temp0*temp1 - temp2*temp3 - three*ddw6
              drkd = ddw6*dis2d + dis2*ddw6d - temp*dis4d - dis4*(temp1*&
&               wd(i+2, j, k, irho)+temp0*wd(i+2, j, k, itu1)-temp3*wd(i&
&               -1, j, k, irho)-temp2*wd(i-1, j, k, itu1)-three*ddw6d)
              drk = dis2*ddw6 - dis4*temp
              kavgd = half*(wd(i, j, k, itu1)+wd(i+1, j, k, itu1))
              kavg = half*(w(i, j, k, itu1)+w(i+1, j, k, itu1))
            else
              drk = zero
              kavg = zero
              kavgd = 0.0_8
              drkd = 0.0_8
            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.
            uavgd = half*(wd(i+1, j, k, ivx)+wd(i, j, k, ivx))
            uavg = half*(w(i+1, j, k, ivx)+w(i, j, k, ivx))
            vavgd = half*(wd(i+1, j, k, ivy)+wd(i, j, k, ivy))
            vavg = half*(w(i+1, j, k, ivy)+w(i, j, k, ivy))
            wavgd = half*(wd(i+1, j, k, ivz)+wd(i, j, k, ivz))
            wavg = half*(w(i+1, j, k, ivz)+w(i, j, k, ivz))
            temp3 = gamma(i+1, j, k)
            temp2 = w(i+1, j, k, irho)
            temp1 = p(i+1, j, k)/temp2
            temp0 = w(i, j, k, irho)
            temp = p(i, j, k)/temp0
            a2avgd = half*(temp3*(pd(i+1, j, k)-temp1*wd(i+1, j, k, irho&
&             ))/temp2+gamma(i, j, k)*(pd(i, j, k)-temp*wd(i, j, k, irho&
&             ))/temp0)
            a2avg = half*(temp3*temp1+gamma(i, j, k)*temp)
            temp3 = si(i, j, k, 1)
            temp2 = si(i, j, k, 2)
            temp1 = si(i, j, k, 3)
            arg1d = 2*temp3*sid(i, j, k, 1) + 2*temp2*sid(i, j, k, 2) + &
&             2*temp1*sid(i, j, k, 3)
            arg1 = temp3*temp3 + temp2*temp2 + temp1*temp1
            temp3 = sqrt(arg1)
            if (arg1 .eq. 0.0_8) then
              aread = 0.0_8
            else
              aread = arg1d/(2.0*temp3)
            end if
            area = temp3
            if (1.e-25_realtype .lt. area) then
              max1d = aread
              max1 = area
            else
              max1 = 1.e-25_realtype
              max1d = 0.0_8
            end if
            tmpd = -(one*max1d/max1**2)
            tmp = one/max1
            temp3 = si(i, j, k, 1)
            sxd = tmp*sid(i, j, k, 1) + temp3*tmpd
            sx = temp3*tmp
            temp3 = si(i, j, k, 2)
            syd = tmp*sid(i, j, k, 2) + temp3*tmpd
            sy = temp3*tmp
            temp3 = si(i, j, k, 3)
            szd = tmp*sid(i, j, k, 3) + temp3*tmpd
            sz = temp3*tmp
            alphaavgd = half*(2*uavg*uavgd+2*vavg*vavgd+2*wavg*wavgd)
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            havgd = alphaavgd + ovgm1*(a2avgd-gm53*kavgd)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            temp3 = sqrt(a2avg)
            if (a2avg .eq. 0.0_8) then
              aavgd = 0.0_8
            else
              aavgd = a2avgd/(2.0*temp3)
            end if
            aavg = temp3
            unavgd = sx*uavgd + uavg*sxd + sy*vavgd + vavg*syd + sz*&
&             wavgd + wavg*szd
            unavg = uavg*sx + vavg*sy + wavg*sz
            ovaavgd = -(one*aavgd/aavg**2)
            ovaavg = one/aavg
            ova2avgd = -(one*a2avgd/a2avg**2)
            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
              sfaced = tmp*sfaceid(i, j, k) + sfacei(i, j, k)*tmpd
              sface = sfacei(i, j, k)*tmp
            end if
            if (unavg - sface + aavg .ge. 0.) then
              lam1d = unavgd - sfaced + aavgd
              lam1 = unavg - sface + aavg
            else
              lam1d = sfaced - unavgd - aavgd
              lam1 = -(unavg-sface+aavg)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2d = unavgd - sfaced - aavgd
              lam2 = unavg - sface - aavg
            else
              lam2d = sfaced - unavgd + aavgd
              lam2 = -(unavg-sface-aavg)
            end if
            if (unavg - sface .ge. 0.) then
              lam3d = unavgd - sfaced
              lam3 = unavg - sface
            else
              lam3d = sfaced - unavgd
              lam3 = -(unavg-sface)
            end if
            rradd = lam3d + aavgd
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              max2d = epsacoustic*rradd
              max2 = epsacoustic*rrad
            else
              max2d = lam1d
              max2 = lam1
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            lam1d = area*max2d + max2*aread
            lam1 = max2*area
            if (lam2 .lt. epsacoustic*rrad) then
              max3d = epsacoustic*rradd
              max3 = epsacoustic*rrad
            else
              max3d = lam2d
              max3 = lam2
            end if
            lam2d = area*max3d + max3*aread
            lam2 = max3*area
            if (lam3 .lt. epsshear*rrad) then
              max4d = epsshear*rradd
              max4 = epsshear*rrad
            else
              max4d = lam3d
              max4 = lam3
            end if
            lam3d = area*max4d + max4*aread
            lam3 = max4*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1d = half*(lam1d+lam2d)
            abv1 = half*(lam1+lam2)
            abv2d = half*(lam1d-lam2d)
            abv2 = half*(lam1-lam2)
            abv3d = abv1d - lam3d
            abv3 = abv1 - lam3
            abv4d = gm1*(dr*alphaavgd+alphaavg*drd-dru*uavgd-uavg*drud-&
&             drv*vavgd-vavg*drvd+dred-drw*wavgd-wavg*drwd) - gm53*drkd
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
            abv5d = dru*sxd + sx*drud + drv*syd + sy*drvd + drw*szd + sz&
&             *drwd - dr*unavgd - unavg*drd
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            abv6d = ova2avg*(abv4*abv3d+abv3*abv4d) + abv3*abv4*ova2avgd&
&             + ovaavg*(abv5*abv2d+abv2*abv5d) + abv2*abv5*ovaavgd
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7d = ovaavg*(abv4*abv2d+abv2*abv4d) + abv2*abv4*ovaavgd +&
&             abv5*abv3d + abv3*abv5d
            abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
            fsd = dr*lam3d + lam3*drd + abv6d
            fs = lam3*dr + abv6
            fwd(i+1, j, k, irho) = fwd(i+1, j, k, irho) + fsd
            fw(i+1, j, k, irho) = fw(i+1, j, k, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            fsd = dru*lam3d + lam3*drud + abv6*uavgd + uavg*abv6d + abv7&
&             *sxd + sx*abv7d
            fs = lam3*dru + uavg*abv6 + sx*abv7
            fwd(i+1, j, k, imx) = fwd(i+1, j, k, imx) + fsd
            fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            fsd = drv*lam3d + lam3*drvd + abv6*vavgd + vavg*abv6d + abv7&
&             *syd + sy*abv7d
            fs = lam3*drv + vavg*abv6 + sy*abv7
            fwd(i+1, j, k, imy) = fwd(i+1, j, k, imy) + fsd
            fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            fsd = drw*lam3d + lam3*drwd + abv6*wavgd + wavg*abv6d + abv7&
&             *szd + sz*abv7d
            fs = lam3*drw + wavg*abv6 + sz*abv7
            fwd(i+1, j, k, imz) = fwd(i+1, j, k, imz) + fsd
            fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            fsd = dre*lam3d + lam3*dred + abv6*havgd + havg*abv6d + abv7&
&             *unavgd + unavg*abv7d
            fs = lam3*dre + havg*abv6 + unavg*abv7
            fwd(i+1, j, k, irhoe) = fwd(i+1, j, k, irhoe) + fsd
            fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
          end do
        end do
      end do
!
!       dissipative fluxes in the j-direction.
!
      do k=2,kl
        do j=1,jl
          do i=2,il
! 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
              y2d = dssd(i, j+1, k, 2)
              y2 = dss(i, j+1, k, 2)
            else
              y2d = dssd(i, j, k, 2)
              y2 = dss(i, j, k, 2)
            end if
            if (dpmax .gt. y2) then
              min2d = y2d
              min2 = y2
            else
              min2 = dpmax
              min2d = 0.0_8
            end if
            dis2d = ppor*fis2*min2d
            dis2 = ppor*fis2*min2
            dis4d = mydim_d(ppor*fis4, 0.0_8, dis2, dis2d, dis4)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            ddw1d = wd(i, j+1, k, irho) - wd(i, j, k, irho)
            ddw1 = w(i, j+1, k, irho) - w(i, j, k, irho)
            temp3 = w(i, j+2, k, irho) - w(i, j-1, k, irho) - three*ddw1
            drd = ddw1*dis2d + dis2*ddw1d - temp3*dis4d - dis4*(wd(i, j+&
&             2, k, irho)-wd(i, j-1, k, irho)-three*ddw1d)
            dr = dis2*ddw1 - dis4*temp3
            temp3 = w(i, j+1, k, ivx)
            temp2 = w(i, j+1, k, irho)
            temp1 = w(i, j, k, ivx)
            temp0 = w(i, j, k, irho)
            ddw2d = temp3*wd(i, j+1, k, irho) + temp2*wd(i, j+1, k, ivx)&
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivx)
            ddw2 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw2
            drud = ddw2*dis2d + dis2*ddw2d - temp*dis4d - dis4*(temp1*wd&
&             (i, j+2, k, irho)+temp0*wd(i, j+2, k, ivx)-temp3*wd(i, j-1&
&             , k, irho)-temp2*wd(i, j-1, k, ivx)-three*ddw2d)
            dru = dis2*ddw2 - dis4*temp
            temp3 = w(i, j+1, k, ivy)
            temp2 = w(i, j+1, k, irho)
            temp1 = w(i, j, k, ivy)
            temp0 = w(i, j, k, irho)
            ddw3d = temp3*wd(i, j+1, k, irho) + temp2*wd(i, j+1, k, ivy)&
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivy)
            ddw3 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw3
            drvd = ddw3*dis2d + dis2*ddw3d - temp*dis4d - dis4*(temp1*wd&
&             (i, j+2, k, irho)+temp0*wd(i, j+2, k, ivy)-temp3*wd(i, j-1&
&             , k, irho)-temp2*wd(i, j-1, k, ivy)-three*ddw3d)
            drv = dis2*ddw3 - dis4*temp
            temp3 = w(i, j+1, k, ivz)
            temp2 = w(i, j+1, k, irho)
            temp1 = w(i, j, k, ivz)
            temp0 = w(i, j, k, irho)
            ddw4d = temp3*wd(i, j+1, k, irho) + temp2*wd(i, j+1, k, ivz)&
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivz)
            ddw4 = temp2*temp3 - temp0*temp1
            temp3 = w(i, j-1, k, ivz)
            temp2 = w(i, j-1, k, irho)
            temp1 = w(i, j+2, k, ivz)
            temp0 = w(i, j+2, k, irho)
            temp = temp0*temp1 - temp2*temp3 - three*ddw4
            drwd = ddw4*dis2d + dis2*ddw4d - temp*dis4d - dis4*(temp1*wd&
&             (i, j+2, k, irho)+temp0*wd(i, j+2, k, ivz)-temp3*wd(i, j-1&
&             , k, irho)-temp2*wd(i, j-1, k, ivz)-three*ddw4d)
            drw = dis2*ddw4 - dis4*temp
            ddw5d = wd(i, j+1, k, irhoe) - wd(i, j, k, irhoe)
            ddw5 = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
            temp3 = w(i, j+2, k, irhoe) - w(i, j-1, k, irhoe) - three*&
&             ddw5
            dred = ddw5*dis2d + dis2*ddw5d - temp3*dis4d - dis4*(wd(i, j&
&             +2, k, irhoe)-wd(i, j-1, k, irhoe)-three*ddw5d)
            dre = dis2*ddw5 - dis4*temp3
! 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
              temp3 = w(i, j+1, k, itu1)
              temp2 = w(i, j+1, k, irho)
              temp1 = w(i, j, k, itu1)
              temp0 = w(i, j, k, irho)
              ddw6d = temp3*wd(i, j+1, k, irho) + temp2*wd(i, j+1, k, &
&               itu1) - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, itu1&
&               )
              ddw6 = temp2*temp3 - temp0*temp1
              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)
              temp = temp0*temp1 - temp2*temp3 - three*ddw6
              drkd = ddw6*dis2d + dis2*ddw6d - temp*dis4d - dis4*(temp1*&
&               wd(i, j+2, k, irho)+temp0*wd(i, j+2, k, itu1)-temp3*wd(i&
&               , j-1, k, irho)-temp2*wd(i, j-1, k, itu1)-three*ddw6d)
              drk = dis2*ddw6 - dis4*temp
              kavgd = half*(wd(i, j, k, itu1)+wd(i, j+1, k, itu1))
              kavg = half*(w(i, j, k, itu1)+w(i, j+1, k, itu1))
            else
              drk = zero
              kavg = zero
              kavgd = 0.0_8
              drkd = 0.0_8
            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.
            uavgd = half*(wd(i, j+1, k, ivx)+wd(i, j, k, ivx))
            uavg = half*(w(i, j+1, k, ivx)+w(i, j, k, ivx))
            vavgd = half*(wd(i, j+1, k, ivy)+wd(i, j, k, ivy))
            vavg = half*(w(i, j+1, k, ivy)+w(i, j, k, ivy))
            wavgd = half*(wd(i, j+1, k, ivz)+wd(i, j, k, ivz))
            wavg = half*(w(i, j+1, k, ivz)+w(i, j, k, ivz))
            temp3 = gamma(i, j+1, k)
            temp2 = w(i, j+1, k, irho)
            temp1 = p(i, j+1, k)/temp2
            temp0 = w(i, j, k, irho)
            temp = p(i, j, k)/temp0
            a2avgd = half*(temp3*(pd(i, j+1, k)-temp1*wd(i, j+1, k, irho&
&             ))/temp2+gamma(i, j, k)*(pd(i, j, k)-temp*wd(i, j, k, irho&
&             ))/temp0)
            a2avg = half*(temp3*temp1+gamma(i, j, k)*temp)
            temp3 = sj(i, j, k, 1)
            temp2 = sj(i, j, k, 2)
            temp1 = sj(i, j, k, 3)
            arg1d = 2*temp3*sjd(i, j, k, 1) + 2*temp2*sjd(i, j, k, 2) + &
&             2*temp1*sjd(i, j, k, 3)
            arg1 = temp3*temp3 + temp2*temp2 + temp1*temp1
            temp3 = sqrt(arg1)
            if (arg1 .eq. 0.0_8) then
              aread = 0.0_8
            else
              aread = arg1d/(2.0*temp3)
            end if
            area = temp3
            if (1.e-25_realtype .lt. area) then
              max5d = aread
              max5 = area
            else
              max5 = 1.e-25_realtype
              max5d = 0.0_8
            end if
            tmpd = -(one*max5d/max5**2)
            tmp = one/max5
            temp3 = sj(i, j, k, 1)
            sxd = tmp*sjd(i, j, k, 1) + temp3*tmpd
            sx = temp3*tmp
            temp3 = sj(i, j, k, 2)
            syd = tmp*sjd(i, j, k, 2) + temp3*tmpd
            sy = temp3*tmp
            temp3 = sj(i, j, k, 3)
            szd = tmp*sjd(i, j, k, 3) + temp3*tmpd
            sz = temp3*tmp
            alphaavgd = half*(2*uavg*uavgd+2*vavg*vavgd+2*wavg*wavgd)
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            havgd = alphaavgd + ovgm1*(a2avgd-gm53*kavgd)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            temp3 = sqrt(a2avg)
            if (a2avg .eq. 0.0_8) then
              aavgd = 0.0_8
            else
              aavgd = a2avgd/(2.0*temp3)
            end if
            aavg = temp3
            unavgd = sx*uavgd + uavg*sxd + sy*vavgd + vavg*syd + sz*&
&             wavgd + wavg*szd
            unavg = uavg*sx + vavg*sy + wavg*sz
            ovaavgd = -(one*aavgd/aavg**2)
            ovaavg = one/aavg
            ova2avgd = -(one*a2avgd/a2avg**2)
            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
              sfaced = tmp*sfacejd(i, j, k) + sfacej(i, j, k)*tmpd
              sface = sfacej(i, j, k)*tmp
            end if
            if (unavg - sface + aavg .ge. 0.) then
              lam1d = unavgd - sfaced + aavgd
              lam1 = unavg - sface + aavg
            else
              lam1d = sfaced - unavgd - aavgd
              lam1 = -(unavg-sface+aavg)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2d = unavgd - sfaced - aavgd
              lam2 = unavg - sface - aavg
            else
              lam2d = sfaced - unavgd + aavgd
              lam2 = -(unavg-sface-aavg)
            end if
            if (unavg - sface .ge. 0.) then
              lam3d = unavgd - sfaced
              lam3 = unavg - sface
            else
              lam3d = sfaced - unavgd
              lam3 = -(unavg-sface)
            end if
            rradd = lam3d + aavgd
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              max6d = epsacoustic*rradd
              max6 = epsacoustic*rrad
            else
              max6d = lam1d
              max6 = lam1
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            lam1d = area*max6d + max6*aread
            lam1 = max6*area
            if (lam2 .lt. epsacoustic*rrad) then
              max7d = epsacoustic*rradd
              max7 = epsacoustic*rrad
            else
              max7d = lam2d
              max7 = lam2
            end if
            lam2d = area*max7d + max7*aread
            lam2 = max7*area
            if (lam3 .lt. epsshear*rrad) then
              max8d = epsshear*rradd
              max8 = epsshear*rrad
            else
              max8d = lam3d
              max8 = lam3
            end if
            lam3d = area*max8d + max8*aread
            lam3 = max8*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1d = half*(lam1d+lam2d)
            abv1 = half*(lam1+lam2)
            abv2d = half*(lam1d-lam2d)
            abv2 = half*(lam1-lam2)
            abv3d = abv1d - lam3d
            abv3 = abv1 - lam3
            abv4d = gm1*(dr*alphaavgd+alphaavg*drd-dru*uavgd-uavg*drud-&
&             drv*vavgd-vavg*drvd+dred-drw*wavgd-wavg*drwd) - gm53*drkd
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
            abv5d = dru*sxd + sx*drud + drv*syd + sy*drvd + drw*szd + sz&
&             *drwd - dr*unavgd - unavg*drd
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            abv6d = ova2avg*(abv4*abv3d+abv3*abv4d) + abv3*abv4*ova2avgd&
&             + ovaavg*(abv5*abv2d+abv2*abv5d) + abv2*abv5*ovaavgd
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7d = ovaavg*(abv4*abv2d+abv2*abv4d) + abv2*abv4*ovaavgd +&
&             abv5*abv3d + abv3*abv5d
            abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
            fsd = dr*lam3d + lam3*drd + abv6d
            fs = lam3*dr + abv6
            fwd(i, j+1, k, irho) = fwd(i, j+1, k, irho) + fsd
            fw(i, j+1, k, irho) = fw(i, j+1, k, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            fsd = dru*lam3d + lam3*drud + abv6*uavgd + uavg*abv6d + abv7&
&             *sxd + sx*abv7d
            fs = lam3*dru + uavg*abv6 + sx*abv7
            fwd(i, j+1, k, imx) = fwd(i, j+1, k, imx) + fsd
            fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            fsd = drv*lam3d + lam3*drvd + abv6*vavgd + vavg*abv6d + abv7&
&             *syd + sy*abv7d
            fs = lam3*drv + vavg*abv6 + sy*abv7
            fwd(i, j+1, k, imy) = fwd(i, j+1, k, imy) + fsd
            fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            fsd = drw*lam3d + lam3*drwd + abv6*wavgd + wavg*abv6d + abv7&
&             *szd + sz*abv7d
            fs = lam3*drw + wavg*abv6 + sz*abv7
            fwd(i, j+1, k, imz) = fwd(i, j+1, k, imz) + fsd
            fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            fsd = dre*lam3d + lam3*dred + abv6*havgd + havg*abv6d + abv7&
&             *unavgd + unavg*abv7d
            fs = lam3*dre + havg*abv6 + unavg*abv7
            fwd(i, j+1, k, irhoe) = fwd(i, j+1, k, irhoe) + fsd
            fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
          end do
        end do
      end do
!
!       dissipative fluxes in the k-direction.
!
      do k=1,kl
        do j=2,jl
          do i=2,il
! 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
              y3d = dssd(i, j, k+1, 3)
              y3 = dss(i, j, k+1, 3)
            else
              y3d = dssd(i, j, k, 3)
              y3 = dss(i, j, k, 3)
            end if
            if (dpmax .gt. y3) then
              min3d = y3d
              min3 = y3
            else
              min3 = dpmax
              min3d = 0.0_8
            end if
            dis2d = ppor*fis2*min3d
            dis2 = ppor*fis2*min3
            dis4d = mydim_d(ppor*fis4, 0.0_8, dis2, dis2d, dis4)
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            ddw1d = wd(i, j, k+1, irho) - wd(i, j, k, irho)
            ddw1 = w(i, j, k+1, irho) - w(i, j, k, irho)
            temp3 = w(i, j, k+2, irho) - w(i, j, k-1, irho) - three*ddw1
            drd = ddw1*dis2d + dis2*ddw1d - temp3*dis4d - dis4*(wd(i, j&
&             , k+2, irho)-wd(i, j, k-1, irho)-three*ddw1d)
            dr = dis2*ddw1 - dis4*temp3
            temp3 = w(i, j, k+1, ivx)
            temp2 = w(i, j, k+1, irho)
            temp1 = w(i, j, k, ivx)
            temp0 = w(i, j, k, irho)
            ddw2d = temp3*wd(i, j, k+1, irho) + temp2*wd(i, j, k+1, ivx)&
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivx)
            ddw2 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw2
            drud = ddw2*dis2d + dis2*ddw2d - temp*dis4d - dis4*(temp1*wd&
&             (i, j, k+2, irho)+temp0*wd(i, j, k+2, ivx)-temp3*wd(i, j, &
&             k-1, irho)-temp2*wd(i, j, k-1, ivx)-three*ddw2d)
            dru = dis2*ddw2 - dis4*temp
            temp3 = w(i, j, k+1, ivy)
            temp2 = w(i, j, k+1, irho)
            temp1 = w(i, j, k, ivy)
            temp0 = w(i, j, k, irho)
            ddw3d = temp3*wd(i, j, k+1, irho) + temp2*wd(i, j, k+1, ivy)&
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivy)
            ddw3 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw3
            drvd = ddw3*dis2d + dis2*ddw3d - temp*dis4d - dis4*(temp1*wd&
&             (i, j, k+2, irho)+temp0*wd(i, j, k+2, ivy)-temp3*wd(i, j, &
&             k-1, irho)-temp2*wd(i, j, k-1, ivy)-three*ddw3d)
            drv = dis2*ddw3 - dis4*temp
            temp3 = w(i, j, k+1, ivz)
            temp2 = w(i, j, k+1, irho)
            temp1 = w(i, j, k, ivz)
            temp0 = w(i, j, k, irho)
            ddw4d = temp3*wd(i, j, k+1, irho) + temp2*wd(i, j, k+1, ivz)&
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivz)
            ddw4 = temp2*temp3 - temp0*temp1
            temp3 = w(i, j, k-1, ivz)
            temp2 = w(i, j, k-1, irho)
            temp1 = w(i, j, k+2, ivz)
            temp0 = w(i, j, k+2, irho)
            temp = temp0*temp1 - temp2*temp3 - three*ddw4
            drwd = ddw4*dis2d + dis2*ddw4d - temp*dis4d - dis4*(temp1*wd&
&             (i, j, k+2, irho)+temp0*wd(i, j, k+2, ivz)-temp3*wd(i, j, &
&             k-1, irho)-temp2*wd(i, j, k-1, ivz)-three*ddw4d)
            drw = dis2*ddw4 - dis4*temp
            ddw5d = wd(i, j, k+1, irhoe) - wd(i, j, k, irhoe)
            ddw5 = w(i, j, k+1, irhoe) - w(i, j, k, irhoe)
            temp3 = w(i, j, k+2, irhoe) - w(i, j, k-1, irhoe) - three*&
&             ddw5
            dred = ddw5*dis2d + dis2*ddw5d - temp3*dis4d - dis4*(wd(i, j&
&             , k+2, irhoe)-wd(i, j, k-1, irhoe)-three*ddw5d)
            dre = dis2*ddw5 - dis4*temp3
! 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
              temp3 = w(i, j, k+1, itu1)
              temp2 = w(i, j, k+1, irho)
              temp1 = w(i, j, k, itu1)
              temp0 = w(i, j, k, irho)
              ddw6d = temp3*wd(i, j, k+1, irho) + temp2*wd(i, j, k+1, &
&               itu1) - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, itu1&
&               )
              ddw6 = temp2*temp3 - temp0*temp1
              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)
              temp = temp0*temp1 - temp2*temp3 - three*ddw6
              drkd = ddw6*dis2d + dis2*ddw6d - temp*dis4d - dis4*(temp1*&
&               wd(i, j, k+2, irho)+temp0*wd(i, j, k+2, itu1)-temp3*wd(i&
&               , j, k-1, irho)-temp2*wd(i, j, k-1, itu1)-three*ddw6d)
              drk = dis2*ddw6 - dis4*temp
              kavgd = half*(wd(i, j, k+1, itu1)+wd(i, j, k, itu1))
              kavg = half*(w(i, j, k+1, itu1)+w(i, j, k, itu1))
            else
              drk = zero
              kavg = zero
              kavgd = 0.0_8
              drkd = 0.0_8
            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.
            uavgd = half*(wd(i, j, k+1, ivx)+wd(i, j, k, ivx))
            uavg = half*(w(i, j, k+1, ivx)+w(i, j, k, ivx))
            vavgd = half*(wd(i, j, k+1, ivy)+wd(i, j, k, ivy))
            vavg = half*(w(i, j, k+1, ivy)+w(i, j, k, ivy))
            wavgd = half*(wd(i, j, k+1, ivz)+wd(i, j, k, ivz))
            wavg = half*(w(i, j, k+1, ivz)+w(i, j, k, ivz))
            temp3 = gamma(i, j, k+1)
            temp2 = w(i, j, k+1, irho)
            temp1 = p(i, j, k+1)/temp2
            temp0 = w(i, j, k, irho)
            temp = p(i, j, k)/temp0
            a2avgd = half*(temp3*(pd(i, j, k+1)-temp1*wd(i, j, k+1, irho&
&             ))/temp2+gamma(i, j, k)*(pd(i, j, k)-temp*wd(i, j, k, irho&
&             ))/temp0)
            a2avg = half*(temp3*temp1+gamma(i, j, k)*temp)
            temp3 = sk(i, j, k, 1)
            temp2 = sk(i, j, k, 2)
            temp1 = sk(i, j, k, 3)
            arg1d = 2*temp3*skd(i, j, k, 1) + 2*temp2*skd(i, j, k, 2) + &
&             2*temp1*skd(i, j, k, 3)
            arg1 = temp3*temp3 + temp2*temp2 + temp1*temp1
            temp3 = sqrt(arg1)
            if (arg1 .eq. 0.0_8) then
              aread = 0.0_8
            else
              aread = arg1d/(2.0*temp3)
            end if
            area = temp3
            if (1.e-25_realtype .lt. area) then
              max9d = aread
              max9 = area
            else
              max9 = 1.e-25_realtype
              max9d = 0.0_8
            end if
            tmpd = -(one*max9d/max9**2)
            tmp = one/max9
            temp3 = sk(i, j, k, 1)
            sxd = tmp*skd(i, j, k, 1) + temp3*tmpd
            sx = temp3*tmp
            temp3 = sk(i, j, k, 2)
            syd = tmp*skd(i, j, k, 2) + temp3*tmpd
            sy = temp3*tmp
            temp3 = sk(i, j, k, 3)
            szd = tmp*skd(i, j, k, 3) + temp3*tmpd
            sz = temp3*tmp
            alphaavgd = half*(2*uavg*uavgd+2*vavg*vavgd+2*wavg*wavgd)
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            havgd = alphaavgd + ovgm1*(a2avgd-gm53*kavgd)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            temp3 = sqrt(a2avg)
            if (a2avg .eq. 0.0_8) then
              aavgd = 0.0_8
            else
              aavgd = a2avgd/(2.0*temp3)
            end if
            aavg = temp3
            unavgd = sx*uavgd + uavg*sxd + sy*vavgd + vavg*syd + sz*&
&             wavgd + wavg*szd
            unavg = uavg*sx + vavg*sy + wavg*sz
            ovaavgd = -(one*aavgd/aavg**2)
            ovaavg = one/aavg
            ova2avgd = -(one*a2avgd/a2avg**2)
            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
              sfaced = tmp*sfacekd(i, j, k) + sfacek(i, j, k)*tmpd
              sface = sfacek(i, j, k)*tmp
            end if
            if (unavg - sface + aavg .ge. 0.) then
              lam1d = unavgd - sfaced + aavgd
              lam1 = unavg - sface + aavg
            else
              lam1d = sfaced - unavgd - aavgd
              lam1 = -(unavg-sface+aavg)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2d = unavgd - sfaced - aavgd
              lam2 = unavg - sface - aavg
            else
              lam2d = sfaced - unavgd + aavgd
              lam2 = -(unavg-sface-aavg)
            end if
            if (unavg - sface .ge. 0.) then
              lam3d = unavgd - sfaced
              lam3 = unavg - sface
            else
              lam3d = sfaced - unavgd
              lam3 = -(unavg-sface)
            end if
            rradd = lam3d + aavgd
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              max10d = epsacoustic*rradd
              max10 = epsacoustic*rrad
            else
              max10d = lam1d
              max10 = lam1
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            lam1d = area*max10d + max10*aread
            lam1 = max10*area
            if (lam2 .lt. epsacoustic*rrad) then
              max11d = epsacoustic*rradd
              max11 = epsacoustic*rrad
            else
              max11d = lam2d
              max11 = lam2
            end if
            lam2d = area*max11d + max11*aread
            lam2 = max11*area
            if (lam3 .lt. epsshear*rrad) then
              max12d = epsshear*rradd
              max12 = epsshear*rrad
            else
              max12d = lam3d
              max12 = lam3
            end if
            lam3d = area*max12d + max12*aread
            lam3 = max12*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1d = half*(lam1d+lam2d)
            abv1 = half*(lam1+lam2)
            abv2d = half*(lam1d-lam2d)
            abv2 = half*(lam1-lam2)
            abv3d = abv1d - lam3d
            abv3 = abv1 - lam3
            abv4d = gm1*(dr*alphaavgd+alphaavg*drd-dru*uavgd-uavg*drud-&
&             drv*vavgd-vavg*drvd+dred-drw*wavgd-wavg*drwd) - gm53*drkd
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
            abv5d = dru*sxd + sx*drud + drv*syd + sy*drvd + drw*szd + sz&
&             *drwd - dr*unavgd - unavg*drd
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            abv6d = ova2avg*(abv4*abv3d+abv3*abv4d) + abv3*abv4*ova2avgd&
&             + ovaavg*(abv5*abv2d+abv2*abv5d) + abv2*abv5*ovaavgd
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7d = ovaavg*(abv4*abv2d+abv2*abv4d) + abv2*abv4*ovaavgd +&
&             abv5*abv3d + abv3*abv5d
            abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
            fsd = dr*lam3d + lam3*drd + abv6d
            fs = lam3*dr + abv6
            fwd(i, j, k+1, irho) = fwd(i, j, k+1, irho) + fsd
            fw(i, j, k+1, irho) = fw(i, j, k+1, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            fsd = dru*lam3d + lam3*drud + abv6*uavgd + uavg*abv6d + abv7&
&             *sxd + sx*abv7d
            fs = lam3*dru + uavg*abv6 + sx*abv7
            fwd(i, j, k+1, imx) = fwd(i, j, k+1, imx) + fsd
            fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            fsd = drv*lam3d + lam3*drvd + abv6*vavgd + vavg*abv6d + abv7&
&             *syd + sy*abv7d
            fs = lam3*drv + vavg*abv6 + sy*abv7
            fwd(i, j, k+1, imy) = fwd(i, j, k+1, imy) + fsd
            fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            fsd = drw*lam3d + lam3*drwd + abv6*wavgd + wavg*abv6d + abv7&
&             *szd + sz*abv7d
            fs = lam3*drw + wavg*abv6 + sz*abv7
            fwd(i, j, k+1, imz) = fwd(i, j, k+1, imz) + fsd
            fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            fsd = dre*lam3d + lam3*dred + abv6*havgd + havg*abv6d + abv7&
&             *unavgd + unavg*abv7d
            fs = lam3*dre + havg*abv6 + unavg*abv7
            fwd(i, j, k+1, irhoe) = fwd(i, j, k+1, irhoe) + fsd
            fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
          end do
        end do
      end do
    end if
  end subroutine invisciddissfluxmatrix_d
 
  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_d, 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 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
! compute the pressure sensor for each cell, in each direction:
      do k=1,ke
        do j=1,je
          do i=1,ie
            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
        end do
      end do
!
!       dissipative fluxes in the i-direction.
!
      do k=2,kl
        do j=2,jl
          do i=1,il
! 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
            dis4 = mydim(ppor*fis4, 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))
            arg1 = si(i, j, k, 1)**2 + si(i, j, k, 2)**2 + si(i, j, k, 3&
&             )**2
            area = sqrt(arg1)
            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
        end do
      end do
!
!       dissipative fluxes in the j-direction.
!
      do k=2,kl
        do j=1,jl
          do i=2,il
! 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
            dis4 = mydim(ppor*fis4, 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))
            arg1 = sj(i, j, k, 1)**2 + sj(i, j, k, 2)**2 + sj(i, j, k, 3&
&             )**2
            area = sqrt(arg1)
            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
        end do
      end do
!
!       dissipative fluxes in the k-direction.
!
      do k=1,kl
        do j=2,jl
          do i=2,il
! 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
            dis4 = mydim(ppor*fis4, 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))
            arg1 = sk(i, j, k, 1)**2 + sk(i, j, k, 2)**2 + sk(i, j, k, 3&
&             )**2
            area = sqrt(arg1)
            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 do
      end do
    end if
  end subroutine invisciddissfluxmatrix
 
!  differentiation of invisciddissfluxscalar in forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: *fw
!   with respect to varying inputs: rhoinf pinfcorr *p *w *fw *radi
!                *radj *radk
!   rw status of diff variables: rhoinf:in pinfcorr:in *p:in *w:in
!                *fw:in-out *radi:in *radj:in *radk:in
!   plus diff mem management of: p:in w:in fw:in radi:in radj:in
!                radk:in
  subroutine invisciddissfluxscalar_d()
!
!       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_d, only : mydim, mydim_d
    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 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) :: temp
    real(kind=realtype) :: tempd
    real(kind=realtype) :: temp0
    real(kind=realtype) :: temp1
    real(kind=realtype) :: temp2
    real(kind=realtype) :: tempd0
    real(kind=realtype) :: temp3
    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.
        sslimd = 0.001_realtype*pinfcorrd
        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.
        ssd = pd
        ss = p
!===============================================================
        dssd = 0.0_8
      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.
        temp = rhoinf**gammainf
        if (rhoinf .le. 0.0_8 .and. (gammainf .eq. 0.0_8 .or. gammainf &
&           .ne. int(gammainf))) then
          tempd = 0.0_8
        else
          tempd = gammainf*rhoinf**(gammainf-1)*rhoinfd
        end if
        sslimd = 0.001_realtype*(pinfcorrd-pinfcorr*tempd/temp)/temp
        sslim = 0.001_realtype*(pinfcorr/temp)
        ssd = 0.0_8
! store the entropy in ss. see above.
        do k=0,kb
          do j=0,jb
            do i=0,ib
              temp = gamma(i, j, k)
              temp0 = w(i, j, k, irho)
              temp1 = temp0**temp
              temp2 = p(i, j, k)/temp1
              if (temp0 .le. 0.0_8 .and. (temp .eq. 0.0_8 .or. temp .ne.&
&                 int(temp))) then
                tempd0 = 0.0_8
              else
                tempd0 = temp*temp0**(temp-1)*wd(i, j, k, irho)
              end if
              ssd(i, j, k) = (pd(i, j, k)-temp2*tempd0)/temp1
              ss(i, j, k) = temp2
            end do
          end do
        end do
        dssd = 0.0_8
      case default
        sslimd = 0.0_8
        ssd = 0.0_8
        dssd = 0.0_8
      end select
! compute the pressure sensor for each cell, in each direction:
      do k=1,ke
        do j=1,je
          do i=1,ie
            temp2 = ss(i+1, j, k) + two*ss(i, j, k) + ss(i-1, j, k) + &
&             sslim
            temp1 = (ss(i+1, j, k)-two*ss(i, j, k)+ss(i-1, j, k))/temp2
            x1d = (ssd(i+1, j, k)-two*ssd(i, j, k)+ssd(i-1, j, k)-temp1*&
&             (ssd(i+1, j, k)+two*ssd(i, j, k)+ssd(i-1, j, k)+sslimd))/&
&             temp2
            x1 = temp1
            if (x1 .ge. 0.) then
              dssd(i, j, k, 1) = x1d
              dss(i, j, k, 1) = x1
            else
              dssd(i, j, k, 1) = -x1d
              dss(i, j, k, 1) = -x1
            end if
            temp2 = ss(i, j+1, k) + two*ss(i, j, k) + ss(i, j-1, k) + &
&             sslim
            temp1 = (ss(i, j+1, k)-two*ss(i, j, k)+ss(i, j-1, k))/temp2
            x2d = (ssd(i, j+1, k)-two*ssd(i, j, k)+ssd(i, j-1, k)-temp1*&
&             (ssd(i, j+1, k)+two*ssd(i, j, k)+ssd(i, j-1, k)+sslimd))/&
&             temp2
            x2 = temp1
            if (x2 .ge. 0.) then
              dssd(i, j, k, 2) = x2d
              dss(i, j, k, 2) = x2
            else
              dssd(i, j, k, 2) = -x2d
              dss(i, j, k, 2) = -x2
            end if
            temp2 = ss(i, j, k+1) + two*ss(i, j, k) + ss(i, j, k-1) + &
&             sslim
            temp1 = (ss(i, j, k+1)-two*ss(i, j, k)+ss(i, j, k-1))/temp2
            x3d = (ssd(i, j, k+1)-two*ssd(i, j, k)+ssd(i, j, k-1)-temp1*&
&             (ssd(i, j, k+1)+two*ssd(i, j, k)+ssd(i, j, k-1)+sslimd))/&
&             temp2
            x3 = temp1
            if (x3 .ge. 0.) then
              dssd(i, j, k, 3) = x3d
              dss(i, j, k, 3) = x3
            else
              dssd(i, j, k, 3) = -x3d
              dss(i, j, k, 3) = -x3
            end if
          end do
        end do
      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
          arg1 = -(disscontsharpness*(log10(totalr/totalr0)+&
&           disscontmidpoint))
          fis2 = rfil*(vis2+disscontmagnitude/(1+exp(arg1)))
        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.
      fwd = sfil*fwd
      fw = sfil*fw
!
!       dissipative fluxes in the i-direction.
!
      do k=2,kl
        do j=2,jl
          do i=1,il
! compute the dissipation coefficients for this face.
            ppor = zero
            if (pori(i, j, k) .eq. normalflux) ppor = half
            rradd = ppor*(radid(i, j, k)+radid(i+1, j, k))
            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
              y1d = dssd(i+1, j, k, 1)
              y1 = dss(i+1, j, k, 1)
            else
              y1d = dssd(i, j, k, 1)
              y1 = dss(i, j, k, 1)
            end if
            if (dssmax .gt. y1) then
              min1d = y1d
              min1 = y1
            else
              min1 = dssmax
              min1d = 0.0_8
            end if
            dis2d = fis2*(min1*rradd+rrad*min1d)
            dis2 = fis2*rrad*min1
            dis4d = mydim_d(fis4*rrad, fis4*rradd, dis2, dis2d, dis4)
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
            ddw1d = wd(i+1, j, k, irho) - wd(i, j, k, irho)
            ddw1 = w(i+1, j, k, irho) - w(i, j, k, irho)
            temp2 = w(i+2, j, k, irho) - w(i-1, j, k, irho) - three*ddw1
            fsd = ddw1*dis2d + dis2*ddw1d - temp2*dis4d - dis4*(wd(i+2, &
&             j, k, irho)-wd(i-1, j, k, irho)-three*ddw1d)
            fs = dis2*ddw1 - dis4*temp2
            fwd(i+1, j, k, irho) = fwd(i+1, j, k, irho) + fsd
            fw(i+1, j, k, irho) = fw(i+1, j, k, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            temp2 = w(i+1, j, k, irho)
            temp1 = w(i+1, j, k, ivx)
            temp0 = w(i, j, k, irho)
            temp = w(i, j, k, ivx)
            ddw2d = temp2*wd(i+1, j, k, ivx) + temp1*wd(i+1, j, k, irho)&
&             - temp0*wd(i, j, k, ivx) - temp*wd(i, j, k, irho)
            ddw2 = temp1*temp2 - temp*temp0
            temp2 = w(i-1, j, k, irho)
            temp1 = w(i-1, j, k, ivx)
            temp0 = w(i+2, j, k, irho)
            temp = w(i+2, j, k, ivx)
            temp3 = temp*temp0 - temp1*temp2 - three*ddw2
            fsd = ddw2*dis2d + dis2*ddw2d - temp3*dis4d - dis4*(temp0*wd&
&             (i+2, j, k, ivx)+temp*wd(i+2, j, k, irho)-temp2*wd(i-1, j&
&             , k, ivx)-temp1*wd(i-1, j, k, irho)-three*ddw2d)
            fs = dis2*ddw2 - dis4*temp3
            fwd(i+1, j, k, imx) = fwd(i+1, j, k, imx) + fsd
            fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            temp3 = w(i+1, j, k, irho)
            temp2 = w(i+1, j, k, ivy)
            temp1 = w(i, j, k, irho)
            temp0 = w(i, j, k, ivy)
            ddw3d = temp3*wd(i+1, j, k, ivy) + temp2*wd(i+1, j, k, irho)&
&             - temp1*wd(i, j, k, ivy) - temp0*wd(i, j, k, irho)
            ddw3 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw3
            fsd = ddw3*dis2d + dis2*ddw3d - temp*dis4d - dis4*(temp1*wd(&
&             i+2, j, k, ivy)+temp0*wd(i+2, j, k, irho)-temp3*wd(i-1, j&
&             , k, ivy)-temp2*wd(i-1, j, k, irho)-three*ddw3d)
            fs = dis2*ddw3 - dis4*temp
            fwd(i+1, j, k, imy) = fwd(i+1, j, k, imy) + fsd
            fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            temp3 = w(i+1, j, k, irho)
            temp2 = w(i+1, j, k, ivz)
            temp1 = w(i, j, k, irho)
            temp0 = w(i, j, k, ivz)
            ddw4d = temp3*wd(i+1, j, k, ivz) + temp2*wd(i+1, j, k, irho)&
&             - temp1*wd(i, j, k, ivz) - temp0*wd(i, j, k, irho)
            ddw4 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw4
            fsd = ddw4*dis2d + dis2*ddw4d - temp*dis4d - dis4*(temp1*wd(&
&             i+2, j, k, ivz)+temp0*wd(i+2, j, k, irho)-temp3*wd(i-1, j&
&             , k, ivz)-temp2*wd(i-1, j, k, irho)-three*ddw4d)
            fs = dis2*ddw4 - dis4*temp
            fwd(i+1, j, k, imz) = fwd(i+1, j, k, imz) + fsd
            fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            ddw5d = wd(i+1, j, k, irhoe) + pd(i+1, j, k) - wd(i, j, k, &
&             irhoe) - pd(i, j, k)
            ddw5 = w(i+1, j, k, irhoe) + p(i+1, j, k) - (w(i, j, k, &
&             irhoe)+p(i, j, k))
            temp3 = 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 = ddw5*dis2d + dis2*ddw5d - temp3*dis4d - dis4*(wd(i+2, &
&             j, k, irhoe)+pd(i+2, j, k)-wd(i-1, j, k, irhoe)-pd(i-1, j&
&             , k)-three*ddw5d)
            fs = dis2*ddw5 - dis4*temp3
            fwd(i+1, j, k, irhoe) = fwd(i+1, j, k, irhoe) + fsd
            fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
          end do
        end do
      end do
!
!       dissipative fluxes in the j-direction.
!
      do k=2,kl
        do j=1,jl
          do i=2,il
! compute the dissipation coefficients for this face.
            ppor = zero
            if (porj(i, j, k) .eq. normalflux) ppor = half
            rradd = ppor*(radjd(i, j, k)+radjd(i, j+1, k))
            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
              y2d = dssd(i, j+1, k, 2)
              y2 = dss(i, j+1, k, 2)
            else
              y2d = dssd(i, j, k, 2)
              y2 = dss(i, j, k, 2)
            end if
            if (dssmax .gt. y2) then
              min2d = y2d
              min2 = y2
            else
              min2 = dssmax
              min2d = 0.0_8
            end if
            dis2d = fis2*(min2*rradd+rrad*min2d)
            dis2 = fis2*rrad*min2
            dis4d = mydim_d(fis4*rrad, fis4*rradd, dis2, dis2d, dis4)
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
            ddw1d = wd(i, j+1, k, irho) - wd(i, j, k, irho)
            ddw1 = w(i, j+1, k, irho) - w(i, j, k, irho)
            temp3 = w(i, j+2, k, irho) - w(i, j-1, k, irho) - three*ddw1
            fsd = ddw1*dis2d + dis2*ddw1d - temp3*dis4d - dis4*(wd(i, j+&
&             2, k, irho)-wd(i, j-1, k, irho)-three*ddw1d)
            fs = dis2*ddw1 - dis4*temp3
            fwd(i, j+1, k, irho) = fwd(i, j+1, k, irho) + fsd
            fw(i, j+1, k, irho) = fw(i, j+1, k, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            temp3 = w(i, j+1, k, irho)
            temp2 = w(i, j+1, k, ivx)
            temp1 = w(i, j, k, irho)
            temp0 = w(i, j, k, ivx)
            ddw2d = temp3*wd(i, j+1, k, ivx) + temp2*wd(i, j+1, k, irho)&
&             - temp1*wd(i, j, k, ivx) - temp0*wd(i, j, k, irho)
            ddw2 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw2
            fsd = ddw2*dis2d + dis2*ddw2d - temp*dis4d - dis4*(temp1*wd(&
&             i, j+2, k, ivx)+temp0*wd(i, j+2, k, irho)-temp3*wd(i, j-1&
&             , k, ivx)-temp2*wd(i, j-1, k, irho)-three*ddw2d)
            fs = dis2*ddw2 - dis4*temp
            fwd(i, j+1, k, imx) = fwd(i, j+1, k, imx) + fsd
            fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            temp3 = w(i, j+1, k, irho)
            temp2 = w(i, j+1, k, ivy)
            temp1 = w(i, j, k, irho)
            temp0 = w(i, j, k, ivy)
            ddw3d = temp3*wd(i, j+1, k, ivy) + temp2*wd(i, j+1, k, irho)&
&             - temp1*wd(i, j, k, ivy) - temp0*wd(i, j, k, irho)
            ddw3 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw3
            fsd = ddw3*dis2d + dis2*ddw3d - temp*dis4d - dis4*(temp1*wd(&
&             i, j+2, k, ivy)+temp0*wd(i, j+2, k, irho)-temp3*wd(i, j-1&
&             , k, ivy)-temp2*wd(i, j-1, k, irho)-three*ddw3d)
            fs = dis2*ddw3 - dis4*temp
            fwd(i, j+1, k, imy) = fwd(i, j+1, k, imy) + fsd
            fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            temp3 = w(i, j+1, k, irho)
            temp2 = w(i, j+1, k, ivz)
            temp1 = w(i, j, k, irho)
            temp0 = w(i, j, k, ivz)
            ddw4d = temp3*wd(i, j+1, k, ivz) + temp2*wd(i, j+1, k, irho)&
&             - temp1*wd(i, j, k, ivz) - temp0*wd(i, j, k, irho)
            ddw4 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw4
            fsd = ddw4*dis2d + dis2*ddw4d - temp*dis4d - dis4*(temp1*wd(&
&             i, j+2, k, ivz)+temp0*wd(i, j+2, k, irho)-temp3*wd(i, j-1&
&             , k, ivz)-temp2*wd(i, j-1, k, irho)-three*ddw4d)
            fs = dis2*ddw4 - dis4*temp
            fwd(i, j+1, k, imz) = fwd(i, j+1, k, imz) + fsd
            fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            ddw5d = wd(i, j+1, k, irhoe) + pd(i, j+1, k) - wd(i, j, k, &
&             irhoe) - pd(i, j, k)
            ddw5 = w(i, j+1, k, irhoe) + p(i, j+1, k) - (w(i, j, k, &
&             irhoe)+p(i, j, k))
            temp3 = 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 = ddw5*dis2d + dis2*ddw5d - temp3*dis4d - dis4*(wd(i, j+&
&             2, k, irhoe)+pd(i, j+2, k)-wd(i, j-1, k, irhoe)-pd(i, j-1&
&             , k)-three*ddw5d)
            fs = dis2*ddw5 - dis4*temp3
            fwd(i, j+1, k, irhoe) = fwd(i, j+1, k, irhoe) + fsd
            fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
          end do
        end do
      end do
!
!       dissipative fluxes in the k-direction.
!
      do k=1,kl
        do j=2,jl
          do i=2,il
! compute the dissipation coefficients for this face.
            ppor = zero
            if (pork(i, j, k) .eq. normalflux) ppor = half
            rradd = ppor*(radkd(i, j, k)+radkd(i, j, k+1))
            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
              y3d = dssd(i, j, k+1, 3)
              y3 = dss(i, j, k+1, 3)
            else
              y3d = dssd(i, j, k, 3)
              y3 = dss(i, j, k, 3)
            end if
            if (dssmax .gt. y3) then
              min3d = y3d
              min3 = y3
            else
              min3 = dssmax
              min3d = 0.0_8
            end if
            dis2d = fis2*(min3*rradd+rrad*min3d)
            dis2 = fis2*rrad*min3
            dis4d = mydim_d(fis4*rrad, fis4*rradd, dis2, dis2d, dis4)
! compute and scatter the dissipative flux.
! density. store it in the mass flow of the
! appropriate sliding mesh interface.
            ddw1d = wd(i, j, k+1, irho) - wd(i, j, k, irho)
            ddw1 = w(i, j, k+1, irho) - w(i, j, k, irho)
            temp3 = w(i, j, k+2, irho) - w(i, j, k-1, irho) - three*ddw1
            fsd = ddw1*dis2d + dis2*ddw1d - temp3*dis4d - dis4*(wd(i, j&
&             , k+2, irho)-wd(i, j, k-1, irho)-three*ddw1d)
            fs = dis2*ddw1 - dis4*temp3
            fwd(i, j, k+1, irho) = fwd(i, j, k+1, irho) + fsd
            fw(i, j, k+1, irho) = fw(i, j, k+1, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            temp3 = w(i, j, k+1, irho)
            temp2 = w(i, j, k+1, ivx)
            temp1 = w(i, j, k, irho)
            temp0 = w(i, j, k, ivx)
            ddw2d = temp3*wd(i, j, k+1, ivx) + temp2*wd(i, j, k+1, irho)&
&             - temp1*wd(i, j, k, ivx) - temp0*wd(i, j, k, irho)
            ddw2 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw2
            fsd = ddw2*dis2d + dis2*ddw2d - temp*dis4d - dis4*(temp1*wd(&
&             i, j, k+2, ivx)+temp0*wd(i, j, k+2, irho)-temp3*wd(i, j, k&
&             -1, ivx)-temp2*wd(i, j, k-1, irho)-three*ddw2d)
            fs = dis2*ddw2 - dis4*temp
            fwd(i, j, k+1, imx) = fwd(i, j, k+1, imx) + fsd
            fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            temp3 = w(i, j, k+1, irho)
            temp2 = w(i, j, k+1, ivy)
            temp1 = w(i, j, k, irho)
            temp0 = w(i, j, k, ivy)
            ddw3d = temp3*wd(i, j, k+1, ivy) + temp2*wd(i, j, k+1, irho)&
&             - temp1*wd(i, j, k, ivy) - temp0*wd(i, j, k, irho)
            ddw3 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw3
            fsd = ddw3*dis2d + dis2*ddw3d - temp*dis4d - dis4*(temp1*wd(&
&             i, j, k+2, ivy)+temp0*wd(i, j, k+2, irho)-temp3*wd(i, j, k&
&             -1, ivy)-temp2*wd(i, j, k-1, irho)-three*ddw3d)
            fs = dis2*ddw3 - dis4*temp
            fwd(i, j, k+1, imy) = fwd(i, j, k+1, imy) + fsd
            fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            temp3 = w(i, j, k+1, irho)
            temp2 = w(i, j, k+1, ivz)
            temp1 = w(i, j, k, irho)
            temp0 = w(i, j, k, ivz)
            ddw4d = temp3*wd(i, j, k+1, ivz) + temp2*wd(i, j, k+1, irho)&
&             - temp1*wd(i, j, k, ivz) - temp0*wd(i, j, k, irho)
            ddw4 = temp2*temp3 - temp0*temp1
            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)
            temp = temp0*temp1 - temp2*temp3 - three*ddw4
            fsd = ddw4*dis2d + dis2*ddw4d - temp*dis4d - dis4*(temp1*wd(&
&             i, j, k+2, ivz)+temp0*wd(i, j, k+2, irho)-temp3*wd(i, j, k&
&             -1, ivz)-temp2*wd(i, j, k-1, irho)-three*ddw4d)
            fs = dis2*ddw4 - dis4*temp
            fwd(i, j, k+1, imz) = fwd(i, j, k+1, imz) + fsd
            fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            ddw5d = wd(i, j, k+1, irhoe) + pd(i, j, k+1) - wd(i, j, k, &
&             irhoe) - pd(i, j, k)
            ddw5 = w(i, j, k+1, irhoe) + p(i, j, k+1) - (w(i, j, k, &
&             irhoe)+p(i, j, k))
            temp3 = 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 = ddw5*dis2d + dis2*ddw5d - temp3*dis4d - dis4*(wd(i, j&
&             , k+2, irhoe)+pd(i, j, k+2)-wd(i, j, k-1, irhoe)-pd(i, j, &
&             k-1)-three*ddw5d)
            fs = dis2*ddw5 - dis4*temp3
            fwd(i, j, k+1, irhoe) = fwd(i, j, k+1, irhoe) + fsd
            fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
          end do
        end do
      end do
    end if
  end subroutine invisciddissfluxscalar_d
 
  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_d, 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 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
! store the entropy in ss. see above.
        do k=0,kb
          do j=0,jb
            do i=0,ib
              ss(i, j, k) = p(i, j, k)/w(i, j, k, irho)**gamma(i, j, k)
            end do
          end do
        end do
      end select
! compute the pressure sensor for each cell, in each direction:
      do k=1,ke
        do j=1,je
          do i=1,ie
            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
        end do
      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
          arg1 = -(disscontsharpness*(log10(totalr/totalr0)+&
&           disscontmidpoint))
          fis2 = rfil*(vis2+disscontmagnitude/(1+exp(arg1)))
        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
!
!       dissipative fluxes in the i-direction.
!
      do k=2,kl
        do j=2,jl
          do i=1,il
! 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
            dis4 = mydim(fis4*rrad, 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
        end do
      end do
!
!       dissipative fluxes in the j-direction.
!
      do k=2,kl
        do j=1,jl
          do i=2,il
! 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
            dis4 = mydim(fis4*rrad, 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
        end do
      end do
!
!       dissipative fluxes in the k-direction.
!
      do k=1,kl
        do j=2,jl
          do i=2,il
! 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
            dis4 = mydim(fis4*rrad, 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 do
      end do
    end if
  end subroutine invisciddissfluxscalar
 
!  differentiation of inviscidupwindflux in forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: *fw
!   with respect to varying inputs: *p *sfacei *sfacej *sfacek
!                *w *si *sj *sk *fw
!   rw status of diff variables: *p:in *sfacei:in *sfacej:in *sfacek:in
!                *w:in *si:in *sj:in *sk:in *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_d(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_d, only : getcorrectfork, terminate
    use flowutils_d, only : etot, etot_d
    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
    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
            fwd(i, j, k, irho) = sfil*fwd(i, j, k, irho)
            fw(i, j, k, irho) = sfil*fw(i, j, k, irho)
            fwd(i, j, k, imx) = sfil*fwd(i, j, k, imx)
            fw(i, j, k, imx) = sfil*fw(i, j, k, imx)
            fwd(i, j, k, imy) = sfil*fwd(i, j, k, imy)
            fw(i, j, k, imy) = sfil*fw(i, j, k, imy)
            fwd(i, j, k, imz) = sfil*fwd(i, j, k, imz)
            fw(i, j, k, imz) = sfil*fw(i, j, k, imz)
            fwd(i, j, k, irhoe) = sfil*fwd(i, j, k, irhoe)
            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
        fluxd = 0.0_8
        leftd = 0.0_8
        rightd = 0.0_8
        sfaced = 0.0_8
!
!         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.
              sxd = sid(i, j, k, 1)
              sx = si(i, j, k, 1)
              syd = sid(i, j, k, 2)
              sy = si(i, j, k, 2)
              szd = sid(i, j, k, 3)
              sz = si(i, j, k, 3)
              por = pori(i, j, k)
              if (addgridvelocities) then
                sfaced = sfaceid(i, j, k)
                sface = sfacei(i, j, k)
              end if
! determine the left and right state.
              leftd(irho) = wd(i, j, k, irho)
              left(irho) = w(i, j, k, irho)
              leftd(ivx) = wd(i, j, k, ivx)
              left(ivx) = w(i, j, k, ivx)
              leftd(ivy) = wd(i, j, k, ivy)
              left(ivy) = w(i, j, k, ivy)
              leftd(ivz) = wd(i, j, k, ivz)
              left(ivz) = w(i, j, k, ivz)
              leftd(irhoe) = pd(i, j, k)
              left(irhoe) = p(i, j, k)
              if (correctfork) then
                leftd(itu1) = wd(i, j, k, itu1)
                left(itu1) = w(i, j, k, itu1)
              end if
              rightd(irho) = wd(i+1, j, k, irho)
              right(irho) = w(i+1, j, k, irho)
              rightd(ivx) = wd(i+1, j, k, ivx)
              right(ivx) = w(i+1, j, k, ivx)
              rightd(ivy) = wd(i+1, j, k, ivy)
              right(ivy) = w(i+1, j, k, ivy)
              rightd(ivz) = wd(i+1, j, k, ivz)
              right(ivz) = w(i+1, j, k, ivz)
              rightd(irhoe) = pd(i+1, j, k)
              right(irhoe) = p(i+1, j, k)
              if (correctfork) then
                rightd(itu1) = wd(i+1, j, k, itu1)
                right(itu1) = w(i+1, j, k, itu1)
              end if
! 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_d(left, leftd, right, rightd, flux, fluxd&
&                         )
! and scatter it to the left and right.
              fwd(i, j, k, irho) = fwd(i, j, k, irho) + fluxd(irho)
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fwd(i, j, k, imx) = fwd(i, j, k, imx) + fluxd(imx)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fwd(i, j, k, imy) = fwd(i, j, k, imy) + fluxd(imy)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fwd(i, j, k, imz) = fwd(i, j, k, imz) + fluxd(imz)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) + fluxd(irhoe)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fwd(i+1, j, k, irho) = fwd(i+1, j, k, irho) - fluxd(irho)
              fw(i+1, j, k, irho) = fw(i+1, j, k, irho) - flux(irho)
              fwd(i+1, j, k, imx) = fwd(i+1, j, k, imx) - fluxd(imx)
              fw(i+1, j, k, imx) = fw(i+1, j, k, imx) - flux(imx)
              fwd(i+1, j, k, imy) = fwd(i+1, j, k, imy) - fluxd(imy)
              fw(i+1, j, k, imy) = fw(i+1, j, k, imy) - flux(imy)
              fwd(i+1, j, k, imz) = fwd(i+1, j, k, imz) - fluxd(imz)
              fw(i+1, j, k, imz) = fw(i+1, j, k, imz) - flux(imz)
              fwd(i+1, j, k, irhoe) = fwd(i+1, j, k, irhoe) - fluxd(&
&               irhoe)
              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.
              sxd = sjd(i, j, k, 1)
              sx = sj(i, j, k, 1)
              syd = sjd(i, j, k, 2)
              sy = sj(i, j, k, 2)
              szd = sjd(i, j, k, 3)
              sz = sj(i, j, k, 3)
              por = porj(i, j, k)
              if (addgridvelocities) then
                sfaced = sfacejd(i, j, k)
                sface = sfacej(i, j, k)
              end if
! determine the left and right state.
              leftd(irho) = wd(i, j, k, irho)
              left(irho) = w(i, j, k, irho)
              leftd(ivx) = wd(i, j, k, ivx)
              left(ivx) = w(i, j, k, ivx)
              leftd(ivy) = wd(i, j, k, ivy)
              left(ivy) = w(i, j, k, ivy)
              leftd(ivz) = wd(i, j, k, ivz)
              left(ivz) = w(i, j, k, ivz)
              leftd(irhoe) = pd(i, j, k)
              left(irhoe) = p(i, j, k)
              if (correctfork) then
                leftd(itu1) = wd(i, j, k, itu1)
                left(itu1) = w(i, j, k, itu1)
              end if
              rightd(irho) = wd(i, j+1, k, irho)
              right(irho) = w(i, j+1, k, irho)
              rightd(ivx) = wd(i, j+1, k, ivx)
              right(ivx) = w(i, j+1, k, ivx)
              rightd(ivy) = wd(i, j+1, k, ivy)
              right(ivy) = w(i, j+1, k, ivy)
              rightd(ivz) = wd(i, j+1, k, ivz)
              right(ivz) = w(i, j+1, k, ivz)
              rightd(irhoe) = pd(i, j+1, k)
              right(irhoe) = p(i, j+1, k)
              if (correctfork) then
                rightd(itu1) = wd(i, j+1, k, itu1)
                right(itu1) = w(i, j+1, k, itu1)
              end if
! 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_d(left, leftd, right, rightd, flux, fluxd&
&                         )
! and scatter it to the left and right.
              fwd(i, j, k, irho) = fwd(i, j, k, irho) + fluxd(irho)
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fwd(i, j, k, imx) = fwd(i, j, k, imx) + fluxd(imx)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fwd(i, j, k, imy) = fwd(i, j, k, imy) + fluxd(imy)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fwd(i, j, k, imz) = fwd(i, j, k, imz) + fluxd(imz)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) + fluxd(irhoe)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fwd(i, j+1, k, irho) = fwd(i, j+1, k, irho) - fluxd(irho)
              fw(i, j+1, k, irho) = fw(i, j+1, k, irho) - flux(irho)
              fwd(i, j+1, k, imx) = fwd(i, j+1, k, imx) - fluxd(imx)
              fw(i, j+1, k, imx) = fw(i, j+1, k, imx) - flux(imx)
              fwd(i, j+1, k, imy) = fwd(i, j+1, k, imy) - fluxd(imy)
              fw(i, j+1, k, imy) = fw(i, j+1, k, imy) - flux(imy)
              fwd(i, j+1, k, imz) = fwd(i, j+1, k, imz) - fluxd(imz)
              fw(i, j+1, k, imz) = fw(i, j+1, k, imz) - flux(imz)
              fwd(i, j+1, k, irhoe) = fwd(i, j+1, k, irhoe) - fluxd(&
&               irhoe)
              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.
              sxd = skd(i, j, k, 1)
              sx = sk(i, j, k, 1)
              syd = skd(i, j, k, 2)
              sy = sk(i, j, k, 2)
              szd = skd(i, j, k, 3)
              sz = sk(i, j, k, 3)
              por = pork(i, j, k)
              if (addgridvelocities) then
                sfaced = sfacekd(i, j, k)
                sface = sfacek(i, j, k)
              end if
! determine the left and right state.
              leftd(irho) = wd(i, j, k, irho)
              left(irho) = w(i, j, k, irho)
              leftd(ivx) = wd(i, j, k, ivx)
              left(ivx) = w(i, j, k, ivx)
              leftd(ivy) = wd(i, j, k, ivy)
              left(ivy) = w(i, j, k, ivy)
              leftd(ivz) = wd(i, j, k, ivz)
              left(ivz) = w(i, j, k, ivz)
              leftd(irhoe) = pd(i, j, k)
              left(irhoe) = p(i, j, k)
              if (correctfork) then
                leftd(itu1) = wd(i, j, k, itu1)
                left(itu1) = w(i, j, k, itu1)
              end if
              rightd(irho) = wd(i, j, k+1, irho)
              right(irho) = w(i, j, k+1, irho)
              rightd(ivx) = wd(i, j, k+1, ivx)
              right(ivx) = w(i, j, k+1, ivx)
              rightd(ivy) = wd(i, j, k+1, ivy)
              right(ivy) = w(i, j, k+1, ivy)
              rightd(ivz) = wd(i, j, k+1, ivz)
              right(ivz) = w(i, j, k+1, ivz)
              rightd(irhoe) = pd(i, j, k+1)
              right(irhoe) = p(i, j, k+1)
              if (correctfork) then
                rightd(itu1) = wd(i, j, k+1, itu1)
                right(itu1) = w(i, j, k+1, itu1)
              end if
! 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_d(left, leftd, right, rightd, flux, fluxd&
&                         )
! and scatter it the left and right.
              fwd(i, j, k, irho) = fwd(i, j, k, irho) + fluxd(irho)
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fwd(i, j, k, imx) = fwd(i, j, k, imx) + fluxd(imx)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fwd(i, j, k, imy) = fwd(i, j, k, imy) + fluxd(imy)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fwd(i, j, k, imz) = fwd(i, j, k, imz) + fluxd(imz)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) + fluxd(irhoe)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fwd(i, j, k+1, irho) = fwd(i, j, k+1, irho) - fluxd(irho)
              fw(i, j, k+1, irho) = fw(i, j, k+1, irho) - flux(irho)
              fwd(i, j, k+1, imx) = fwd(i, j, k+1, imx) - fluxd(imx)
              fw(i, j, k+1, imx) = fw(i, j, k+1, imx) - flux(imx)
              fwd(i, j, k+1, imy) = fwd(i, j, k+1, imy) - fluxd(imy)
              fw(i, j, k+1, imy) = fw(i, j, k+1, imy) - flux(imy)
              fwd(i, j, k+1, imz) = fwd(i, j, k+1, imz) - fluxd(imz)
              fw(i, j, k+1, imz) = fw(i, j, k+1, imz) - flux(imz)
              fwd(i, j, k+1, irhoe) = fwd(i, j, k+1, irhoe) - fluxd(&
&               irhoe)
              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
        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
!      ==================================================================
!      ==================================================================
!
!         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.
              du1d(irho) = wd(i, j, k, irho) - wd(i-1, j, k, irho)
              du1(irho) = w(i, j, k, irho) - w(i-1, j, k, irho)
              du2d(irho) = wd(i+1, j, k, irho) - wd(i, j, k, irho)
              du2(irho) = w(i+1, j, k, irho) - w(i, j, k, irho)
              du3d(irho) = wd(i+2, j, k, irho) - wd(i+1, j, k, irho)
              du3(irho) = w(i+2, j, k, irho) - w(i+1, j, k, irho)
              du1d(ivx) = wd(i, j, k, ivx) - wd(i-1, j, k, ivx)
              du1(ivx) = w(i, j, k, ivx) - w(i-1, j, k, ivx)
              du2d(ivx) = wd(i+1, j, k, ivx) - wd(i, j, k, ivx)
              du2(ivx) = w(i+1, j, k, ivx) - w(i, j, k, ivx)
              du3d(ivx) = wd(i+2, j, k, ivx) - wd(i+1, j, k, ivx)
              du3(ivx) = w(i+2, j, k, ivx) - w(i+1, j, k, ivx)
              du1d(ivy) = wd(i, j, k, ivy) - wd(i-1, j, k, ivy)
              du1(ivy) = w(i, j, k, ivy) - w(i-1, j, k, ivy)
              du2d(ivy) = wd(i+1, j, k, ivy) - wd(i, j, k, ivy)
              du2(ivy) = w(i+1, j, k, ivy) - w(i, j, k, ivy)
              du3d(ivy) = wd(i+2, j, k, ivy) - wd(i+1, j, k, ivy)
              du3(ivy) = w(i+2, j, k, ivy) - w(i+1, j, k, ivy)
              du1d(ivz) = wd(i, j, k, ivz) - wd(i-1, j, k, ivz)
              du1(ivz) = w(i, j, k, ivz) - w(i-1, j, k, ivz)
              du2d(ivz) = wd(i+1, j, k, ivz) - wd(i, j, k, ivz)
              du2(ivz) = w(i+1, j, k, ivz) - w(i, j, k, ivz)
              du3d(ivz) = wd(i+2, j, k, ivz) - wd(i+1, j, k, ivz)
              du3(ivz) = w(i+2, j, k, ivz) - w(i+1, j, k, ivz)
              du1d(irhoe) = pd(i, j, k) - pd(i-1, j, k)
              du1(irhoe) = p(i, j, k) - p(i-1, j, k)
              du2d(irhoe) = pd(i+1, j, k) - pd(i, j, k)
              du2(irhoe) = p(i+1, j, k) - p(i, j, k)
              du3d(irhoe) = pd(i+2, j, k) - pd(i+1, j, k)
              du3(irhoe) = p(i+2, j, k) - p(i+1, j, k)
              if (correctfork) then
                du1d(itu1) = wd(i, j, k, itu1) - wd(i-1, j, k, itu1)
                du1(itu1) = w(i, j, k, itu1) - w(i-1, j, k, itu1)
                du2d(itu1) = wd(i+1, j, k, itu1) - wd(i, j, k, itu1)
                du2(itu1) = w(i+1, j, k, itu1) - w(i, j, k, itu1)
                du3d(itu1) = wd(i+2, j, k, itu1) - wd(i+1, 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_d(du1, du1d, du2, du2d, du3, du3d, &
&                             rotmatrixi, left, leftd, right, rightd)
! add the first order part to the currently stored
! differences, such that the correct state vector
! is stored.
              leftd(irho) = leftd(irho) + wd(i, j, k, irho)
              left(irho) = left(irho) + w(i, j, k, irho)
              leftd(ivx) = leftd(ivx) + wd(i, j, k, ivx)
              left(ivx) = left(ivx) + w(i, j, k, ivx)
              leftd(ivy) = leftd(ivy) + wd(i, j, k, ivy)
              left(ivy) = left(ivy) + w(i, j, k, ivy)
              leftd(ivz) = leftd(ivz) + wd(i, j, k, ivz)
              left(ivz) = left(ivz) + w(i, j, k, ivz)
              leftd(irhoe) = leftd(irhoe) + pd(i, j, k)
              left(irhoe) = left(irhoe) + p(i, j, k)
              rightd(irho) = rightd(irho) + wd(i+1, j, k, irho)
              right(irho) = right(irho) + w(i+1, j, k, irho)
              rightd(ivx) = rightd(ivx) + wd(i+1, j, k, ivx)
              right(ivx) = right(ivx) + w(i+1, j, k, ivx)
              rightd(ivy) = rightd(ivy) + wd(i+1, j, k, ivy)
              right(ivy) = right(ivy) + w(i+1, j, k, ivy)
              rightd(ivz) = rightd(ivz) + wd(i+1, j, k, ivz)
              right(ivz) = right(ivz) + w(i+1, j, k, ivz)
              rightd(irhoe) = rightd(irhoe) + pd(i+1, j, k)
              right(irhoe) = right(irhoe) + p(i+1, j, k)
              if (correctfork) then
                leftd(itu1) = leftd(itu1) + wd(i, j, k, itu1)
                left(itu1) = left(itu1) + w(i, j, k, itu1)
                rightd(itu1) = rightd(itu1) + wd(i+1, 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.
              sxd = sid(i, j, k, 1)
              sx = si(i, j, k, 1)
              syd = sid(i, j, k, 2)
              sy = si(i, j, k, 2)
              szd = sid(i, j, k, 3)
              sz = si(i, j, k, 3)
              por = pori(i, j, k)
              if (addgridvelocities) then
                sfaced = sfaceid(i, j, k)
                sface = sfacei(i, j, k)
              end if
! 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_d(left, leftd, right, rightd, flux, fluxd&
&                         )
! and scatter it to the left and right.
              fwd(i, j, k, irho) = fwd(i, j, k, irho) + fluxd(irho)
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fwd(i, j, k, imx) = fwd(i, j, k, imx) + fluxd(imx)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fwd(i, j, k, imy) = fwd(i, j, k, imy) + fluxd(imy)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fwd(i, j, k, imz) = fwd(i, j, k, imz) + fluxd(imz)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) + fluxd(irhoe)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fwd(i+1, j, k, irho) = fwd(i+1, j, k, irho) - fluxd(irho)
              fw(i+1, j, k, irho) = fw(i+1, j, k, irho) - flux(irho)
              fwd(i+1, j, k, imx) = fwd(i+1, j, k, imx) - fluxd(imx)
              fw(i+1, j, k, imx) = fw(i+1, j, k, imx) - flux(imx)
              fwd(i+1, j, k, imy) = fwd(i+1, j, k, imy) - fluxd(imy)
              fw(i+1, j, k, imy) = fw(i+1, j, k, imy) - flux(imy)
              fwd(i+1, j, k, imz) = fwd(i+1, j, k, imz) - fluxd(imz)
              fw(i+1, j, k, imz) = fw(i+1, j, k, imz) - flux(imz)
              fwd(i+1, j, k, irhoe) = fwd(i+1, j, k, irhoe) - fluxd(&
&               irhoe)
              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.
              du1d(irho) = wd(i, j, k, irho) - wd(i, j-1, k, irho)
              du1(irho) = w(i, j, k, irho) - w(i, j-1, k, irho)
              du2d(irho) = wd(i, j+1, k, irho) - wd(i, j, k, irho)
              du2(irho) = w(i, j+1, k, irho) - w(i, j, k, irho)
              du3d(irho) = wd(i, j+2, k, irho) - wd(i, j+1, k, irho)
              du3(irho) = w(i, j+2, k, irho) - w(i, j+1, k, irho)
              du1d(ivx) = wd(i, j, k, ivx) - wd(i, j-1, k, ivx)
              du1(ivx) = w(i, j, k, ivx) - w(i, j-1, k, ivx)
              du2d(ivx) = wd(i, j+1, k, ivx) - wd(i, j, k, ivx)
              du2(ivx) = w(i, j+1, k, ivx) - w(i, j, k, ivx)
              du3d(ivx) = wd(i, j+2, k, ivx) - wd(i, j+1, k, ivx)
              du3(ivx) = w(i, j+2, k, ivx) - w(i, j+1, k, ivx)
              du1d(ivy) = wd(i, j, k, ivy) - wd(i, j-1, k, ivy)
              du1(ivy) = w(i, j, k, ivy) - w(i, j-1, k, ivy)
              du2d(ivy) = wd(i, j+1, k, ivy) - wd(i, j, k, ivy)
              du2(ivy) = w(i, j+1, k, ivy) - w(i, j, k, ivy)
              du3d(ivy) = wd(i, j+2, k, ivy) - wd(i, j+1, k, ivy)
              du3(ivy) = w(i, j+2, k, ivy) - w(i, j+1, k, ivy)
              du1d(ivz) = wd(i, j, k, ivz) - wd(i, j-1, k, ivz)
              du1(ivz) = w(i, j, k, ivz) - w(i, j-1, k, ivz)
              du2d(ivz) = wd(i, j+1, k, ivz) - wd(i, j, k, ivz)
              du2(ivz) = w(i, j+1, k, ivz) - w(i, j, k, ivz)
              du3d(ivz) = wd(i, j+2, k, ivz) - wd(i, j+1, k, ivz)
              du3(ivz) = w(i, j+2, k, ivz) - w(i, j+1, k, ivz)
              du1d(irhoe) = pd(i, j, k) - pd(i, j-1, k)
              du1(irhoe) = p(i, j, k) - p(i, j-1, k)
              du2d(irhoe) = pd(i, j+1, k) - pd(i, j, k)
              du2(irhoe) = p(i, j+1, k) - p(i, j, k)
              du3d(irhoe) = pd(i, j+2, k) - pd(i, j+1, k)
              du3(irhoe) = p(i, j+2, k) - p(i, j+1, k)
              if (correctfork) then
                du1d(itu1) = wd(i, j, k, itu1) - wd(i, j-1, k, itu1)
                du1(itu1) = w(i, j, k, itu1) - w(i, j-1, k, itu1)
                du2d(itu1) = wd(i, j+1, k, itu1) - wd(i, j, k, itu1)
                du2(itu1) = w(i, j+1, k, itu1) - w(i, j, k, itu1)
                du3d(itu1) = wd(i, j+2, k, itu1) - wd(i, j+1, 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_d(du1, du1d, du2, du2d, du3, du3d, &
&                             rotmatrixj, left, leftd, right, rightd)
! add the first order part to the currently stored
! differences, such that the correct state vector
! is stored.
              leftd(irho) = leftd(irho) + wd(i, j, k, irho)
              left(irho) = left(irho) + w(i, j, k, irho)
              leftd(ivx) = leftd(ivx) + wd(i, j, k, ivx)
              left(ivx) = left(ivx) + w(i, j, k, ivx)
              leftd(ivy) = leftd(ivy) + wd(i, j, k, ivy)
              left(ivy) = left(ivy) + w(i, j, k, ivy)
              leftd(ivz) = leftd(ivz) + wd(i, j, k, ivz)
              left(ivz) = left(ivz) + w(i, j, k, ivz)
              leftd(irhoe) = leftd(irhoe) + pd(i, j, k)
              left(irhoe) = left(irhoe) + p(i, j, k)
              rightd(irho) = rightd(irho) + wd(i, j+1, k, irho)
              right(irho) = right(irho) + w(i, j+1, k, irho)
              rightd(ivx) = rightd(ivx) + wd(i, j+1, k, ivx)
              right(ivx) = right(ivx) + w(i, j+1, k, ivx)
              rightd(ivy) = rightd(ivy) + wd(i, j+1, k, ivy)
              right(ivy) = right(ivy) + w(i, j+1, k, ivy)
              rightd(ivz) = rightd(ivz) + wd(i, j+1, k, ivz)
              right(ivz) = right(ivz) + w(i, j+1, k, ivz)
              rightd(irhoe) = rightd(irhoe) + pd(i, j+1, k)
              right(irhoe) = right(irhoe) + p(i, j+1, k)
              if (correctfork) then
                leftd(itu1) = leftd(itu1) + wd(i, j, k, itu1)
                left(itu1) = left(itu1) + w(i, j, k, itu1)
                rightd(itu1) = rightd(itu1) + wd(i, j+1, 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.
              sxd = sjd(i, j, k, 1)
              sx = sj(i, j, k, 1)
              syd = sjd(i, j, k, 2)
              sy = sj(i, j, k, 2)
              szd = sjd(i, j, k, 3)
              sz = sj(i, j, k, 3)
              por = porj(i, j, k)
              if (addgridvelocities) then
                sfaced = sfacejd(i, j, k)
                sface = sfacej(i, j, k)
              end if
! 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_d(left, leftd, right, rightd, flux, fluxd&
&                         )
! and scatter it to the left and right.
              fwd(i, j, k, irho) = fwd(i, j, k, irho) + fluxd(irho)
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fwd(i, j, k, imx) = fwd(i, j, k, imx) + fluxd(imx)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fwd(i, j, k, imy) = fwd(i, j, k, imy) + fluxd(imy)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fwd(i, j, k, imz) = fwd(i, j, k, imz) + fluxd(imz)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) + fluxd(irhoe)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fwd(i, j+1, k, irho) = fwd(i, j+1, k, irho) - fluxd(irho)
              fw(i, j+1, k, irho) = fw(i, j+1, k, irho) - flux(irho)
              fwd(i, j+1, k, imx) = fwd(i, j+1, k, imx) - fluxd(imx)
              fw(i, j+1, k, imx) = fw(i, j+1, k, imx) - flux(imx)
              fwd(i, j+1, k, imy) = fwd(i, j+1, k, imy) - fluxd(imy)
              fw(i, j+1, k, imy) = fw(i, j+1, k, imy) - flux(imy)
              fwd(i, j+1, k, imz) = fwd(i, j+1, k, imz) - fluxd(imz)
              fw(i, j+1, k, imz) = fw(i, j+1, k, imz) - flux(imz)
              fwd(i, j+1, k, irhoe) = fwd(i, j+1, k, irhoe) - fluxd(&
&               irhoe)
              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.
              du1d(irho) = wd(i, j, k, irho) - wd(i, j, k-1, irho)
              du1(irho) = w(i, j, k, irho) - w(i, j, k-1, irho)
              du2d(irho) = wd(i, j, k+1, irho) - wd(i, j, k, irho)
              du2(irho) = w(i, j, k+1, irho) - w(i, j, k, irho)
              du3d(irho) = wd(i, j, k+2, irho) - wd(i, j, k+1, irho)
              du3(irho) = w(i, j, k+2, irho) - w(i, j, k+1, irho)
              du1d(ivx) = wd(i, j, k, ivx) - wd(i, j, k-1, ivx)
              du1(ivx) = w(i, j, k, ivx) - w(i, j, k-1, ivx)
              du2d(ivx) = wd(i, j, k+1, ivx) - wd(i, j, k, ivx)
              du2(ivx) = w(i, j, k+1, ivx) - w(i, j, k, ivx)
              du3d(ivx) = wd(i, j, k+2, ivx) - wd(i, j, k+1, ivx)
              du3(ivx) = w(i, j, k+2, ivx) - w(i, j, k+1, ivx)
              du1d(ivy) = wd(i, j, k, ivy) - wd(i, j, k-1, ivy)
              du1(ivy) = w(i, j, k, ivy) - w(i, j, k-1, ivy)
              du2d(ivy) = wd(i, j, k+1, ivy) - wd(i, j, k, ivy)
              du2(ivy) = w(i, j, k+1, ivy) - w(i, j, k, ivy)
              du3d(ivy) = wd(i, j, k+2, ivy) - wd(i, j, k+1, ivy)
              du3(ivy) = w(i, j, k+2, ivy) - w(i, j, k+1, ivy)
              du1d(ivz) = wd(i, j, k, ivz) - wd(i, j, k-1, ivz)
              du1(ivz) = w(i, j, k, ivz) - w(i, j, k-1, ivz)
              du2d(ivz) = wd(i, j, k+1, ivz) - wd(i, j, k, ivz)
              du2(ivz) = w(i, j, k+1, ivz) - w(i, j, k, ivz)
              du3d(ivz) = wd(i, j, k+2, ivz) - wd(i, j, k+1, ivz)
              du3(ivz) = w(i, j, k+2, ivz) - w(i, j, k+1, ivz)
              du1d(irhoe) = pd(i, j, k) - pd(i, j, k-1)
              du1(irhoe) = p(i, j, k) - p(i, j, k-1)
              du2d(irhoe) = pd(i, j, k+1) - pd(i, j, k)
              du2(irhoe) = p(i, j, k+1) - p(i, j, k)
              du3d(irhoe) = pd(i, j, k+2) - pd(i, j, k+1)
              du3(irhoe) = p(i, j, k+2) - p(i, j, k+1)
              if (correctfork) then
                du1d(itu1) = wd(i, j, k, itu1) - wd(i, j, k-1, itu1)
                du1(itu1) = w(i, j, k, itu1) - w(i, j, k-1, itu1)
                du2d(itu1) = wd(i, j, k+1, itu1) - wd(i, j, k, itu1)
                du2(itu1) = w(i, j, k+1, itu1) - w(i, j, k, itu1)
                du3d(itu1) = wd(i, j, k+2, itu1) - wd(i, j, k+1, 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_d(du1, du1d, du2, du2d, du3, du3d, &
&                             rotmatrixk, left, leftd, right, rightd)
! add the first order part to the currently stored
! differences, such that the correct state vector
! is stored.
              leftd(irho) = leftd(irho) + wd(i, j, k, irho)
              left(irho) = left(irho) + w(i, j, k, irho)
              leftd(ivx) = leftd(ivx) + wd(i, j, k, ivx)
              left(ivx) = left(ivx) + w(i, j, k, ivx)
              leftd(ivy) = leftd(ivy) + wd(i, j, k, ivy)
              left(ivy) = left(ivy) + w(i, j, k, ivy)
              leftd(ivz) = leftd(ivz) + wd(i, j, k, ivz)
              left(ivz) = left(ivz) + w(i, j, k, ivz)
              leftd(irhoe) = leftd(irhoe) + pd(i, j, k)
              left(irhoe) = left(irhoe) + p(i, j, k)
              rightd(irho) = rightd(irho) + wd(i, j, k+1, irho)
              right(irho) = right(irho) + w(i, j, k+1, irho)
              rightd(ivx) = rightd(ivx) + wd(i, j, k+1, ivx)
              right(ivx) = right(ivx) + w(i, j, k+1, ivx)
              rightd(ivy) = rightd(ivy) + wd(i, j, k+1, ivy)
              right(ivy) = right(ivy) + w(i, j, k+1, ivy)
              rightd(ivz) = rightd(ivz) + wd(i, j, k+1, ivz)
              right(ivz) = right(ivz) + w(i, j, k+1, ivz)
              rightd(irhoe) = rightd(irhoe) + pd(i, j, k+1)
              right(irhoe) = right(irhoe) + p(i, j, k+1)
              if (correctfork) then
                leftd(itu1) = leftd(itu1) + wd(i, j, k, itu1)
                left(itu1) = left(itu1) + w(i, j, k, itu1)
                rightd(itu1) = rightd(itu1) + wd(i, j, k+1, 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.
              sxd = skd(i, j, k, 1)
              sx = sk(i, j, k, 1)
              syd = skd(i, j, k, 2)
              sy = sk(i, j, k, 2)
              szd = skd(i, j, k, 3)
              sz = sk(i, j, k, 3)
              por = pork(i, j, k)
              if (addgridvelocities) then
                sfaced = sfacekd(i, j, k)
                sface = sfacek(i, j, k)
              end if
! 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_d(left, leftd, right, rightd, flux, fluxd&
&                         )
! and scatter it to the left and right.
              fwd(i, j, k, irho) = fwd(i, j, k, irho) + fluxd(irho)
              fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
              fwd(i, j, k, imx) = fwd(i, j, k, imx) + fluxd(imx)
              fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
              fwd(i, j, k, imy) = fwd(i, j, k, imy) + fluxd(imy)
              fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
              fwd(i, j, k, imz) = fwd(i, j, k, imz) + fluxd(imz)
              fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
              fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) + fluxd(irhoe)
              fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
              fwd(i, j, k+1, irho) = fwd(i, j, k+1, irho) - fluxd(irho)
              fw(i, j, k+1, irho) = fw(i, j, k+1, irho) - flux(irho)
              fwd(i, j, k+1, imx) = fwd(i, j, k+1, imx) - fluxd(imx)
              fw(i, j, k+1, imx) = fw(i, j, k+1, imx) - flux(imx)
              fwd(i, j, k+1, imy) = fwd(i, j, k+1, imy) - fluxd(imy)
              fw(i, j, k+1, imy) = fw(i, j, k+1, imy) - flux(imy)
              fwd(i, j, k+1, imz) = fwd(i, j, k+1, imz) - fluxd(imz)
              fw(i, j, k+1, imz) = fw(i, j, k+1, imz) - flux(imz)
              fwd(i, j, k+1, irhoe) = fwd(i, j, k+1, irhoe) - fluxd(&
&               irhoe)
              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
!  differentiation of leftrightstate in forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: left right du1 du2 du3
!   with respect to varying inputs: left right du1 du2 du3
!      ==================================================================
    subroutine leftrightstate_d(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(:), intent(out) :: left, right
      real(kind=realtype), dimension(:), intent(out) :: 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) :: temp0
! 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.
        dvxd = du1d(ivx)
        dvx = du1(ivx)
        dvyd = du1d(ivy)
        dvy = du1(ivy)
        dvzd = du1d(ivz)
        dvz = du1(ivz)
        du1d(ivx) = rot(1, 1)*dvxd + rot(1, 2)*dvyd + rot(1, 3)*dvzd
        du1(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du1d(ivy) = rot(2, 1)*dvxd + rot(2, 2)*dvyd + rot(2, 3)*dvzd
        du1(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du1d(ivz) = rot(3, 1)*dvxd + rot(3, 2)*dvyd + rot(3, 3)*dvzd
        du1(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
        dvxd = du2d(ivx)
        dvx = du2(ivx)
        dvyd = du2d(ivy)
        dvy = du2(ivy)
        dvzd = du2d(ivz)
        dvz = du2(ivz)
        du2d(ivx) = rot(1, 1)*dvxd + rot(1, 2)*dvyd + rot(1, 3)*dvzd
        du2(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du2d(ivy) = rot(2, 1)*dvxd + rot(2, 2)*dvyd + rot(2, 3)*dvzd
        du2(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du2d(ivz) = rot(3, 1)*dvxd + rot(3, 2)*dvyd + rot(3, 3)*dvzd
        du2(ivz) = rot(3, 1)*dvx + rot(3, 2)*dvy + rot(3, 3)*dvz
        dvxd = du3d(ivx)
        dvx = du3(ivx)
        dvyd = du3d(ivy)
        dvy = du3(ivy)
        dvzd = du3d(ivz)
        dvz = du3(ivz)
        du3d(ivx) = rot(1, 1)*dvxd + rot(1, 2)*dvyd + rot(1, 3)*dvzd
        du3(ivx) = rot(1, 1)*dvx + rot(1, 2)*dvy + rot(1, 3)*dvz
        du3d(ivy) = rot(2, 1)*dvxd + rot(2, 2)*dvyd + rot(2, 3)*dvzd
        du3(ivy) = rot(2, 1)*dvx + rot(2, 2)*dvy + rot(2, 3)*dvz
        du3d(ivz) = rot(3, 1)*dvxd + rot(3, 2)*dvyd + rot(3, 3)*dvzd
        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
          leftd(l) = omk*du1d(l) + opk*du2d(l)
          left(l) = omk*du1(l) + opk*du2(l)
          rightd(l) = -(omk*du3d(l)) - opk*du2d(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
            x1d = du2d(l)
            x1 = du2(l)
          else
            x1d = -du2d(l)
            x1 = -du2(l)
          end if
          if (x1 .lt. epslim) then
            max2 = epslim
            max2d = 0.0_8
          else
            max2d = x1d
            max2 = x1
          end if
! compute the limiter argument rl1, rl2, rr1 and rr2.
! note the cut off to 0.0.
          temp = one/sign(max2, du2(l))
          tmpd = -(temp*sign(1.d0, max2*du2(l))*max2d/sign(max2, du2(l))&
&           )
          tmp = temp
          if (du1(l) .ge. 0.) then
            x3d = du1d(l)
            x3 = du1(l)
          else
            x3d = -du1d(l)
            x3 = -du1(l)
          end if
          if (x3 .lt. epslim) then
            max4 = epslim
            max4d = 0.0_8
          else
            max4d = x3d
            max4 = x3
          end if
          temp = sign(max4, du1(l))
          temp0 = du2(l)/temp
          y1d = (du2d(l)-temp0*sign(1.d0, max4*du1(l))*max4d)/temp
          y1 = temp0
          if (zero .lt. y1) then
            rl1d = y1d
            rl1 = y1
          else
            rl1 = zero
            rl1d = 0.0_8
          end if
          if (zero .lt. du1(l)*tmp) then
            rl2d = tmp*du1d(l) + du1(l)*tmpd
            rl2 = du1(l)*tmp
          else
            rl2 = zero
            rl2d = 0.0_8
          end if
          if (zero .lt. du3(l)*tmp) then
            rr1d = tmp*du3d(l) + du3(l)*tmpd
            rr1 = du3(l)*tmp
          else
            rr1 = zero
            rr1d = 0.0_8
          end if
          if (du3(l) .ge. 0.) then
            x4d = du3d(l)
            x4 = du3(l)
          else
            x4d = -du3d(l)
            x4 = -du3(l)
          end if
          if (x4 .lt. epslim) then
            max5 = epslim
            max5d = 0.0_8
          else
            max5d = x4d
            max5 = x4
          end if
          temp0 = sign(max5, du3(l))
          temp = du2(l)/temp0
          y2d = (du2d(l)-temp*sign(1.d0, max5*du3(l))*max5d)/temp0
          y2 = temp
          if (zero .lt. y2) then
            rr2d = y2d
            rr2 = y2
          else
            rr2 = zero
            rr2d = 0.0_8
          end if
! compute the corresponding limiter values.
          temp0 = rl1*(one+rl1)/(one+rl1*rl1)
          rl1d = (one+2*rl1-temp0*2*rl1)*rl1d/(one+rl1**2)
          rl1 = temp0
          temp0 = rl2*(one+rl2)/(one+rl2*rl2)
          rl2d = (one+2*rl2-temp0*2*rl2)*rl2d/(one+rl2**2)
          rl2 = temp0
          temp0 = rr1*(one+rr1)/(one+rr1*rr1)
          rr1d = (one+2*rr1-temp0*2*rr1)*rr1d/(one+rr1**2)
          rr1 = temp0
          temp0 = rr2*(one+rr2)/(one+rr2*rr2)
          rr2d = (one+2*rr2-temp0*2*rr2)*rr2d/(one+rr2**2)
          rr2 = temp0
! compute the nonlinear corrections to the first order
! scheme.
          leftd(l) = omk*(du1(l)*rl1d+rl1*du1d(l)) + opk*(du2(l)*rl2d+&
&           rl2*du2d(l))
          left(l) = omk*rl1*du1(l) + opk*rl2*du2(l)
          rightd(l) = -(opk*(du2(l)*rr1d+rr1*du2d(l))) - omk*(du3(l)*&
&           rr2d+rr2*du3d(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
            x2d = du2d(l)
            x2 = du2(l)
          else
            x2d = -du2d(l)
            x2 = -du2(l)
          end if
          if (x2 .lt. epslim) then
            max3 = epslim
            max3d = 0.0_8
          else
            max3d = x2d
            max3 = x2
          end if
! compute the limiter argument rl1, rl2, rr1 and rr2.
! note the cut off to 0.0.
          temp0 = one/sign(max3, du2(l))
          tmpd = -(temp0*sign(1.d0, max3*du2(l))*max3d/sign(max3, du2(l)&
&           ))
          tmp = temp0
          if (du1(l) .ge. 0.) then
            x5d = du1d(l)
            x5 = du1(l)
          else
            x5d = -du1d(l)
            x5 = -du1(l)
          end if
          if (x5 .lt. epslim) then
            max6 = epslim
            max6d = 0.0_8
          else
            max6d = x5d
            max6 = x5
          end if
          temp0 = sign(max6, du1(l))
          temp = du2(l)/temp0
          y3d = (du2d(l)-temp*sign(1.d0, max6*du1(l))*max6d)/temp0
          y3 = temp
          if (zero .lt. y3) then
            rl1d = y3d
            rl1 = y3
          else
            rl1 = zero
            rl1d = 0.0_8
          end if
          if (zero .lt. du1(l)*tmp) then
            rl2d = tmp*du1d(l) + du1(l)*tmpd
            rl2 = du1(l)*tmp
          else
            rl2 = zero
            rl2d = 0.0_8
          end if
          if (zero .lt. du3(l)*tmp) then
            rr1d = tmp*du3d(l) + du3(l)*tmpd
            rr1 = du3(l)*tmp
          else
            rr1 = zero
            rr1d = 0.0_8
          end if
          if (du3(l) .ge. 0.) then
            x6d = du3d(l)
            x6 = du3(l)
          else
            x6d = -du3d(l)
            x6 = -du3(l)
          end if
          if (x6 .lt. epslim) then
            max7 = epslim
            max7d = 0.0_8
          else
            max7d = x6d
            max7 = x6
          end if
          temp0 = sign(max7, du3(l))
          temp = du2(l)/temp0
          y4d = (du2d(l)-temp*sign(1.d0, max7*du3(l))*max7d)/temp0
          y4 = temp
          if (zero .lt. y4) then
            rr2d = y4d
            rr2 = y4
          else
            rr2 = zero
            rr2d = 0.0_8
          end if
          if (one .gt. factminmod*rl1) then
            rl1d = factminmod*rl1d
            rl1 = factminmod*rl1
          else
            rl1 = one
            rl1d = 0.0_8
          end if
          if (one .gt. factminmod*rl2) then
            rl2d = factminmod*rl2d
            rl2 = factminmod*rl2
          else
            rl2 = one
            rl2d = 0.0_8
          end if
          if (one .gt. factminmod*rr1) then
            rr1d = factminmod*rr1d
            rr1 = factminmod*rr1
          else
            rr1 = one
            rr1d = 0.0_8
          end if
          if (one .gt. factminmod*rr2) then
            rr2d = factminmod*rr2d
            rr2 = factminmod*rr2
          else
            rr2 = one
            rr2d = 0.0_8
          end if
! compute the nonlinear corrections to the first order
! scheme.
          leftd(l) = omk*(du1(l)*rl1d+rl1*du1d(l)) + opk*(du2(l)*rl2d+&
&           rl2*du2d(l))
          left(l) = omk*rl1*du1(l) + opk*rl2*du2(l)
          rightd(l) = -(opk*(du2(l)*rr1d+rr1*du2d(l))) - omk*(du3(l)*&
&           rr2d+rr2*du3d(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
        leftd(itu1) = 0.0_8
        left(itu1) = zero
        rightd(itu1) = 0.0_8
        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.
        dvxd = leftd(ivx)
        dvx = left(ivx)
        dvyd = leftd(ivy)
        dvy = left(ivy)
        dvzd = leftd(ivz)
        dvz = left(ivz)
        leftd(ivx) = rot(1, 1)*dvxd + rot(2, 1)*dvyd + rot(3, 1)*dvzd
        left(ivx) = rot(1, 1)*dvx + rot(2, 1)*dvy + rot(3, 1)*dvz
        leftd(ivy) = rot(1, 2)*dvxd + rot(2, 2)*dvyd + rot(3, 2)*dvzd
        left(ivy) = rot(1, 2)*dvx + rot(2, 2)*dvy + rot(3, 2)*dvz
        leftd(ivz) = rot(1, 3)*dvxd + rot(2, 3)*dvyd + rot(3, 3)*dvzd
        left(ivz) = rot(1, 3)*dvx + rot(2, 3)*dvy + rot(3, 3)*dvz
! right state.
        dvxd = rightd(ivx)
        dvx = right(ivx)
        dvyd = rightd(ivy)
        dvy = right(ivy)
        dvzd = rightd(ivz)
        dvz = right(ivz)
        rightd(ivx) = rot(1, 1)*dvxd + rot(2, 1)*dvyd + rot(3, 1)*dvzd
        right(ivx) = rot(1, 1)*dvx + rot(2, 1)*dvy + rot(3, 1)*dvz
        rightd(ivy) = rot(1, 2)*dvxd + rot(2, 2)*dvyd + rot(3, 2)*dvzd
        right(ivy) = rot(1, 2)*dvx + rot(2, 2)*dvy + rot(3, 2)*dvz
        rightd(ivz) = rot(1, 3)*dvxd + rot(2, 3)*dvyd + rot(3, 3)*dvzd
        right(ivz) = rot(1, 3)*dvx + rot(2, 3)*dvy + rot(3, 3)*dvz
      end if
    end subroutine leftrightstate_d
 
!      ==================================================================
    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 forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: flux
!   with respect to varying inputs: sface sx sy sz flux left right
!        ================================================================
    subroutine riemannflux_d(left, leftd, right, rightd, flux, fluxd)
      implicit none
!
!        subroutine arguments.
!
      real(kind=realtype), dimension(*), intent(in) :: left, right
      real(kind=realtype), dimension(*), intent(in) :: leftd, rightd
      real(kind=realtype), dimension(*), intent(out) :: flux
      real(kind=realtype), dimension(*), intent(out) :: 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) :: arg1
      real(kind=realtype) :: arg1d
      real(kind=realtype) :: result1
      real(kind=realtype) :: result1d
      real(kind=realtype) :: arg2
      real(kind=realtype) :: arg2d
      real(kind=realtype) :: result2
      real(kind=realtype) :: result2d
      real(kind=realtype) :: temp
      real(kind=realtype) :: temp0
      real(kind=realtype) :: temp1
! 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.
          temp = sqrt(left(irho))
          if (left(irho) .eq. 0.0_8) then
            z1ld = 0.0_8
          else
            z1ld = leftd(irho)/(2.0*temp)
          end if
          z1l = temp
          temp = sqrt(right(irho))
          if (right(irho) .eq. 0.0_8) then
            z1rd = 0.0_8
          else
            z1rd = rightd(irho)/(2.0*temp)
          end if
          z1r = temp
          temp = one/(z1l+z1r)
          tmpd = -(temp*(z1ld+z1rd)/(z1l+z1r))
          tmp = temp
! 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.
            ktmpd = 0.0_8
            ktmpd(1) = leftd(itu1)
            ktmp(1) = left(itu1)
            ktmpd(2) = rightd(itu1)
            ktmp(2) = right(itu1)
! store the difference of the turbulent kinetic energy
! per unit volume, i.e. the conserved variable.
            drkd = right(itu1)*rightd(irho) + right(irho)*rightd(itu1) -&
&             left(itu1)*leftd(irho) - left(irho)*leftd(itu1)
            drk = right(irho)*right(itu1) - left(irho)*left(itu1)
! compute the average turbulent energy per unit mass
! using roe averages.
            temp = z1l*left(itu1) + z1r*right(itu1)
            kavgd = temp*tmpd + tmp*(left(itu1)*z1ld+z1l*leftd(itu1)+&
&             right(itu1)*z1rd+z1r*rightd(itu1))
            kavg = tmp*temp
          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
            ktmpd = 0.0_8
            kavgd = 0.0_8
            drkd = 0.0_8
          end if
! compute the total energy of the left and right state.
          etld = 0.0_8
          call etot_d(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)
          etrd = 0.0_8
          call etot_d(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)
! compute the difference of the conservative mean
! flow variables.
          drd = rightd(irho) - leftd(irho)
          dr = right(irho) - left(irho)
          drud = right(ivx)*rightd(irho) + right(irho)*rightd(ivx) - &
&           left(ivx)*leftd(irho) - left(irho)*leftd(ivx)
          dru = right(irho)*right(ivx) - left(irho)*left(ivx)
          drvd = right(ivy)*rightd(irho) + right(irho)*rightd(ivy) - &
&           left(ivy)*leftd(irho) - left(irho)*leftd(ivy)
          drv = right(irho)*right(ivy) - left(irho)*left(ivy)
          drwd = right(ivz)*rightd(irho) + right(irho)*rightd(ivz) - &
&           left(ivz)*leftd(irho) - left(irho)*leftd(ivz)
          drw = right(irho)*right(ivz) - left(irho)*left(ivz)
          dred = etrd - etld
          dre = etr - etl
! compute the roe average variables, which can be
! computed directly from the average roe vector.
          ravg = fourth*(z1r+z1l)**2
          temp = z1l*left(ivx) + z1r*right(ivx)
          uavgd = temp*tmpd + tmp*(left(ivx)*z1ld+z1l*leftd(ivx)+right(&
&           ivx)*z1rd+z1r*rightd(ivx))
          uavg = tmp*temp
          temp = z1l*left(ivy) + z1r*right(ivy)
          vavgd = temp*tmpd + tmp*(left(ivy)*z1ld+z1l*leftd(ivy)+right(&
&           ivy)*z1rd+z1r*rightd(ivy))
          vavg = tmp*temp
          temp = z1l*left(ivz) + z1r*right(ivz)
          wavgd = temp*tmpd + tmp*(left(ivz)*z1ld+z1l*leftd(ivz)+right(&
&           ivz)*z1rd+z1r*rightd(ivz))
          wavg = tmp*temp
          temp = (etr+right(irhoe))/z1r
          temp0 = (etl+left(irhoe))/z1l
          temp1 = temp0 + temp
          havgd = temp1*tmpd + tmp*((etld+leftd(irhoe)-temp0*z1ld)/z1l+(&
&           etrd+rightd(irhoe)-temp*z1rd)/z1r)
          havg = tmp*temp1
! compute the unit vector and store the area of the
! normal. also compute the unit normal velocity of the face.
          arg1d = 2*sx*sxd + 2*sy*syd + 2*sz*szd
          arg1 = sx**2 + sy**2 + sz**2
          temp1 = sqrt(arg1)
          if (arg1 .eq. 0.0_8) then
            aread = 0.0_8
          else
            aread = arg1d/(2.0*temp1)
          end if
          area = temp1
          if (1.e-25_realtype .lt. area) then
            max2d = aread
            max2 = area
          else
            max2 = 1.e-25_realtype
            max2d = 0.0_8
          end if
          tmpd = -(one*max2d/max2**2)
          tmp = one/max2
          sxd = tmp*sxd + sx*tmpd
          sx = sx*tmp
          syd = tmp*syd + sy*tmpd
          sy = sy*tmp
          szd = tmp*szd + sz*tmpd
          sz = sz*tmp
          rfaced = tmp*sfaced + sface*tmpd
          rface = sface*tmp
! compute some dependent variables at the roe
! average state.
          alphaavgd = half*(2*uavg*uavgd+2*vavg*vavgd+2*wavg*wavgd)
          alphaavg = half*(uavg**2+vavg**2+wavg**2)
          if (gm1*(havg-alphaavg) - gm53*kavg .ge. 0.) then
            a2avgd = gm1*(havgd-alphaavgd) - gm53*kavgd
            a2avg = gm1*(havg-alphaavg) - gm53*kavg
          else
            a2avgd = gm53*kavgd - gm1*(havgd-alphaavgd)
            a2avg = -(gm1*(havg-alphaavg)-gm53*kavg)
          end if
          temp1 = sqrt(a2avg)
          if (a2avg .eq. 0.0_8) then
            aavgd = 0.0_8
          else
            aavgd = a2avgd/(2.0*temp1)
          end if
          aavg = temp1
          unavgd = sx*uavgd + uavg*sxd + sy*vavgd + vavg*syd + sz*wavgd &
&           + wavg*szd
          unavg = uavg*sx + vavg*sy + wavg*sz
          ovaavgd = -(one*aavgd/aavg**2)
          ovaavg = one/aavg
          ova2avgd = -(one*a2avgd/a2avg**2)
          ova2avg = one/a2avg
! set for a boundary the normal velocity to rface, the
! normal velocity of the boundary.
          if (por .eq. boundflux) then
            unavgd = rfaced
            unavg = rface
          end if
          x1d = sx*(leftd(ivx)-rightd(ivx)) + (left(ivx)-right(ivx))*sxd&
&           + sy*(leftd(ivy)-rightd(ivy)) + (left(ivy)-right(ivy))*syd +&
&           sz*(leftd(ivz)-rightd(ivz)) + (left(ivz)-right(ivz))*szd
          x1 = (left(ivx)-right(ivx))*sx + (left(ivy)-right(ivy))*sy + (&
&           left(ivz)-right(ivz))*sz
          if (x1 .ge. 0.) then
            abs1d = x1d
            abs1 = x1
          else
            abs1d = -x1d
            abs1 = -x1
          end if
          temp1 = left(irhoe)/left(irho)
          arg1d = gammaface*(leftd(irhoe)-temp1*leftd(irho))/left(irho)
          arg1 = gammaface*temp1
          temp1 = sqrt(arg1)
          if (arg1 .eq. 0.0_8) then
            result1d = 0.0_8
          else
            result1d = arg1d/(2.0*temp1)
          end if
          result1 = temp1
          temp1 = right(irhoe)/right(irho)
          arg2d = gammaface*(rightd(irhoe)-temp1*rightd(irho))/right(&
&           irho)
          arg2 = gammaface*temp1
          temp1 = sqrt(arg2)
          if (arg2 .eq. 0.0_8) then
            result2d = 0.0_8
          else
            result2d = arg2d/(2.0*temp1)
          end if
          result2 = temp1
          x2d = result1d - result2d
          x2 = result1 - result2
          if (x2 .ge. 0.) then
            abs2d = x2d
            abs2 = x2
          else
            abs2d = -x2d
            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.
          etad = half*(abs1d+abs2d)
          eta = half*(abs1+abs2)
          if (unavg - rface + aavg .ge. 0.) then
            lam1d = unavgd - rfaced + aavgd
            lam1 = unavg - rface + aavg
          else
            lam1d = rfaced - unavgd - aavgd
            lam1 = -(unavg-rface+aavg)
          end if
          if (unavg - rface - aavg .ge. 0.) then
            lam2d = unavgd - rfaced - aavgd
            lam2 = unavg - rface - aavg
          else
            lam2d = rfaced - unavgd + aavgd
            lam2 = -(unavg-rface-aavg)
          end if
          if (unavg - rface .ge. 0.) then
            lam3d = unavgd - rfaced
            lam3 = unavg - rface
          else
            lam3d = rfaced - unavgd
            lam3 = -(unavg-rface)
          end if
! apply the entropy correction to the eigenvalues.
          tmp = two*eta
          if (lam1 .lt. tmp) then
            temp1 = lam1*lam1/eta
            lam1d = etad + fourth*(2*lam1*lam1d-temp1*etad)/eta
            lam1 = eta + fourth*temp1
          end if
          if (lam2 .lt. tmp) then
            temp1 = lam2*lam2/eta
            lam2d = etad + fourth*(2*lam2*lam2d-temp1*etad)/eta
            lam2 = eta + fourth*temp1
          end if
          if (lam3 .lt. tmp) then
            temp1 = lam3*lam3/eta
            lam3d = etad + fourth*(2*lam3*lam3d-temp1*etad)/eta
            lam3 = eta + fourth*temp1
          end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
          lam1d = area*lam1d + lam1*aread
          lam1 = lam1*area
          lam2d = area*lam2d + lam2*aread
          lam2 = lam2*area
          lam3d = area*lam3d + lam3*aread
          lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
          abv1d = half*(lam1d+lam2d)
          abv1 = half*(lam1+lam2)
          abv2d = half*(lam1d-lam2d)
          abv2 = half*(lam1-lam2)
          abv3d = abv1d - lam3d
          abv3 = abv1 - lam3
          abv4d = gm1*(dr*alphaavgd+alphaavg*drd-dru*uavgd-uavg*drud-drv&
&           *vavgd-vavg*drvd+dred-drw*wavgd-wavg*drwd) - gm53*drkd
          abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - gm53&
&           *drk
          abv5d = dru*sxd + sx*drud + drv*syd + sy*drvd + drw*szd + sz*&
&           drwd - dr*unavgd - unavg*drd
          abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
          abv6d = ova2avg*(abv4*abv3d+abv3*abv4d) + abv3*abv4*ova2avgd +&
&           ovaavg*(abv5*abv2d+abv2*abv5d) + abv2*abv5*ovaavgd
          abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
          abv7d = ovaavg*(abv4*abv2d+abv2*abv4d) + abv2*abv4*ovaavgd + &
&           abv5*abv3d + abv3*abv5d
          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.
          fluxd(irho) = -(porflux*(dr*lam3d+lam3*drd+abv6d))
          flux(irho) = -(porflux*(lam3*dr+abv6))
          fluxd(imx) = -(porflux*(dru*lam3d+lam3*drud+abv6*uavgd+uavg*&
&           abv6d+abv7*sxd+sx*abv7d))
          flux(imx) = -(porflux*(lam3*dru+uavg*abv6+sx*abv7))
          fluxd(imy) = -(porflux*(drv*lam3d+lam3*drvd+abv6*vavgd+vavg*&
&           abv6d+abv7*syd+sy*abv7d))
          flux(imy) = -(porflux*(lam3*drv+vavg*abv6+sy*abv7))
          fluxd(imz) = -(porflux*(drw*lam3d+lam3*drwd+abv6*wavgd+wavg*&
&           abv6d+abv7*szd+sz*abv7d))
          flux(imz) = -(porflux*(lam3*drw+wavg*abv6+sz*abv7))
          fluxd(irhoe) = -(porflux*(dre*lam3d+lam3*dred+abv6*havgd+havg*&
&           abv6d+abv7*unavgd+unavg*abv7d))
          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_d
 
!        ================================================================
    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
      real(kind=realtype) :: arg1
      real(kind=realtype) :: result1
      real(kind=realtype) :: arg2
      real(kind=realtype) :: result2
! 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.
          arg1 = sx**2 + sy**2 + sz**2
          area = sqrt(arg1)
          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
          arg1 = gammaface*left(irhoe)/left(irho)
          result1 = sqrt(arg1)
          arg2 = gammaface*right(irhoe)/right(irho)
          result2 = sqrt(arg2)
          x2 = result1 - result2
          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_d
 
  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_d, only : getcorrectfork, terminate
    use flowutils_d, 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
      real(kind=realtype) :: arg1
      real(kind=realtype) :: result1
      real(kind=realtype) :: arg2
      real(kind=realtype) :: result2
! 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.
          arg1 = sx**2 + sy**2 + sz**2
          area = sqrt(arg1)
          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
          arg1 = gammaface*left(irhoe)/left(irho)
          result1 = sqrt(arg1)
          arg2 = gammaface*right(irhoe)/right(irho)
          result2 = sqrt(arg2)
          x2 = result1 - result2
          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 forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: *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: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-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_d()
!
!       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 sqrt
    intrinsic max
    real(kind=realtype) :: abs0
    real(kind=realtype) :: arg1
    real(kind=realtype) :: arg1d
    real(kind=realtype) :: result1
    real(kind=realtype) :: result1d
    real(kind=realtype) :: temp
    real(kind=realtype) :: temp0
    real(kind=realtype) :: temp1
    real(kind=realtype) :: temp2
    real(kind=realtype) :: temp3
    real(kind=realtype) :: temp4
    real(kind=realtype) :: temp5
    real(kind=realtype) :: temp6
    real(kind=realtype) :: temp7
! 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
!
!         viscous fluxes in the k-direction.
!
      mue = zero
      mued = 0.0_8
      do k=1,kl
        do j=2,jl
          do i=2,il
! 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.
            muld = por*(rlvd(i, j, k)+rlvd(i, j, k+1))
            mul = por*(rlv(i, j, k)+rlv(i, j, k+1))
            if (eddymodel) then
              mued = por*(revd(i, j, k)+revd(i, j, k+1))
              mue = por*(rev(i, j, k)+rev(i, j, k+1))
            end if
            mutd = muld + mued
            mut = mul + mue
            gm1 = half*(gamma(i, j, k)+gamma(i, j, k+1)) - one
            factlamheat = one/(prandtl*gm1)
            factturbheat = one/(prandtlturb*gm1)
            heatcoefd = factlamheat*muld + factturbheat*mued
            heatcoef = mul*factlamheat + mue*factturbheat
! compute the gradients at the face by averaging the four
! nodal values.
            u_xd = fourth*(uxd(i-1, j-1, k)+uxd(i, j-1, k)+uxd(i-1, j, k&
&             )+uxd(i, j, k))
            u_x = fourth*(ux(i-1, j-1, k)+ux(i, j-1, k)+ux(i-1, j, k)+ux&
&             (i, j, k))
            u_yd = fourth*(uyd(i-1, j-1, k)+uyd(i, j-1, k)+uyd(i-1, j, k&
&             )+uyd(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_zd = fourth*(uzd(i-1, j-1, k)+uzd(i, j-1, k)+uzd(i-1, j, k&
&             )+uzd(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_xd = fourth*(vxd(i-1, j-1, k)+vxd(i, j-1, k)+vxd(i-1, j, k&
&             )+vxd(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_yd = fourth*(vyd(i-1, j-1, k)+vyd(i, j-1, k)+vyd(i-1, j, k&
&             )+vyd(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_zd = fourth*(vzd(i-1, j-1, k)+vzd(i, j-1, k)+vzd(i-1, j, k&
&             )+vzd(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_xd = fourth*(wxd(i-1, j-1, k)+wxd(i, j-1, k)+wxd(i-1, j, k&
&             )+wxd(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_yd = fourth*(wyd(i-1, j-1, k)+wyd(i, j-1, k)+wyd(i-1, j, k&
&             )+wyd(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_zd = fourth*(wzd(i-1, j-1, k)+wzd(i, j-1, k)+wzd(i-1, j, k&
&             )+wzd(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_xd = fourth*(qxd(i-1, j-1, k)+qxd(i, j-1, k)+qxd(i-1, j, k&
&             )+qxd(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_yd = fourth*(qyd(i-1, j-1, k)+qyd(i, j-1, k)+qyd(i-1, j, k&
&             )+qyd(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_zd = fourth*(qzd(i-1, j-1, k)+qzd(i, j-1, k)+qzd(i-1, j, k&
&             )+qzd(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.
            ssxd = eighth*(xd(i-1, j-1, k+1, 1)-xd(i-1, j-1, k-1, 1)+xd(&
&             i-1, j, k+1, 1)-xd(i-1, j, k-1, 1)+xd(i, j-1, k+1, 1)-xd(i&
&             , j-1, k-1, 1)+xd(i, j, k+1, 1)-xd(i, j, k-1, 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))
            ssyd = eighth*(xd(i-1, j-1, k+1, 2)-xd(i-1, j-1, k-1, 2)+xd(&
&             i-1, j, k+1, 2)-xd(i-1, j, k-1, 2)+xd(i, j-1, k+1, 2)-xd(i&
&             , j-1, k-1, 2)+xd(i, j, k+1, 2)-xd(i, j, k-1, 2))
            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))
            sszd = eighth*(xd(i-1, j-1, k+1, 3)-xd(i-1, j-1, k-1, 3)+xd(&
&             i-1, j, k+1, 3)-xd(i-1, j, k-1, 3)+xd(i, j-1, k+1, 3)-xd(i&
&             , j-1, k-1, 3)+xd(i, j, k+1, 3)-xd(i, j, k-1, 3))
            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.
            arg1d = 2*ssx*ssxd + 2*ssy*ssyd + 2*ssz*sszd
            arg1 = ssx*ssx + ssy*ssy + ssz*ssz
            temp = sqrt(arg1)
            if (arg1 .eq. 0.0_8) then
              result1d = 0.0_8
            else
              result1d = arg1d/(2.0*temp)
            end if
            result1 = temp
            ssd = -(one*result1d/result1**2)
            ss = one/result1
            ssxd = ssx*ssd + ss*ssxd
            ssx = ss*ssx
            ssyd = ssy*ssd + ss*ssyd
            ssy = ss*ssy
            sszd = ssz*ssd + ss*sszd
            ssz = ss*ssz
! correct the gradients.
            temp = w(i, j, k+1, ivx) - w(i, j, k, ivx)
            corrd = ssx*u_xd + u_x*ssxd + ssy*u_yd + u_y*ssyd + ssz*u_zd&
&             + u_z*sszd - ss*(wd(i, j, k+1, ivx)-wd(i, j, k, ivx)) - &
&             temp*ssd
            corr = u_x*ssx + u_y*ssy + u_z*ssz - temp*ss
            u_xd = u_xd - ssx*corrd - corr*ssxd
            u_x = u_x - corr*ssx
            u_yd = u_yd - ssy*corrd - corr*ssyd
            u_y = u_y - corr*ssy
            u_zd = u_zd - ssz*corrd - corr*sszd
            u_z = u_z - corr*ssz
            temp = w(i, j, k+1, ivy) - w(i, j, k, ivy)
            corrd = ssx*v_xd + v_x*ssxd + ssy*v_yd + v_y*ssyd + ssz*v_zd&
&             + v_z*sszd - ss*(wd(i, j, k+1, ivy)-wd(i, j, k, ivy)) - &
&             temp*ssd
            corr = v_x*ssx + v_y*ssy + v_z*ssz - temp*ss
            v_xd = v_xd - ssx*corrd - corr*ssxd
            v_x = v_x - corr*ssx
            v_yd = v_yd - ssy*corrd - corr*ssyd
            v_y = v_y - corr*ssy
            v_zd = v_zd - ssz*corrd - corr*sszd
            v_z = v_z - corr*ssz
            temp = w(i, j, k+1, ivz) - w(i, j, k, ivz)
            corrd = ssx*w_xd + w_x*ssxd + ssy*w_yd + w_y*ssyd + ssz*w_zd&
&             + w_z*sszd - ss*(wd(i, j, k+1, ivz)-wd(i, j, k, ivz)) - &
&             temp*ssd
            corr = w_x*ssx + w_y*ssy + w_z*ssz - temp*ss
            w_xd = w_xd - ssx*corrd - corr*ssxd
            w_x = w_x - corr*ssx
            w_yd = w_yd - ssy*corrd - corr*ssyd
            w_y = w_y - corr*ssy
            w_zd = w_zd - ssz*corrd - corr*sszd
            w_z = w_z - corr*ssz
            temp = aa(i, j, k+1) - aa(i, j, k)
            corrd = ssx*q_xd + q_x*ssxd + ssy*q_yd + q_y*ssyd + ssz*q_zd&
&             + q_z*sszd + ss*(aad(i, j, k+1)-aad(i, j, k)) + temp*ssd
            corr = q_x*ssx + q_y*ssy + q_z*ssz + temp*ss
            q_xd = q_xd - ssx*corrd - corr*ssxd
            q_x = q_x - corr*ssx
            q_yd = q_yd - ssy*corrd - corr*ssyd
            q_y = q_y - corr*ssy
            q_zd = q_zd - ssz*corrd - corr*sszd
            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.
            fracdivd = twothird*(u_xd+v_yd+w_zd)
            fracdiv = twothird*(u_x+v_y+w_z)
            tauxxsd = two*u_xd - fracdivd
            tauxxs = two*u_x - fracdiv
            tauyysd = two*v_yd - fracdivd
            tauyys = two*v_y - fracdiv
            tauzzsd = two*w_zd - fracdivd
            tauzzs = two*w_z - fracdiv
            tauxysd = u_yd + v_xd
            tauxys = u_y + v_x
            tauxzsd = u_zd + w_xd
            tauxzs = u_z + w_x
            tauyzsd = v_zd + w_yd
            tauyzs = v_z + w_y
            q_xd = q_x*heatcoefd + heatcoef*q_xd
            q_x = heatcoef*q_x
            q_yd = q_y*heatcoefd + heatcoef*q_yd
            q_y = heatcoef*q_y
            q_zd = q_z*heatcoefd + heatcoef*q_zd
            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
              arg1d = 2*u_x*u_xd + 2*u_y*u_yd + 2*u_z*u_zd + 2*v_x*v_xd &
&               + 2*v_y*v_yd + 2*v_z*v_zd + 2*w_x*w_xd + 2*w_y*w_yd + 2*&
&               w_z*w_zd
              arg1 = 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
              temp = sqrt(arg1)
              if (arg1 .eq. 0.0_8) then
                dend = 0.0_8
              else
                dend = arg1d/(2.0*temp)
              end if
              den = temp
              if (den .lt. xminn) then
                den = xminn
                dend = 0.0_8
              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.
              factd = ccr1*(mued-mue*dend/den)/den
              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
              wxyd = u_yd - v_xd
              wxy = u_y - v_x
              wxzd = u_zd - w_xd
              wxz = u_z - w_x
              wyzd = v_zd - w_yd
              wyz = v_z - w_y
              wyxd = -wxyd
              wyx = -wxy
              wzxd = -wxzd
              wzx = -wxz
              wzyd = -wyzd
              wzy = -wyz
! compute the extra terms of the boussinesq relation
              temp = wxy*tauxys + wxz*tauxzs
              exxd = two*(temp*factd+fact*(tauxys*wxyd+wxy*tauxysd+&
&               tauxzs*wxzd+wxz*tauxzsd))
              exx = two*(fact*temp)
              temp = wyx*tauxys + wyz*tauyzs
              eyyd = two*(temp*factd+fact*(tauxys*wyxd+wyx*tauxysd+&
&               tauyzs*wyzd+wyz*tauyzsd))
              eyy = two*(fact*temp)
              temp = wzx*tauxzs + wzy*tauyzs
              ezzd = two*(temp*factd+fact*(tauxzs*wzxd+wzx*tauxzsd+&
&               tauyzs*wzyd+wzy*tauyzsd))
              ezz = two*(fact*temp)
              temp = wxy*tauyys + wxz*tauyzs + wyx*tauxxs + wyz*tauxzs
              exyd = temp*factd + fact*(tauyys*wxyd+wxy*tauyysd+tauyzs*&
&               wxzd+wxz*tauyzsd+tauxxs*wyxd+wyx*tauxxsd+tauxzs*wyzd+wyz&
&               *tauxzsd)
              exy = fact*temp
              temp = wxy*tauyzs + wxz*tauzzs + wzx*tauxxs + wzy*tauxys
              exzd = temp*factd + fact*(tauyzs*wxyd+wxy*tauyzsd+tauzzs*&
&               wxzd+wxz*tauzzsd+tauxxs*wzxd+wzx*tauxxsd+tauxys*wzyd+wzy&
&               *tauxysd)
              exz = fact*temp
              temp = wyx*tauxzs + wyz*tauzzs + wzx*tauxys + wzy*tauyys
              eyzd = temp*factd + fact*(tauxzs*wyxd+wyx*tauxzsd+tauzzs*&
&               wyzd+wyz*tauzzsd+tauxys*wzxd+wzx*tauxysd+tauyys*wzyd+wzy&
&               *tauyysd)
              eyz = fact*temp
! apply the total viscosity to the stress tensor and add extra terms
              tauxxd = tauxxs*mutd + mut*tauxxsd - exxd
              tauxx = mut*tauxxs - exx
              tauyyd = tauyys*mutd + mut*tauyysd - eyyd
              tauyy = mut*tauyys - eyy
              tauzzd = tauzzs*mutd + mut*tauzzsd - ezzd
              tauzz = mut*tauzzs - ezz
              tauxyd = tauxys*mutd + mut*tauxysd - exyd
              tauxy = mut*tauxys - exy
              tauxzd = tauxzs*mutd + mut*tauxzsd - exzd
              tauxz = mut*tauxzs - exz
              tauyzd = tauyzs*mutd + mut*tauyzsd - eyzd
              tauyz = mut*tauyzs - eyz
            else
! just apply the total viscosity to the stress tensor
              tauxxd = tauxxs*mutd + mut*tauxxsd
              tauxx = mut*tauxxs
              tauyyd = tauyys*mutd + mut*tauyysd
              tauyy = mut*tauyys
              tauzzd = tauzzs*mutd + mut*tauzzsd
              tauzz = mut*tauzzs
              tauxyd = tauxys*mutd + mut*tauxysd
              tauxy = mut*tauxys
              tauxzd = tauxzs*mutd + mut*tauxzsd
              tauxz = mut*tauxzs
              tauyzd = tauyzs*mutd + mut*tauyzsd
              tauyz = mut*tauyzs
            end if
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
            ubard = half*(wd(i, j, k, ivx)+wd(i, j, k+1, ivx))
            ubar = half*(w(i, j, k, ivx)+w(i, j, k+1, ivx))
            vbard = half*(wd(i, j, k, ivy)+wd(i, j, k+1, ivy))
            vbar = half*(w(i, j, k, ivy)+w(i, j, k+1, ivy))
            wbard = half*(wd(i, j, k, ivz)+wd(i, j, k+1, ivz))
            wbar = half*(w(i, j, k, ivz)+w(i, j, k+1, ivz))
! compute the viscous fluxes for this k-face.
            temp = sk(i, j, k, 1)
            temp0 = sk(i, j, k, 2)
            temp1 = sk(i, j, k, 3)
            fmxd = temp*tauxxd + tauxx*skd(i, j, k, 1) + temp0*tauxyd + &
&             tauxy*skd(i, j, k, 2) + temp1*tauxzd + tauxz*skd(i, j, k, &
&             3)
            fmx = tauxx*temp + tauxy*temp0 + tauxz*temp1
            temp1 = sk(i, j, k, 1)
            temp0 = sk(i, j, k, 2)
            temp = sk(i, j, k, 3)
            fmyd = temp1*tauxyd + tauxy*skd(i, j, k, 1) + temp0*tauyyd +&
&             tauyy*skd(i, j, k, 2) + temp*tauyzd + tauyz*skd(i, j, k, 3&
&             )
            fmy = tauxy*temp1 + tauyy*temp0 + tauyz*temp
            temp1 = sk(i, j, k, 1)
            temp0 = sk(i, j, k, 2)
            temp = sk(i, j, k, 3)
            fmzd = temp1*tauxzd + tauxz*skd(i, j, k, 1) + temp0*tauyzd +&
&             tauyz*skd(i, j, k, 2) + temp*tauzzd + tauzz*skd(i, j, k, 3&
&             )
            fmz = tauxz*temp1 + tauyz*temp0 + tauzz*temp
            temp1 = sk(i, j, k, 1)
            temp0 = ubar*tauxx + vbar*tauxy + wbar*tauxz
            frhoed = temp1*(tauxx*ubard+ubar*tauxxd+tauxy*vbard+vbar*&
&             tauxyd+tauxz*wbard+wbar*tauxzd) + temp0*skd(i, j, k, 1)
            frhoe = temp0*temp1
            temp1 = sk(i, j, k, 2)
            temp0 = ubar*tauxy + vbar*tauyy + wbar*tauyz
            frhoed = frhoed + temp1*(tauxy*ubard+ubar*tauxyd+tauyy*vbard&
&             +vbar*tauyyd+tauyz*wbard+wbar*tauyzd) + temp0*skd(i, j, k&
&             , 2)
            frhoe = frhoe + temp0*temp1
            temp1 = sk(i, j, k, 3)
            temp0 = ubar*tauxz + vbar*tauyz + wbar*tauzz
            frhoed = frhoed + temp1*(tauxz*ubard+ubar*tauxzd+tauyz*vbard&
&             +vbar*tauyzd+tauzz*wbard+wbar*tauzzd) + temp0*skd(i, j, k&
&             , 3)
            frhoe = frhoe + temp0*temp1
            temp1 = sk(i, j, k, 1)
            temp0 = sk(i, j, k, 2)
            temp = sk(i, j, k, 3)
            frhoed = frhoed - temp1*q_xd - q_x*skd(i, j, k, 1) - temp0*&
&             q_yd - q_y*skd(i, j, k, 2) - temp*q_zd - q_z*skd(i, j, k, &
&             3)
            frhoe = frhoe - q_x*temp1 - q_y*temp0 - q_z*temp
! update the residuals of cell k and k+1.
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fmxd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fmyd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fmzd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - frhoed
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
            fwd(i, j, k+1, imx) = fwd(i, j, k+1, imx) + fmxd
            fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fmx
            fwd(i, j, k+1, imy) = fwd(i, j, k+1, imy) + fmyd
            fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fmy
            fwd(i, j, k+1, imz) = fwd(i, j, k+1, imz) + fmzd
            fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fmz
            fwd(i, j, k+1, irhoe) = fwd(i, j, k+1, irhoe) + frhoed
            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
              viscsubfaced(visckminpointer(i, j))%tau(i, j, 1) = tauxxd
              viscsubface(visckminpointer(i, j))%tau(i, j, 1) = tauxx
              viscsubfaced(visckminpointer(i, j))%tau(i, j, 2) = tauyyd
              viscsubface(visckminpointer(i, j))%tau(i, j, 2) = tauyy
              viscsubfaced(visckminpointer(i, j))%tau(i, j, 3) = tauzzd
              viscsubface(visckminpointer(i, j))%tau(i, j, 3) = tauzz
              viscsubfaced(visckminpointer(i, j))%tau(i, j, 4) = tauxyd
              viscsubface(visckminpointer(i, j))%tau(i, j, 4) = tauxy
              viscsubfaced(visckminpointer(i, j))%tau(i, j, 5) = tauxzd
              viscsubface(visckminpointer(i, j))%tau(i, j, 5) = tauxz
              viscsubfaced(visckminpointer(i, j))%tau(i, j, 6) = tauyzd
              viscsubface(visckminpointer(i, j))%tau(i, j, 6) = tauyz
              viscsubfaced(visckminpointer(i, j))%q(i, j, 1) = q_xd
              viscsubface(visckminpointer(i, j))%q(i, j, 1) = q_x
              viscsubfaced(visckminpointer(i, j))%q(i, j, 2) = q_yd
              viscsubface(visckminpointer(i, j))%q(i, j, 2) = q_y
              viscsubfaced(visckminpointer(i, j))%q(i, j, 3) = q_zd
              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
              viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 1) = tauxxd
              viscsubface(visckmaxpointer(i, j))%tau(i, j, 1) = tauxx
              viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 2) = tauyyd
              viscsubface(visckmaxpointer(i, j))%tau(i, j, 2) = tauyy
              viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 3) = tauzzd
              viscsubface(visckmaxpointer(i, j))%tau(i, j, 3) = tauzz
              viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 4) = tauxyd
              viscsubface(visckmaxpointer(i, j))%tau(i, j, 4) = tauxy
              viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 5) = tauxzd
              viscsubface(visckmaxpointer(i, j))%tau(i, j, 5) = tauxz
              viscsubfaced(visckmaxpointer(i, j))%tau(i, j, 6) = tauyzd
              viscsubface(visckmaxpointer(i, j))%tau(i, j, 6) = tauyz
              viscsubfaced(visckmaxpointer(i, j))%q(i, j, 1) = q_xd
              viscsubface(visckmaxpointer(i, j))%q(i, j, 1) = q_x
              viscsubfaced(visckmaxpointer(i, j))%q(i, j, 2) = q_yd
              viscsubface(visckmaxpointer(i, j))%q(i, j, 2) = q_y
              viscsubfaced(visckmaxpointer(i, j))%q(i, j, 3) = q_zd
              viscsubface(visckmaxpointer(i, j))%q(i, j, 3) = q_z
            end if
          end do
        end do
      end do
!
!         viscous fluxes in the j-direction.
!
      mue = zero
      mued = 0.0_8
      do k=2,kl
        do j=1,jl
          do i=2,il
! 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.
            muld = por*(rlvd(i, j, k)+rlvd(i, j+1, k))
            mul = por*(rlv(i, j, k)+rlv(i, j+1, k))
            if (eddymodel) then
              mued = por*(revd(i, j, k)+revd(i, j+1, k))
              mue = por*(rev(i, j, k)+rev(i, j+1, k))
            end if
            mutd = muld + mued
            mut = mul + mue
            gm1 = half*(gamma(i, j, k)+gamma(i, j+1, k)) - one
            factlamheat = one/(prandtl*gm1)
            factturbheat = one/(prandtlturb*gm1)
            heatcoefd = factlamheat*muld + factturbheat*mued
            heatcoef = mul*factlamheat + mue*factturbheat
! compute the gradients at the face by averaging the four
! nodal values.
            u_xd = fourth*(uxd(i-1, j, k-1)+uxd(i, j, k-1)+uxd(i-1, j, k&
&             )+uxd(i, j, k))
            u_x = fourth*(ux(i-1, j, k-1)+ux(i, j, k-1)+ux(i-1, j, k)+ux&
&             (i, j, k))
            u_yd = fourth*(uyd(i-1, j, k-1)+uyd(i, j, k-1)+uyd(i-1, j, k&
&             )+uyd(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_zd = fourth*(uzd(i-1, j, k-1)+uzd(i, j, k-1)+uzd(i-1, j, k&
&             )+uzd(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_xd = fourth*(vxd(i-1, j, k-1)+vxd(i, j, k-1)+vxd(i-1, j, k&
&             )+vxd(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_yd = fourth*(vyd(i-1, j, k-1)+vyd(i, j, k-1)+vyd(i-1, j, k&
&             )+vyd(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_zd = fourth*(vzd(i-1, j, k-1)+vzd(i, j, k-1)+vzd(i-1, j, k&
&             )+vzd(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_xd = fourth*(wxd(i-1, j, k-1)+wxd(i, j, k-1)+wxd(i-1, j, k&
&             )+wxd(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_yd = fourth*(wyd(i-1, j, k-1)+wyd(i, j, k-1)+wyd(i-1, j, k&
&             )+wyd(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_zd = fourth*(wzd(i-1, j, k-1)+wzd(i, j, k-1)+wzd(i-1, j, k&
&             )+wzd(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_xd = fourth*(qxd(i-1, j, k-1)+qxd(i, j, k-1)+qxd(i-1, j, k&
&             )+qxd(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_yd = fourth*(qyd(i-1, j, k-1)+qyd(i, j, k-1)+qyd(i-1, j, k&
&             )+qyd(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_zd = fourth*(qzd(i-1, j, k-1)+qzd(i, j, k-1)+qzd(i-1, j, k&
&             )+qzd(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.
            ssxd = eighth*(xd(i-1, j+1, k-1, 1)-xd(i-1, j-1, k-1, 1)+xd(&
&             i-1, j+1, k, 1)-xd(i-1, j-1, k, 1)+xd(i, j+1, k-1, 1)-xd(i&
&             , j-1, k-1, 1)+xd(i, j+1, k, 1)-xd(i, j-1, k, 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))
            ssyd = eighth*(xd(i-1, j+1, k-1, 2)-xd(i-1, j-1, k-1, 2)+xd(&
&             i-1, j+1, k, 2)-xd(i-1, j-1, k, 2)+xd(i, j+1, k-1, 2)-xd(i&
&             , j-1, k-1, 2)+xd(i, j+1, k, 2)-xd(i, j-1, k, 2))
            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))
            sszd = eighth*(xd(i-1, j+1, k-1, 3)-xd(i-1, j-1, k-1, 3)+xd(&
&             i-1, j+1, k, 3)-xd(i-1, j-1, k, 3)+xd(i, j+1, k-1, 3)-xd(i&
&             , j-1, k-1, 3)+xd(i, j+1, k, 3)-xd(i, j-1, k, 3))
            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.
            arg1d = 2*ssx*ssxd + 2*ssy*ssyd + 2*ssz*sszd
            arg1 = ssx*ssx + ssy*ssy + ssz*ssz
            temp1 = sqrt(arg1)
            if (arg1 .eq. 0.0_8) then
              result1d = 0.0_8
            else
              result1d = arg1d/(2.0*temp1)
            end if
            result1 = temp1
            ssd = -(one*result1d/result1**2)
            ss = one/result1
            ssxd = ssx*ssd + ss*ssxd
            ssx = ss*ssx
            ssyd = ssy*ssd + ss*ssyd
            ssy = ss*ssy
            sszd = ssz*ssd + ss*sszd
            ssz = ss*ssz
! correct the gradients.
            temp1 = w(i, j+1, k, ivx) - w(i, j, k, ivx)
            corrd = ssx*u_xd + u_x*ssxd + ssy*u_yd + u_y*ssyd + ssz*u_zd&
&             + u_z*sszd - ss*(wd(i, j+1, k, ivx)-wd(i, j, k, ivx)) - &
&             temp1*ssd
            corr = u_x*ssx + u_y*ssy + u_z*ssz - temp1*ss
            u_xd = u_xd - ssx*corrd - corr*ssxd
            u_x = u_x - corr*ssx
            u_yd = u_yd - ssy*corrd - corr*ssyd
            u_y = u_y - corr*ssy
            u_zd = u_zd - ssz*corrd - corr*sszd
            u_z = u_z - corr*ssz
            temp1 = w(i, j+1, k, ivy) - w(i, j, k, ivy)
            corrd = ssx*v_xd + v_x*ssxd + ssy*v_yd + v_y*ssyd + ssz*v_zd&
&             + v_z*sszd - ss*(wd(i, j+1, k, ivy)-wd(i, j, k, ivy)) - &
&             temp1*ssd
            corr = v_x*ssx + v_y*ssy + v_z*ssz - temp1*ss
            v_xd = v_xd - ssx*corrd - corr*ssxd
            v_x = v_x - corr*ssx
            v_yd = v_yd - ssy*corrd - corr*ssyd
            v_y = v_y - corr*ssy
            v_zd = v_zd - ssz*corrd - corr*sszd
            v_z = v_z - corr*ssz
            temp1 = w(i, j+1, k, ivz) - w(i, j, k, ivz)
            corrd = ssx*w_xd + w_x*ssxd + ssy*w_yd + w_y*ssyd + ssz*w_zd&
&             + w_z*sszd - ss*(wd(i, j+1, k, ivz)-wd(i, j, k, ivz)) - &
&             temp1*ssd
            corr = w_x*ssx + w_y*ssy + w_z*ssz - temp1*ss
            w_xd = w_xd - ssx*corrd - corr*ssxd
            w_x = w_x - corr*ssx
            w_yd = w_yd - ssy*corrd - corr*ssyd
            w_y = w_y - corr*ssy
            w_zd = w_zd - ssz*corrd - corr*sszd
            w_z = w_z - corr*ssz
            temp1 = aa(i, j+1, k) - aa(i, j, k)
            corrd = ssx*q_xd + q_x*ssxd + ssy*q_yd + q_y*ssyd + ssz*q_zd&
&             + q_z*sszd + ss*(aad(i, j+1, k)-aad(i, j, k)) + temp1*ssd
            corr = q_x*ssx + q_y*ssy + q_z*ssz + temp1*ss
            q_xd = q_xd - ssx*corrd - corr*ssxd
            q_x = q_x - corr*ssx
            q_yd = q_yd - ssy*corrd - corr*ssyd
            q_y = q_y - corr*ssy
            q_zd = q_zd - ssz*corrd - corr*sszd
            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.
            fracdivd = twothird*(u_xd+v_yd+w_zd)
            fracdiv = twothird*(u_x+v_y+w_z)
            tauxxsd = two*u_xd - fracdivd
            tauxxs = two*u_x - fracdiv
            tauyysd = two*v_yd - fracdivd
            tauyys = two*v_y - fracdiv
            tauzzsd = two*w_zd - fracdivd
            tauzzs = two*w_z - fracdiv
            tauxysd = u_yd + v_xd
            tauxys = u_y + v_x
            tauxzsd = u_zd + w_xd
            tauxzs = u_z + w_x
            tauyzsd = v_zd + w_yd
            tauyzs = v_z + w_y
            q_xd = q_x*heatcoefd + heatcoef*q_xd
            q_x = heatcoef*q_x
            q_yd = q_y*heatcoefd + heatcoef*q_yd
            q_y = heatcoef*q_y
            q_zd = q_z*heatcoefd + heatcoef*q_zd
            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
              arg1d = 2*u_x*u_xd + 2*u_y*u_yd + 2*u_z*u_zd + 2*v_x*v_xd &
&               + 2*v_y*v_yd + 2*v_z*v_zd + 2*w_x*w_xd + 2*w_y*w_yd + 2*&
&               w_z*w_zd
              arg1 = 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
              temp1 = sqrt(arg1)
              if (arg1 .eq. 0.0_8) then
                dend = 0.0_8
              else
                dend = arg1d/(2.0*temp1)
              end if
              den = temp1
              if (den .lt. xminn) then
                den = xminn
                dend = 0.0_8
              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.
              factd = ccr1*(mued-mue*dend/den)/den
              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
              wxyd = u_yd - v_xd
              wxy = u_y - v_x
              wxzd = u_zd - w_xd
              wxz = u_z - w_x
              wyzd = v_zd - w_yd
              wyz = v_z - w_y
              wyxd = -wxyd
              wyx = -wxy
              wzxd = -wxzd
              wzx = -wxz
              wzyd = -wyzd
              wzy = -wyz
! compute the extra terms of the boussinesq relation
              temp1 = wxy*tauxys + wxz*tauxzs
              exxd = two*(temp1*factd+fact*(tauxys*wxyd+wxy*tauxysd+&
&               tauxzs*wxzd+wxz*tauxzsd))
              exx = two*(fact*temp1)
              temp1 = wyx*tauxys + wyz*tauyzs
              eyyd = two*(temp1*factd+fact*(tauxys*wyxd+wyx*tauxysd+&
&               tauyzs*wyzd+wyz*tauyzsd))
              eyy = two*(fact*temp1)
              temp1 = wzx*tauxzs + wzy*tauyzs
              ezzd = two*(temp1*factd+fact*(tauxzs*wzxd+wzx*tauxzsd+&
&               tauyzs*wzyd+wzy*tauyzsd))
              ezz = two*(fact*temp1)
              temp1 = wxy*tauyys + wxz*tauyzs + wyx*tauxxs + wyz*tauxzs
              exyd = temp1*factd + fact*(tauyys*wxyd+wxy*tauyysd+tauyzs*&
&               wxzd+wxz*tauyzsd+tauxxs*wyxd+wyx*tauxxsd+tauxzs*wyzd+wyz&
&               *tauxzsd)
              exy = fact*temp1
              temp1 = wxy*tauyzs + wxz*tauzzs + wzx*tauxxs + wzy*tauxys
              exzd = temp1*factd + fact*(tauyzs*wxyd+wxy*tauyzsd+tauzzs*&
&               wxzd+wxz*tauzzsd+tauxxs*wzxd+wzx*tauxxsd+tauxys*wzyd+wzy&
&               *tauxysd)
              exz = fact*temp1
              temp1 = wyx*tauxzs + wyz*tauzzs + wzx*tauxys + wzy*tauyys
              eyzd = temp1*factd + fact*(tauxzs*wyxd+wyx*tauxzsd+tauzzs*&
&               wyzd+wyz*tauzzsd+tauxys*wzxd+wzx*tauxysd+tauyys*wzyd+wzy&
&               *tauyysd)
              eyz = fact*temp1
! apply the total viscosity to the stress tensor and add extra terms
              tauxxd = tauxxs*mutd + mut*tauxxsd - exxd
              tauxx = mut*tauxxs - exx
              tauyyd = tauyys*mutd + mut*tauyysd - eyyd
              tauyy = mut*tauyys - eyy
              tauzzd = tauzzs*mutd + mut*tauzzsd - ezzd
              tauzz = mut*tauzzs - ezz
              tauxyd = tauxys*mutd + mut*tauxysd - exyd
              tauxy = mut*tauxys - exy
              tauxzd = tauxzs*mutd + mut*tauxzsd - exzd
              tauxz = mut*tauxzs - exz
              tauyzd = tauyzs*mutd + mut*tauyzsd - eyzd
              tauyz = mut*tauyzs - eyz
            else
! just apply the total viscosity to the stress tensor
              tauxxd = tauxxs*mutd + mut*tauxxsd
              tauxx = mut*tauxxs
              tauyyd = tauyys*mutd + mut*tauyysd
              tauyy = mut*tauyys
              tauzzd = tauzzs*mutd + mut*tauzzsd
              tauzz = mut*tauzzs
              tauxyd = tauxys*mutd + mut*tauxysd
              tauxy = mut*tauxys
              tauxzd = tauxzs*mutd + mut*tauxzsd
              tauxz = mut*tauxzs
              tauyzd = tauyzs*mutd + mut*tauyzsd
              tauyz = mut*tauyzs
            end if
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
            ubard = half*(wd(i, j, k, ivx)+wd(i, j+1, k, ivx))
            ubar = half*(w(i, j, k, ivx)+w(i, j+1, k, ivx))
            vbard = half*(wd(i, j, k, ivy)+wd(i, j+1, k, ivy))
            vbar = half*(w(i, j, k, ivy)+w(i, j+1, k, ivy))
            wbard = half*(wd(i, j, k, ivz)+wd(i, j+1, k, ivz))
            wbar = half*(w(i, j, k, ivz)+w(i, j+1, k, ivz))
! compute the viscous fluxes for this j-face.
            temp1 = sj(i, j, k, 1)
            temp0 = sj(i, j, k, 2)
            temp = sj(i, j, k, 3)
            fmxd = temp1*tauxxd + tauxx*sjd(i, j, k, 1) + temp0*tauxyd +&
&             tauxy*sjd(i, j, k, 2) + temp*tauxzd + tauxz*sjd(i, j, k, 3&
&             )
            fmx = tauxx*temp1 + tauxy*temp0 + tauxz*temp
            temp1 = sj(i, j, k, 1)
            temp0 = sj(i, j, k, 2)
            temp = sj(i, j, k, 3)
            fmyd = temp1*tauxyd + tauxy*sjd(i, j, k, 1) + temp0*tauyyd +&
&             tauyy*sjd(i, j, k, 2) + temp*tauyzd + tauyz*sjd(i, j, k, 3&
&             )
            fmy = tauxy*temp1 + tauyy*temp0 + tauyz*temp
            temp1 = sj(i, j, k, 1)
            temp0 = sj(i, j, k, 2)
            temp = sj(i, j, k, 3)
            fmzd = temp1*tauxzd + tauxz*sjd(i, j, k, 1) + temp0*tauyzd +&
&             tauyz*sjd(i, j, k, 2) + temp*tauzzd + tauzz*sjd(i, j, k, 3&
&             )
            fmz = tauxz*temp1 + tauyz*temp0 + tauzz*temp
            temp1 = sj(i, j, k, 1)
            temp0 = ubar*tauxx + vbar*tauxy + wbar*tauxz
            temp = sj(i, j, k, 2)
            temp2 = ubar*tauxy + vbar*tauyy + wbar*tauyz
            temp3 = sj(i, j, k, 3)
            temp4 = ubar*tauxz + vbar*tauyz + wbar*tauzz
            temp5 = sj(i, j, k, 1)
            temp6 = sj(i, j, k, 2)
            temp7 = sj(i, j, k, 3)
            frhoed = temp1*(tauxx*ubard+ubar*tauxxd+tauxy*vbard+vbar*&
&             tauxyd+tauxz*wbard+wbar*tauxzd) + (temp0-q_x)*sjd(i, j, k&
&             , 1) + temp*(tauxy*ubard+ubar*tauxyd+tauyy*vbard+vbar*&
&             tauyyd+tauyz*wbard+wbar*tauyzd) + (temp2-q_y)*sjd(i, j, k&
&             , 2) + temp3*(tauxz*ubard+ubar*tauxzd+tauyz*vbard+vbar*&
&             tauyzd+tauzz*wbard+wbar*tauzzd) + (temp4-q_z)*sjd(i, j, k&
&             , 3) - temp5*q_xd - temp6*q_yd - temp7*q_zd
            frhoe = temp0*temp1 + temp2*temp + temp4*temp3 - q_x*temp5 -&
&             q_y*temp6 - q_z*temp7
! update the residuals of cell j and j+1.
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fmxd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fmyd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fmzd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - frhoed
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
            fwd(i, j+1, k, imx) = fwd(i, j+1, k, imx) + fmxd
            fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fmx
            fwd(i, j+1, k, imy) = fwd(i, j+1, k, imy) + fmyd
            fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fmy
            fwd(i, j+1, k, imz) = fwd(i, j+1, k, imz) + fmzd
            fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fmz
            fwd(i, j+1, k, irhoe) = fwd(i, j+1, k, irhoe) + frhoed
            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
              viscsubfaced(viscjminpointer(i, k))%tau(i, k, 1) = tauxxd
              viscsubface(viscjminpointer(i, k))%tau(i, k, 1) = tauxx
              viscsubfaced(viscjminpointer(i, k))%tau(i, k, 2) = tauyyd
              viscsubface(viscjminpointer(i, k))%tau(i, k, 2) = tauyy
              viscsubfaced(viscjminpointer(i, k))%tau(i, k, 3) = tauzzd
              viscsubface(viscjminpointer(i, k))%tau(i, k, 3) = tauzz
              viscsubfaced(viscjminpointer(i, k))%tau(i, k, 4) = tauxyd
              viscsubface(viscjminpointer(i, k))%tau(i, k, 4) = tauxy
              viscsubfaced(viscjminpointer(i, k))%tau(i, k, 5) = tauxzd
              viscsubface(viscjminpointer(i, k))%tau(i, k, 5) = tauxz
              viscsubfaced(viscjminpointer(i, k))%tau(i, k, 6) = tauyzd
              viscsubface(viscjminpointer(i, k))%tau(i, k, 6) = tauyz
              viscsubfaced(viscjminpointer(i, k))%q(i, k, 1) = q_xd
              viscsubface(viscjminpointer(i, k))%q(i, k, 1) = q_x
              viscsubfaced(viscjminpointer(i, k))%q(i, k, 2) = q_yd
              viscsubface(viscjminpointer(i, k))%q(i, k, 2) = q_y
              viscsubfaced(viscjminpointer(i, k))%q(i, k, 3) = q_zd
              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
              viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 1) = tauxxd
              viscsubface(viscjmaxpointer(i, k))%tau(i, k, 1) = tauxx
              viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 2) = tauyyd
              viscsubface(viscjmaxpointer(i, k))%tau(i, k, 2) = tauyy
              viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 3) = tauzzd
              viscsubface(viscjmaxpointer(i, k))%tau(i, k, 3) = tauzz
              viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 4) = tauxyd
              viscsubface(viscjmaxpointer(i, k))%tau(i, k, 4) = tauxy
              viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 5) = tauxzd
              viscsubface(viscjmaxpointer(i, k))%tau(i, k, 5) = tauxz
              viscsubfaced(viscjmaxpointer(i, k))%tau(i, k, 6) = tauyzd
              viscsubface(viscjmaxpointer(i, k))%tau(i, k, 6) = tauyz
              viscsubfaced(viscjmaxpointer(i, k))%q(i, k, 1) = q_xd
              viscsubface(viscjmaxpointer(i, k))%q(i, k, 1) = q_x
              viscsubfaced(viscjmaxpointer(i, k))%q(i, k, 2) = q_yd
              viscsubface(viscjmaxpointer(i, k))%q(i, k, 2) = q_y
              viscsubfaced(viscjmaxpointer(i, k))%q(i, k, 3) = q_zd
              viscsubface(viscjmaxpointer(i, k))%q(i, k, 3) = q_z
            end if
          end do
        end do
      end do
!
!         viscous fluxes in the i-direction.
!
      mue = zero
      mued = 0.0_8
      do k=2,kl
        do j=2,jl
          do i=1,il
! 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.
            muld = por*(rlvd(i, j, k)+rlvd(i+1, j, k))
            mul = por*(rlv(i, j, k)+rlv(i+1, j, k))
            if (eddymodel) then
              mued = por*(revd(i, j, k)+revd(i+1, j, k))
              mue = por*(rev(i, j, k)+rev(i+1, j, k))
            end if
            mutd = muld + mued
            mut = mul + mue
            gm1 = half*(gamma(i, j, k)+gamma(i+1, j, k)) - one
            factlamheat = one/(prandtl*gm1)
            factturbheat = one/(prandtlturb*gm1)
            heatcoefd = factlamheat*muld + factturbheat*mued
            heatcoef = mul*factlamheat + mue*factturbheat
! compute the gradients at the face by averaging the four
! nodal values.
            u_xd = fourth*(uxd(i, j-1, k-1)+uxd(i, j, k-1)+uxd(i, j-1, k&
&             )+uxd(i, j, k))
            u_x = fourth*(ux(i, j-1, k-1)+ux(i, j, k-1)+ux(i, j-1, k)+ux&
&             (i, j, k))
            u_yd = fourth*(uyd(i, j-1, k-1)+uyd(i, j, k-1)+uyd(i, j-1, k&
&             )+uyd(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_zd = fourth*(uzd(i, j-1, k-1)+uzd(i, j, k-1)+uzd(i, j-1, k&
&             )+uzd(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_xd = fourth*(vxd(i, j-1, k-1)+vxd(i, j, k-1)+vxd(i, j-1, k&
&             )+vxd(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_yd = fourth*(vyd(i, j-1, k-1)+vyd(i, j, k-1)+vyd(i, j-1, k&
&             )+vyd(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_zd = fourth*(vzd(i, j-1, k-1)+vzd(i, j, k-1)+vzd(i, j-1, k&
&             )+vzd(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_xd = fourth*(wxd(i, j-1, k-1)+wxd(i, j, k-1)+wxd(i, j-1, k&
&             )+wxd(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_yd = fourth*(wyd(i, j-1, k-1)+wyd(i, j, k-1)+wyd(i, j-1, k&
&             )+wyd(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_zd = fourth*(wzd(i, j-1, k-1)+wzd(i, j, k-1)+wzd(i, j-1, k&
&             )+wzd(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_xd = fourth*(qxd(i, j-1, k-1)+qxd(i, j, k-1)+qxd(i, j-1, k&
&             )+qxd(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_yd = fourth*(qyd(i, j-1, k-1)+qyd(i, j, k-1)+qyd(i, j-1, k&
&             )+qyd(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_zd = fourth*(qzd(i, j-1, k-1)+qzd(i, j, k-1)+qzd(i, j-1, k&
&             )+qzd(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.
            ssxd = eighth*(xd(i+1, j-1, k-1, 1)-xd(i-1, j-1, k-1, 1)+xd(&
&             i+1, j-1, k, 1)-xd(i-1, j-1, k, 1)+xd(i+1, j, k-1, 1)-xd(i&
&             -1, j, k-1, 1)+xd(i+1, j, k, 1)-xd(i-1, j, k, 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))
            ssyd = eighth*(xd(i+1, j-1, k-1, 2)-xd(i-1, j-1, k-1, 2)+xd(&
&             i+1, j-1, k, 2)-xd(i-1, j-1, k, 2)+xd(i+1, j, k-1, 2)-xd(i&
&             -1, j, k-1, 2)+xd(i+1, j, k, 2)-xd(i-1, j, k, 2))
            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))
            sszd = eighth*(xd(i+1, j-1, k-1, 3)-xd(i-1, j-1, k-1, 3)+xd(&
&             i+1, j-1, k, 3)-xd(i-1, j-1, k, 3)+xd(i+1, j, k-1, 3)-xd(i&
&             -1, j, k-1, 3)+xd(i+1, j, k, 3)-xd(i-1, j, k, 3))
            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.
            arg1d = 2*ssx*ssxd + 2*ssy*ssyd + 2*ssz*sszd
            arg1 = ssx*ssx + ssy*ssy + ssz*ssz
            temp7 = sqrt(arg1)
            if (arg1 .eq. 0.0_8) then
              result1d = 0.0_8
            else
              result1d = arg1d/(2.0*temp7)
            end if
            result1 = temp7
            ssd = -(one*result1d/result1**2)
            ss = one/result1
            ssxd = ssx*ssd + ss*ssxd
            ssx = ss*ssx
            ssyd = ssy*ssd + ss*ssyd
            ssy = ss*ssy
            sszd = ssz*ssd + ss*sszd
            ssz = ss*ssz
! correct the gradients.
            temp7 = w(i+1, j, k, ivx) - w(i, j, k, ivx)
            corrd = ssx*u_xd + u_x*ssxd + ssy*u_yd + u_y*ssyd + ssz*u_zd&
&             + u_z*sszd - ss*(wd(i+1, j, k, ivx)-wd(i, j, k, ivx)) - &
&             temp7*ssd
            corr = u_x*ssx + u_y*ssy + u_z*ssz - temp7*ss
            u_xd = u_xd - ssx*corrd - corr*ssxd
            u_x = u_x - corr*ssx
            u_yd = u_yd - ssy*corrd - corr*ssyd
            u_y = u_y - corr*ssy
            u_zd = u_zd - ssz*corrd - corr*sszd
            u_z = u_z - corr*ssz
            temp7 = w(i+1, j, k, ivy) - w(i, j, k, ivy)
            corrd = ssx*v_xd + v_x*ssxd + ssy*v_yd + v_y*ssyd + ssz*v_zd&
&             + v_z*sszd - ss*(wd(i+1, j, k, ivy)-wd(i, j, k, ivy)) - &
&             temp7*ssd
            corr = v_x*ssx + v_y*ssy + v_z*ssz - temp7*ss
            v_xd = v_xd - ssx*corrd - corr*ssxd
            v_x = v_x - corr*ssx
            v_yd = v_yd - ssy*corrd - corr*ssyd
            v_y = v_y - corr*ssy
            v_zd = v_zd - ssz*corrd - corr*sszd
            v_z = v_z - corr*ssz
            temp7 = w(i+1, j, k, ivz) - w(i, j, k, ivz)
            corrd = ssx*w_xd + w_x*ssxd + ssy*w_yd + w_y*ssyd + ssz*w_zd&
&             + w_z*sszd - ss*(wd(i+1, j, k, ivz)-wd(i, j, k, ivz)) - &
&             temp7*ssd
            corr = w_x*ssx + w_y*ssy + w_z*ssz - temp7*ss
            w_xd = w_xd - ssx*corrd - corr*ssxd
            w_x = w_x - corr*ssx
            w_yd = w_yd - ssy*corrd - corr*ssyd
            w_y = w_y - corr*ssy
            w_zd = w_zd - ssz*corrd - corr*sszd
            w_z = w_z - corr*ssz
            temp7 = aa(i+1, j, k) - aa(i, j, k)
            corrd = ssx*q_xd + q_x*ssxd + ssy*q_yd + q_y*ssyd + ssz*q_zd&
&             + q_z*sszd + ss*(aad(i+1, j, k)-aad(i, j, k)) + temp7*ssd
            corr = q_x*ssx + q_y*ssy + q_z*ssz + temp7*ss
            q_xd = q_xd - ssx*corrd - corr*ssxd
            q_x = q_x - corr*ssx
            q_yd = q_yd - ssy*corrd - corr*ssyd
            q_y = q_y - corr*ssy
            q_zd = q_zd - ssz*corrd - corr*sszd
            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.
            fracdivd = twothird*(u_xd+v_yd+w_zd)
            fracdiv = twothird*(u_x+v_y+w_z)
            tauxxsd = two*u_xd - fracdivd
            tauxxs = two*u_x - fracdiv
            tauyysd = two*v_yd - fracdivd
            tauyys = two*v_y - fracdiv
            tauzzsd = two*w_zd - fracdivd
            tauzzs = two*w_z - fracdiv
            tauxysd = u_yd + v_xd
            tauxys = u_y + v_x
            tauxzsd = u_zd + w_xd
            tauxzs = u_z + w_x
            tauyzsd = v_zd + w_yd
            tauyzs = v_z + w_y
            q_xd = q_x*heatcoefd + heatcoef*q_xd
            q_x = heatcoef*q_x
            q_yd = q_y*heatcoefd + heatcoef*q_yd
            q_y = heatcoef*q_y
            q_zd = q_z*heatcoefd + heatcoef*q_zd
            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
              arg1d = 2*u_x*u_xd + 2*u_y*u_yd + 2*u_z*u_zd + 2*v_x*v_xd &
&               + 2*v_y*v_yd + 2*v_z*v_zd + 2*w_x*w_xd + 2*w_y*w_yd + 2*&
&               w_z*w_zd
              arg1 = 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
              temp7 = sqrt(arg1)
              if (arg1 .eq. 0.0_8) then
                dend = 0.0_8
              else
                dend = arg1d/(2.0*temp7)
              end if
              den = temp7
              if (den .lt. xminn) then
                den = xminn
                dend = 0.0_8
              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.
              factd = ccr1*(mued-mue*dend/den)/den
              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
              wxyd = u_yd - v_xd
              wxy = u_y - v_x
              wxzd = u_zd - w_xd
              wxz = u_z - w_x
              wyzd = v_zd - w_yd
              wyz = v_z - w_y
              wyxd = -wxyd
              wyx = -wxy
              wzxd = -wxzd
              wzx = -wxz
              wzyd = -wyzd
              wzy = -wyz
! compute the extra terms of the boussinesq relation
              temp7 = wxy*tauxys + wxz*tauxzs
              exxd = two*(temp7*factd+fact*(tauxys*wxyd+wxy*tauxysd+&
&               tauxzs*wxzd+wxz*tauxzsd))
              exx = two*(fact*temp7)
              temp7 = wyx*tauxys + wyz*tauyzs
              eyyd = two*(temp7*factd+fact*(tauxys*wyxd+wyx*tauxysd+&
&               tauyzs*wyzd+wyz*tauyzsd))
              eyy = two*(fact*temp7)
              temp7 = wzx*tauxzs + wzy*tauyzs
              ezzd = two*(temp7*factd+fact*(tauxzs*wzxd+wzx*tauxzsd+&
&               tauyzs*wzyd+wzy*tauyzsd))
              ezz = two*(fact*temp7)
              temp7 = wxy*tauyys + wxz*tauyzs + wyx*tauxxs + wyz*tauxzs
              exyd = temp7*factd + fact*(tauyys*wxyd+wxy*tauyysd+tauyzs*&
&               wxzd+wxz*tauyzsd+tauxxs*wyxd+wyx*tauxxsd+tauxzs*wyzd+wyz&
&               *tauxzsd)
              exy = fact*temp7
              temp7 = wxy*tauyzs + wxz*tauzzs + wzx*tauxxs + wzy*tauxys
              exzd = temp7*factd + fact*(tauyzs*wxyd+wxy*tauyzsd+tauzzs*&
&               wxzd+wxz*tauzzsd+tauxxs*wzxd+wzx*tauxxsd+tauxys*wzyd+wzy&
&               *tauxysd)
              exz = fact*temp7
              temp7 = wyx*tauxzs + wyz*tauzzs + wzx*tauxys + wzy*tauyys
              eyzd = temp7*factd + fact*(tauxzs*wyxd+wyx*tauxzsd+tauzzs*&
&               wyzd+wyz*tauzzsd+tauxys*wzxd+wzx*tauxysd+tauyys*wzyd+wzy&
&               *tauyysd)
              eyz = fact*temp7
! apply the total viscosity to the stress tensor and add extra terms
              tauxxd = tauxxs*mutd + mut*tauxxsd - exxd
              tauxx = mut*tauxxs - exx
              tauyyd = tauyys*mutd + mut*tauyysd - eyyd
              tauyy = mut*tauyys - eyy
              tauzzd = tauzzs*mutd + mut*tauzzsd - ezzd
              tauzz = mut*tauzzs - ezz
              tauxyd = tauxys*mutd + mut*tauxysd - exyd
              tauxy = mut*tauxys - exy
              tauxzd = tauxzs*mutd + mut*tauxzsd - exzd
              tauxz = mut*tauxzs - exz
              tauyzd = tauyzs*mutd + mut*tauyzsd - eyzd
              tauyz = mut*tauyzs - eyz
            else
! just apply the total viscosity to the stress tensor
              tauxxd = tauxxs*mutd + mut*tauxxsd
              tauxx = mut*tauxxs
              tauyyd = tauyys*mutd + mut*tauyysd
              tauyy = mut*tauyys
              tauzzd = tauzzs*mutd + mut*tauzzsd
              tauzz = mut*tauzzs
              tauxyd = tauxys*mutd + mut*tauxysd
              tauxy = mut*tauxys
              tauxzd = tauxzs*mutd + mut*tauxzsd
              tauxz = mut*tauxzs
              tauyzd = tauyzs*mutd + mut*tauyzsd
              tauyz = mut*tauyzs
            end if
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
            ubard = half*(wd(i, j, k, ivx)+wd(i+1, j, k, ivx))
            ubar = half*(w(i, j, k, ivx)+w(i+1, j, k, ivx))
            vbard = half*(wd(i, j, k, ivy)+wd(i+1, j, k, ivy))
            vbar = half*(w(i, j, k, ivy)+w(i+1, j, k, ivy))
            wbard = half*(wd(i, j, k, ivz)+wd(i+1, j, k, ivz))
            wbar = half*(w(i, j, k, ivz)+w(i+1, j, k, ivz))
! compute the viscous fluxes for this i-face.
            temp7 = si(i, j, k, 1)
            temp6 = si(i, j, k, 2)
            temp5 = si(i, j, k, 3)
            fmxd = temp7*tauxxd + tauxx*sid(i, j, k, 1) + temp6*tauxyd +&
&             tauxy*sid(i, j, k, 2) + temp5*tauxzd + tauxz*sid(i, j, k, &
&             3)
            fmx = tauxx*temp7 + tauxy*temp6 + tauxz*temp5
            temp7 = si(i, j, k, 1)
            temp6 = si(i, j, k, 2)
            temp5 = si(i, j, k, 3)
            fmyd = temp7*tauxyd + tauxy*sid(i, j, k, 1) + temp6*tauyyd +&
&             tauyy*sid(i, j, k, 2) + temp5*tauyzd + tauyz*sid(i, j, k, &
&             3)
            fmy = tauxy*temp7 + tauyy*temp6 + tauyz*temp5
            temp7 = si(i, j, k, 1)
            temp6 = si(i, j, k, 2)
            temp5 = si(i, j, k, 3)
            fmzd = temp7*tauxzd + tauxz*sid(i, j, k, 1) + temp6*tauyzd +&
&             tauyz*sid(i, j, k, 2) + temp5*tauzzd + tauzz*sid(i, j, k, &
&             3)
            fmz = tauxz*temp7 + tauyz*temp6 + tauzz*temp5
            temp7 = si(i, j, k, 1)
            temp6 = ubar*tauxx + vbar*tauxy + wbar*tauxz
            temp5 = si(i, j, k, 2)
            temp4 = ubar*tauxy + vbar*tauyy + wbar*tauyz
            temp3 = si(i, j, k, 3)
            temp2 = ubar*tauxz + vbar*tauyz + wbar*tauzz
            temp1 = si(i, j, k, 1)
            temp0 = si(i, j, k, 2)
            temp = si(i, j, k, 3)
            frhoed = temp7*(tauxx*ubard+ubar*tauxxd+tauxy*vbard+vbar*&
&             tauxyd+tauxz*wbard+wbar*tauxzd) + (temp6-q_x)*sid(i, j, k&
&             , 1) + temp5*(tauxy*ubard+ubar*tauxyd+tauyy*vbard+vbar*&
&             tauyyd+tauyz*wbard+wbar*tauyzd) + (temp4-q_y)*sid(i, j, k&
&             , 2) + temp3*(tauxz*ubard+ubar*tauxzd+tauyz*vbard+vbar*&
&             tauyzd+tauzz*wbard+wbar*tauzzd) + (temp2-q_z)*sid(i, j, k&
&             , 3) - temp1*q_xd - temp0*q_yd - temp*q_zd
            frhoe = temp6*temp7 + temp4*temp5 + temp2*temp3 - q_x*temp1 &
&             - q_y*temp0 - q_z*temp
! update the residuals of cell i and i+1.
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fmxd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fmyd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fmzd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - frhoed
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
            fwd(i+1, j, k, imx) = fwd(i+1, j, k, imx) + fmxd
            fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fmx
            fwd(i+1, j, k, imy) = fwd(i+1, j, k, imy) + fmyd
            fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fmy
            fwd(i+1, j, k, imz) = fwd(i+1, j, k, imz) + fmzd
            fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fmz
            fwd(i+1, j, k, irhoe) = fwd(i+1, j, k, irhoe) + frhoed
            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
              viscsubfaced(visciminpointer(j, k))%tau(j, k, 1) = tauxxd
              viscsubface(visciminpointer(j, k))%tau(j, k, 1) = tauxx
              viscsubfaced(visciminpointer(j, k))%tau(j, k, 2) = tauyyd
              viscsubface(visciminpointer(j, k))%tau(j, k, 2) = tauyy
              viscsubfaced(visciminpointer(j, k))%tau(j, k, 3) = tauzzd
              viscsubface(visciminpointer(j, k))%tau(j, k, 3) = tauzz
              viscsubfaced(visciminpointer(j, k))%tau(j, k, 4) = tauxyd
              viscsubface(visciminpointer(j, k))%tau(j, k, 4) = tauxy
              viscsubfaced(visciminpointer(j, k))%tau(j, k, 5) = tauxzd
              viscsubface(visciminpointer(j, k))%tau(j, k, 5) = tauxz
              viscsubfaced(visciminpointer(j, k))%tau(j, k, 6) = tauyzd
              viscsubface(visciminpointer(j, k))%tau(j, k, 6) = tauyz
              viscsubfaced(visciminpointer(j, k))%q(j, k, 1) = q_xd
              viscsubface(visciminpointer(j, k))%q(j, k, 1) = q_x
              viscsubfaced(visciminpointer(j, k))%q(j, k, 2) = q_yd
              viscsubface(visciminpointer(j, k))%q(j, k, 2) = q_y
              viscsubfaced(visciminpointer(j, k))%q(j, k, 3) = q_zd
              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
              viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 1) = tauxxd
              viscsubface(viscimaxpointer(j, k))%tau(j, k, 1) = tauxx
              viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 2) = tauyyd
              viscsubface(viscimaxpointer(j, k))%tau(j, k, 2) = tauyy
              viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 3) = tauzzd
              viscsubface(viscimaxpointer(j, k))%tau(j, k, 3) = tauzz
              viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 4) = tauxyd
              viscsubface(viscimaxpointer(j, k))%tau(j, k, 4) = tauxy
              viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 5) = tauxzd
              viscsubface(viscimaxpointer(j, k))%tau(j, k, 5) = tauxz
              viscsubfaced(viscimaxpointer(j, k))%tau(j, k, 6) = tauyzd
              viscsubface(viscimaxpointer(j, k))%tau(j, k, 6) = tauyz
              viscsubfaced(viscimaxpointer(j, k))%q(j, k, 1) = q_xd
              viscsubface(viscimaxpointer(j, k))%q(j, k, 1) = q_x
              viscsubfaced(viscimaxpointer(j, k))%q(j, k, 2) = q_yd
              viscsubface(viscimaxpointer(j, k))%q(j, k, 2) = q_y
              viscsubfaced(viscimaxpointer(j, k))%q(j, k, 3) = q_zd
              viscsubface(viscimaxpointer(j, k))%q(j, k, 3) = q_z
            end if
          end do
        end do
      end do
      continue
! possibly correct the wall shear stress.
! wall function is not aded
    end if
  end subroutine viscousflux_d
 
  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 sqrt
    intrinsic max
    real(kind=realtype) :: abs0
    real(kind=realtype) :: arg1
    real(kind=realtype) :: result1
! 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
      do k=1,kl
        do j=2,jl
          do i=2,il
! 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.
            arg1 = ssx*ssx + ssy*ssy + ssz*ssz
            result1 = sqrt(arg1)
            ss = one/result1
            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
              arg1 = 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
              den = sqrt(arg1)
              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
        end do
      end do
!$ad checkpoint-end
!
!         viscous fluxes in the j-direction.
!
      continue
!$ad checkpoint-start
      mue = zero
      do k=2,kl
        do j=1,jl
          do i=2,il
! 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.
            arg1 = ssx*ssx + ssy*ssy + ssz*ssz
            result1 = sqrt(arg1)
            ss = one/result1
            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
              arg1 = 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
              den = sqrt(arg1)
              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
        end do
      end do
!$ad checkpoint-end
!
!         viscous fluxes in the i-direction.
!
      continue
!$ad checkpoint-start
      mue = zero
      do k=2,kl
        do j=2,jl
          do i=1,il
! 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.
            arg1 = ssx*ssx + ssy*ssy + ssz*ssz
            result1 = sqrt(arg1)
            ss = one/result1
            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
              arg1 = 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
              den = sqrt(arg1)
              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
        end do
      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 forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: *fw
!   with respect to varying inputs: *rev *aa *w *x *rlv *si *sj
!                *sk *fw
!   rw status of diff variables: *rev:in *aa:in *w:in *x:in *rlv:in
!                *si:in *sj:in *sk:in *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_d()
    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) :: temp0
    real(kind=realtype) :: temp1
    real(kind=realtype) :: temp2
    real(kind=realtype) :: temp3
    real(kind=realtype) :: temp4
    real(kind=realtype) :: temp5
    real(kind=realtype) :: temp6
    real(kind=realtype) :: temp7
    mue = zero
    rfilv = rfil
    mued = 0.0_8
! 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
          ssxd = eighth*(xd(i+1, j-1, k-1, 1)-xd(i-1, j-1, k-1, 1)+xd(i+&
&           1, j-1, k, 1)-xd(i-1, j-1, k, 1)+xd(i+1, j, k-1, 1)-xd(i-1, &
&           j, k-1, 1)+xd(i+1, j, k, 1)-xd(i-1, j, k, 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))
          ssyd = eighth*(xd(i+1, j-1, k-1, 2)-xd(i-1, j-1, k-1, 2)+xd(i+&
&           1, j-1, k, 2)-xd(i-1, j-1, k, 2)+xd(i+1, j, k-1, 2)-xd(i-1, &
&           j, k-1, 2)+xd(i+1, j, k, 2)-xd(i-1, j, k, 2))
          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))
          sszd = eighth*(xd(i+1, j-1, k-1, 3)-xd(i-1, j-1, k-1, 3)+xd(i+&
&           1, j-1, k, 3)-xd(i-1, j-1, k, 3)+xd(i+1, j, k-1, 3)-xd(i-1, &
&           j, k-1, 3)+xd(i+1, j, k, 3)-xd(i-1, j, k, 3))
          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
          temp = one/(ssx*ssx+ssy*ssy+ssz*ssz)
          ssd = -(temp*(2*ssx*ssxd+2*ssy*ssyd+2*ssz*sszd)/(ssx**2+ssy**2&
&           +ssz**2))
          ss = temp
          ssxd = ssx*ssd + ss*ssxd
          ssx = ss*ssx
          ssyd = ssy*ssd + ss*ssyd
          ssy = ss*ssy
          sszd = ssz*ssd + ss*sszd
          ssz = ss*ssz
! now compute each gradient
          ddd = wd(i+1, j, k, ivx) - wd(i, j, k, ivx)
          dd = w(i+1, j, k, ivx) - w(i, j, k, ivx)
          u_xd = ssx*ddd + dd*ssxd
          u_x = dd*ssx
          u_yd = ssy*ddd + dd*ssyd
          u_y = dd*ssy
          u_zd = ssz*ddd + dd*sszd
          u_z = dd*ssz
          ddd = wd(i+1, j, k, ivy) - wd(i, j, k, ivy)
          dd = w(i+1, j, k, ivy) - w(i, j, k, ivy)
          v_xd = ssx*ddd + dd*ssxd
          v_x = dd*ssx
          v_yd = ssy*ddd + dd*ssyd
          v_y = dd*ssy
          v_zd = ssz*ddd + dd*sszd
          v_z = dd*ssz
          ddd = wd(i+1, j, k, ivz) - wd(i, j, k, ivz)
          dd = w(i+1, j, k, ivz) - w(i, j, k, ivz)
          w_xd = ssx*ddd + dd*ssxd
          w_x = dd*ssx
          w_yd = ssy*ddd + dd*ssyd
          w_y = dd*ssy
          w_zd = ssz*ddd + dd*sszd
          w_z = dd*ssz
          ddd = aad(i+1, j, k) - aad(i, j, k)
          dd = aa(i+1, j, k) - aa(i, j, k)
          q_xd = -(ssx*ddd+dd*ssxd)
          q_x = -(dd*ssx)
          q_yd = -(ssy*ddd+dd*ssyd)
          q_y = -(dd*ssy)
          q_zd = -(ssz*ddd+dd*sszd)
          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.
          muld = por*(rlvd(i, j, k)+rlvd(i+1, j, k))
          mul = por*(rlv(i, j, k)+rlv(i+1, j, k))
          if (eddymodel) then
            mued = por*(revd(i, j, k)+revd(i+1, j, k))
            mue = por*(rev(i, j, k)+rev(i+1, j, k))
          end if
          mutd = muld + mued
          mut = mul + mue
          gm1 = half*(gamma(i, j, k)+gamma(i+1, j, k)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          heatcoefd = factlamheat*muld + factturbheat*mued
          heatcoef = mul*factlamheat + mue*factturbheat
! compute the stress tensor and the heat flux vector.
          fracdivd = twothird*(u_xd+v_yd+w_zd)
          fracdiv = twothird*(u_x+v_y+w_z)
          tauxxd = (two*u_x-fracdiv)*mutd + mut*(two*u_xd-fracdivd)
          tauxx = mut*(two*u_x-fracdiv)
          tauyyd = (two*v_y-fracdiv)*mutd + mut*(two*v_yd-fracdivd)
          tauyy = mut*(two*v_y-fracdiv)
          tauzzd = (two*w_z-fracdiv)*mutd + mut*(two*w_zd-fracdivd)
          tauzz = mut*(two*w_z-fracdiv)
          tauxyd = (u_y+v_x)*mutd + mut*(u_yd+v_xd)
          tauxy = mut*(u_y+v_x)
          tauxzd = (u_z+w_x)*mutd + mut*(u_zd+w_xd)
          tauxz = mut*(u_z+w_x)
          tauyzd = (v_z+w_y)*mutd + mut*(v_zd+w_yd)
          tauyz = mut*(v_z+w_y)
          q_xd = q_x*heatcoefd + heatcoef*q_xd
          q_x = heatcoef*q_x
          q_yd = q_y*heatcoefd + heatcoef*q_yd
          q_y = heatcoef*q_y
          q_zd = q_z*heatcoefd + heatcoef*q_zd
          q_z = heatcoef*q_z
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
          ubard = half*(wd(i, j, k, ivx)+wd(i+1, j, k, ivx))
          ubar = half*(w(i, j, k, ivx)+w(i+1, j, k, ivx))
          vbard = half*(wd(i, j, k, ivy)+wd(i+1, j, k, ivy))
          vbar = half*(w(i, j, k, ivy)+w(i+1, j, k, ivy))
          wbard = half*(wd(i, j, k, ivz)+wd(i+1, j, k, ivz))
          wbar = half*(w(i, j, k, ivz)+w(i+1, j, k, ivz))
! compute the viscous fluxes for this i-face.
          temp = si(i, j, k, 1)
          temp0 = si(i, j, k, 2)
          temp1 = si(i, j, k, 3)
          fmxd = temp*tauxxd + tauxx*sid(i, j, k, 1) + temp0*tauxyd + &
&           tauxy*sid(i, j, k, 2) + temp1*tauxzd + tauxz*sid(i, j, k, 3)
          fmx = tauxx*temp + tauxy*temp0 + tauxz*temp1
          temp1 = si(i, j, k, 1)
          temp0 = si(i, j, k, 2)
          temp = si(i, j, k, 3)
          fmyd = temp1*tauxyd + tauxy*sid(i, j, k, 1) + temp0*tauyyd + &
&           tauyy*sid(i, j, k, 2) + temp*tauyzd + tauyz*sid(i, j, k, 3)
          fmy = tauxy*temp1 + tauyy*temp0 + tauyz*temp
          temp1 = si(i, j, k, 1)
          temp0 = si(i, j, k, 2)
          temp = si(i, j, k, 3)
          fmzd = temp1*tauxzd + tauxz*sid(i, j, k, 1) + temp0*tauyzd + &
&           tauyz*sid(i, j, k, 2) + temp*tauzzd + tauzz*sid(i, j, k, 3)
          fmz = tauxz*temp1 + tauyz*temp0 + tauzz*temp
          temp1 = si(i, j, k, 1)
          temp0 = ubar*tauxx + vbar*tauxy + wbar*tauxz
          temp = si(i, j, k, 2)
          temp2 = ubar*tauxy + vbar*tauyy + wbar*tauyz
          temp3 = si(i, j, k, 3)
          temp4 = ubar*tauxz + vbar*tauyz + wbar*tauzz
          temp5 = si(i, j, k, 1)
          temp6 = si(i, j, k, 2)
          temp7 = si(i, j, k, 3)
          frhoed = temp1*(tauxx*ubard+ubar*tauxxd+tauxy*vbard+vbar*&
&           tauxyd+tauxz*wbard+wbar*tauxzd) + (temp0-q_x)*sid(i, j, k, 1&
&           ) + temp*(tauxy*ubard+ubar*tauxyd+tauyy*vbard+vbar*tauyyd+&
&           tauyz*wbard+wbar*tauyzd) + (temp2-q_y)*sid(i, j, k, 2) + &
&           temp3*(tauxz*ubard+ubar*tauxzd+tauyz*vbard+vbar*tauyzd+tauzz&
&           *wbard+wbar*tauzzd) + (temp4-q_z)*sid(i, j, k, 3) - temp5*&
&           q_xd - temp6*q_yd - temp7*q_zd
          frhoe = temp0*temp1 + temp2*temp + temp4*temp3 - q_x*temp5 - &
&           q_y*temp6 - q_z*temp7
! update the residuals of cell i and i+1.
          fwd(i, j, k, imx) = fwd(i, j, k, imx) - fmxd
          fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
          fwd(i, j, k, imy) = fwd(i, j, k, imy) - fmyd
          fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
          fwd(i, j, k, imz) = fwd(i, j, k, imz) - fmzd
          fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
          fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - frhoed
          fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
          fwd(i+1, j, k, imx) = fwd(i+1, j, k, imx) + fmxd
          fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fmx
          fwd(i+1, j, k, imy) = fwd(i+1, j, k, imy) + fmyd
          fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fmy
          fwd(i+1, j, k, imz) = fwd(i+1, j, k, imz) + fmzd
          fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fmz
          fwd(i+1, j, k, irhoe) = fwd(i+1, j, k, irhoe) + frhoed
          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
          ssxd = eighth*(xd(i-1, j+1, k-1, 1)-xd(i-1, j-1, k-1, 1)+xd(i-&
&           1, j+1, k, 1)-xd(i-1, j-1, k, 1)+xd(i, j+1, k-1, 1)-xd(i, j-&
&           1, k-1, 1)+xd(i, j+1, k, 1)-xd(i, j-1, k, 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))
          ssyd = eighth*(xd(i-1, j+1, k-1, 2)-xd(i-1, j-1, k-1, 2)+xd(i-&
&           1, j+1, k, 2)-xd(i-1, j-1, k, 2)+xd(i, j+1, k-1, 2)-xd(i, j-&
&           1, k-1, 2)+xd(i, j+1, k, 2)-xd(i, j-1, k, 2))
          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))
          sszd = eighth*(xd(i-1, j+1, k-1, 3)-xd(i-1, j-1, k-1, 3)+xd(i-&
&           1, j+1, k, 3)-xd(i-1, j-1, k, 3)+xd(i, j+1, k-1, 3)-xd(i, j-&
&           1, k-1, 3)+xd(i, j+1, k, 3)-xd(i, j-1, k, 3))
          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
          temp7 = one/(ssx*ssx+ssy*ssy+ssz*ssz)
          ssd = -(temp7*(2*ssx*ssxd+2*ssy*ssyd+2*ssz*sszd)/(ssx**2+ssy**&
&           2+ssz**2))
          ss = temp7
          ssxd = ssx*ssd + ss*ssxd
          ssx = ss*ssx
          ssyd = ssy*ssd + ss*ssyd
          ssy = ss*ssy
          sszd = ssz*ssd + ss*sszd
          ssz = ss*ssz
! now compute each gradient
          ddd = wd(i, j+1, k, ivx) - wd(i, j, k, ivx)
          dd = w(i, j+1, k, ivx) - w(i, j, k, ivx)
          u_xd = ssx*ddd + dd*ssxd
          u_x = dd*ssx
          u_yd = ssy*ddd + dd*ssyd
          u_y = dd*ssy
          u_zd = ssz*ddd + dd*sszd
          u_z = dd*ssz
          ddd = wd(i, j+1, k, ivy) - wd(i, j, k, ivy)
          dd = w(i, j+1, k, ivy) - w(i, j, k, ivy)
          v_xd = ssx*ddd + dd*ssxd
          v_x = dd*ssx
          v_yd = ssy*ddd + dd*ssyd
          v_y = dd*ssy
          v_zd = ssz*ddd + dd*sszd
          v_z = dd*ssz
          ddd = wd(i, j+1, k, ivz) - wd(i, j, k, ivz)
          dd = w(i, j+1, k, ivz) - w(i, j, k, ivz)
          w_xd = ssx*ddd + dd*ssxd
          w_x = dd*ssx
          w_yd = ssy*ddd + dd*ssyd
          w_y = dd*ssy
          w_zd = ssz*ddd + dd*sszd
          w_z = dd*ssz
          ddd = aad(i, j+1, k) - aad(i, j, k)
          dd = aa(i, j+1, k) - aa(i, j, k)
          q_xd = -(ssx*ddd+dd*ssxd)
          q_x = -(dd*ssx)
          q_yd = -(ssy*ddd+dd*ssyd)
          q_y = -(dd*ssy)
          q_zd = -(ssz*ddd+dd*sszd)
          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.
          muld = por*(rlvd(i, j, k)+rlvd(i, j+1, k))
          mul = por*(rlv(i, j, k)+rlv(i, j+1, k))
          if (eddymodel) then
            mued = por*(revd(i, j, k)+revd(i, j+1, k))
            mue = por*(rev(i, j, k)+rev(i, j+1, k))
          end if
          mutd = muld + mued
          mut = mul + mue
          gm1 = half*(gamma(i, j, k)+gamma(i, j+1, k)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          heatcoefd = factlamheat*muld + factturbheat*mued
          heatcoef = mul*factlamheat + mue*factturbheat
! compute the stress tensor and the heat flux vector.
          fracdivd = twothird*(u_xd+v_yd+w_zd)
          fracdiv = twothird*(u_x+v_y+w_z)
          tauxxd = (two*u_x-fracdiv)*mutd + mut*(two*u_xd-fracdivd)
          tauxx = mut*(two*u_x-fracdiv)
          tauyyd = (two*v_y-fracdiv)*mutd + mut*(two*v_yd-fracdivd)
          tauyy = mut*(two*v_y-fracdiv)
          tauzzd = (two*w_z-fracdiv)*mutd + mut*(two*w_zd-fracdivd)
          tauzz = mut*(two*w_z-fracdiv)
          tauxyd = (u_y+v_x)*mutd + mut*(u_yd+v_xd)
          tauxy = mut*(u_y+v_x)
          tauxzd = (u_z+w_x)*mutd + mut*(u_zd+w_xd)
          tauxz = mut*(u_z+w_x)
          tauyzd = (v_z+w_y)*mutd + mut*(v_zd+w_yd)
          tauyz = mut*(v_z+w_y)
          q_xd = q_x*heatcoefd + heatcoef*q_xd
          q_x = heatcoef*q_x
          q_yd = q_y*heatcoefd + heatcoef*q_yd
          q_y = heatcoef*q_y
          q_zd = q_z*heatcoefd + heatcoef*q_zd
          q_z = heatcoef*q_z
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
          ubard = half*(wd(i, j, k, ivx)+wd(i, j+1, k, ivx))
          ubar = half*(w(i, j, k, ivx)+w(i, j+1, k, ivx))
          vbard = half*(wd(i, j, k, ivy)+wd(i, j+1, k, ivy))
          vbar = half*(w(i, j, k, ivy)+w(i, j+1, k, ivy))
          wbard = half*(wd(i, j, k, ivz)+wd(i, j+1, k, ivz))
          wbar = half*(w(i, j, k, ivz)+w(i, j+1, k, ivz))
! compute the viscous fluxes for this j-face.
          temp7 = sj(i, j, k, 1)
          temp6 = sj(i, j, k, 2)
          temp5 = sj(i, j, k, 3)
          fmxd = temp7*tauxxd + tauxx*sjd(i, j, k, 1) + temp6*tauxyd + &
&           tauxy*sjd(i, j, k, 2) + temp5*tauxzd + tauxz*sjd(i, j, k, 3)
          fmx = tauxx*temp7 + tauxy*temp6 + tauxz*temp5
          temp7 = sj(i, j, k, 1)
          temp6 = sj(i, j, k, 2)
          temp5 = sj(i, j, k, 3)
          fmyd = temp7*tauxyd + tauxy*sjd(i, j, k, 1) + temp6*tauyyd + &
&           tauyy*sjd(i, j, k, 2) + temp5*tauyzd + tauyz*sjd(i, j, k, 3)
          fmy = tauxy*temp7 + tauyy*temp6 + tauyz*temp5
          temp7 = sj(i, j, k, 1)
          temp6 = sj(i, j, k, 2)
          temp5 = sj(i, j, k, 3)
          fmzd = temp7*tauxzd + tauxz*sjd(i, j, k, 1) + temp6*tauyzd + &
&           tauyz*sjd(i, j, k, 2) + temp5*tauzzd + tauzz*sjd(i, j, k, 3)
          fmz = tauxz*temp7 + tauyz*temp6 + tauzz*temp5
          temp7 = sj(i, j, k, 1)
          temp6 = ubar*tauxx + vbar*tauxy + wbar*tauxz
          temp5 = sj(i, j, k, 2)
          temp4 = ubar*tauxy + vbar*tauyy + wbar*tauyz
          temp3 = sj(i, j, k, 3)
          temp2 = ubar*tauxz + vbar*tauyz + wbar*tauzz
          temp1 = sj(i, j, k, 1)
          temp0 = sj(i, j, k, 2)
          temp = sj(i, j, k, 3)
          frhoed = temp7*(tauxx*ubard+ubar*tauxxd+tauxy*vbard+vbar*&
&           tauxyd+tauxz*wbard+wbar*tauxzd) + (temp6-q_x)*sjd(i, j, k, 1&
&           ) + temp5*(tauxy*ubard+ubar*tauxyd+tauyy*vbard+vbar*tauyyd+&
&           tauyz*wbard+wbar*tauyzd) + (temp4-q_y)*sjd(i, j, k, 2) + &
&           temp3*(tauxz*ubard+ubar*tauxzd+tauyz*vbard+vbar*tauyzd+tauzz&
&           *wbard+wbar*tauzzd) + (temp2-q_z)*sjd(i, j, k, 3) - temp1*&
&           q_xd - temp0*q_yd - temp*q_zd
          frhoe = temp6*temp7 + temp4*temp5 + temp2*temp3 - q_x*temp1 - &
&           q_y*temp0 - q_z*temp
! update the residuals of cell j and j+1.
          fwd(i, j, k, imx) = fwd(i, j, k, imx) - fmxd
          fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
          fwd(i, j, k, imy) = fwd(i, j, k, imy) - fmyd
          fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
          fwd(i, j, k, imz) = fwd(i, j, k, imz) - fmzd
          fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
          fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - frhoed
          fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
          fwd(i, j+1, k, imx) = fwd(i, j+1, k, imx) + fmxd
          fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fmx
          fwd(i, j+1, k, imy) = fwd(i, j+1, k, imy) + fmyd
          fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fmy
          fwd(i, j+1, k, imz) = fwd(i, j+1, k, imz) + fmzd
          fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fmz
          fwd(i, j+1, k, irhoe) = fwd(i, j+1, k, irhoe) + frhoed
          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
          ssxd = eighth*(xd(i-1, j-1, k+1, 1)-xd(i-1, j-1, k-1, 1)+xd(i-&
&           1, j, k+1, 1)-xd(i-1, j, k-1, 1)+xd(i, j-1, k+1, 1)-xd(i, j-&
&           1, k-1, 1)+xd(i, j, k+1, 1)-xd(i, j, k-1, 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))
          ssyd = eighth*(xd(i-1, j-1, k+1, 2)-xd(i-1, j-1, k-1, 2)+xd(i-&
&           1, j, k+1, 2)-xd(i-1, j, k-1, 2)+xd(i, j-1, k+1, 2)-xd(i, j-&
&           1, k-1, 2)+xd(i, j, k+1, 2)-xd(i, j, k-1, 2))
          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))
          sszd = eighth*(xd(i-1, j-1, k+1, 3)-xd(i-1, j-1, k-1, 3)+xd(i-&
&           1, j, k+1, 3)-xd(i-1, j, k-1, 3)+xd(i, j-1, k+1, 3)-xd(i, j-&
&           1, k-1, 3)+xd(i, j, k+1, 3)-xd(i, j, k-1, 3))
          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
          temp7 = one/(ssx*ssx+ssy*ssy+ssz*ssz)
          ssd = -(temp7*(2*ssx*ssxd+2*ssy*ssyd+2*ssz*sszd)/(ssx**2+ssy**&
&           2+ssz**2))
          ss = temp7
          ssxd = ssx*ssd + ss*ssxd
          ssx = ss*ssx
          ssyd = ssy*ssd + ss*ssyd
          ssy = ss*ssy
          sszd = ssz*ssd + ss*sszd
          ssz = ss*ssz
! now compute each gradient
          ddd = wd(i, j, k+1, ivx) - wd(i, j, k, ivx)
          dd = w(i, j, k+1, ivx) - w(i, j, k, ivx)
          u_xd = ssx*ddd + dd*ssxd
          u_x = dd*ssx
          u_yd = ssy*ddd + dd*ssyd
          u_y = dd*ssy
          u_zd = ssz*ddd + dd*sszd
          u_z = dd*ssz
          ddd = wd(i, j, k+1, ivy) - wd(i, j, k, ivy)
          dd = w(i, j, k+1, ivy) - w(i, j, k, ivy)
          v_xd = ssx*ddd + dd*ssxd
          v_x = dd*ssx
          v_yd = ssy*ddd + dd*ssyd
          v_y = dd*ssy
          v_zd = ssz*ddd + dd*sszd
          v_z = dd*ssz
          ddd = wd(i, j, k+1, ivz) - wd(i, j, k, ivz)
          dd = w(i, j, k+1, ivz) - w(i, j, k, ivz)
          w_xd = ssx*ddd + dd*ssxd
          w_x = dd*ssx
          w_yd = ssy*ddd + dd*ssyd
          w_y = dd*ssy
          w_zd = ssz*ddd + dd*sszd
          w_z = dd*ssz
          ddd = aad(i, j, k+1) - aad(i, j, k)
          dd = aa(i, j, k+1) - aa(i, j, k)
          q_xd = -(ssx*ddd+dd*ssxd)
          q_x = -(dd*ssx)
          q_yd = -(ssy*ddd+dd*ssyd)
          q_y = -(dd*ssy)
          q_zd = -(ssz*ddd+dd*sszd)
          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.
          muld = por*(rlvd(i, j, k)+rlvd(i, j, k+1))
          mul = por*(rlv(i, j, k)+rlv(i, j, k+1))
          if (eddymodel) then
            mued = por*(revd(i, j, k)+revd(i, j, k+1))
            mue = por*(rev(i, j, k)+rev(i, j, k+1))
          end if
          mutd = muld + mued
          mut = mul + mue
          gm1 = half*(gamma(i, j, k)+gamma(i, j, k+1)) - one
          factlamheat = one/(prandtl*gm1)
          factturbheat = one/(prandtlturb*gm1)
          heatcoefd = factlamheat*muld + factturbheat*mued
          heatcoef = mul*factlamheat + mue*factturbheat
! compute the stress tensor and the heat flux vector.
          fracdivd = twothird*(u_xd+v_yd+w_zd)
          fracdiv = twothird*(u_x+v_y+w_z)
          tauxxd = (two*u_x-fracdiv)*mutd + mut*(two*u_xd-fracdivd)
          tauxx = mut*(two*u_x-fracdiv)
          tauyyd = (two*v_y-fracdiv)*mutd + mut*(two*v_yd-fracdivd)
          tauyy = mut*(two*v_y-fracdiv)
          tauzzd = (two*w_z-fracdiv)*mutd + mut*(two*w_zd-fracdivd)
          tauzz = mut*(two*w_z-fracdiv)
          tauxyd = (u_y+v_x)*mutd + mut*(u_yd+v_xd)
          tauxy = mut*(u_y+v_x)
          tauxzd = (u_z+w_x)*mutd + mut*(u_zd+w_xd)
          tauxz = mut*(u_z+w_x)
          tauyzd = (v_z+w_y)*mutd + mut*(v_zd+w_yd)
          tauyz = mut*(v_z+w_y)
          q_xd = q_x*heatcoefd + heatcoef*q_xd
          q_x = heatcoef*q_x
          q_yd = q_y*heatcoefd + heatcoef*q_yd
          q_y = heatcoef*q_y
          q_zd = q_z*heatcoefd + heatcoef*q_zd
          q_z = heatcoef*q_z
! compute the average velocities for the face. remember that
! the velocities are stored and not the momentum.
          ubard = half*(wd(i, j, k, ivx)+wd(i, j, k+1, ivx))
          ubar = half*(w(i, j, k, ivx)+w(i, j, k+1, ivx))
          vbard = half*(wd(i, j, k, ivy)+wd(i, j, k+1, ivy))
          vbar = half*(w(i, j, k, ivy)+w(i, j, k+1, ivy))
          wbard = half*(wd(i, j, k, ivz)+wd(i, j, k+1, ivz))
          wbar = half*(w(i, j, k, ivz)+w(i, j, k+1, ivz))
! compute the viscous fluxes for this j-face.
          temp7 = sk(i, j, k, 1)
          temp6 = sk(i, j, k, 2)
          temp5 = sk(i, j, k, 3)
          fmxd = temp7*tauxxd + tauxx*skd(i, j, k, 1) + temp6*tauxyd + &
&           tauxy*skd(i, j, k, 2) + temp5*tauxzd + tauxz*skd(i, j, k, 3)
          fmx = tauxx*temp7 + tauxy*temp6 + tauxz*temp5
          temp7 = sk(i, j, k, 1)
          temp6 = sk(i, j, k, 2)
          temp5 = sk(i, j, k, 3)
          fmyd = temp7*tauxyd + tauxy*skd(i, j, k, 1) + temp6*tauyyd + &
&           tauyy*skd(i, j, k, 2) + temp5*tauyzd + tauyz*skd(i, j, k, 3)
          fmy = tauxy*temp7 + tauyy*temp6 + tauyz*temp5
          temp7 = sk(i, j, k, 1)
          temp6 = sk(i, j, k, 2)
          temp5 = sk(i, j, k, 3)
          fmzd = temp7*tauxzd + tauxz*skd(i, j, k, 1) + temp6*tauyzd + &
&           tauyz*skd(i, j, k, 2) + temp5*tauzzd + tauzz*skd(i, j, k, 3)
          fmz = tauxz*temp7 + tauyz*temp6 + tauzz*temp5
          temp7 = sk(i, j, k, 1)
          temp6 = ubar*tauxx + vbar*tauxy + wbar*tauxz
          temp5 = sk(i, j, k, 2)
          temp4 = ubar*tauxy + vbar*tauyy + wbar*tauyz
          temp3 = sk(i, j, k, 3)
          temp2 = ubar*tauxz + vbar*tauyz + wbar*tauzz
          temp1 = sk(i, j, k, 1)
          temp0 = sk(i, j, k, 2)
          temp = sk(i, j, k, 3)
          frhoed = temp7*(tauxx*ubard+ubar*tauxxd+tauxy*vbard+vbar*&
&           tauxyd+tauxz*wbard+wbar*tauxzd) + (temp6-q_x)*skd(i, j, k, 1&
&           ) + temp5*(tauxy*ubard+ubar*tauxyd+tauyy*vbard+vbar*tauyyd+&
&           tauyz*wbard+wbar*tauyzd) + (temp4-q_y)*skd(i, j, k, 2) + &
&           temp3*(tauxz*ubard+ubar*tauxzd+tauyz*vbard+vbar*tauyzd+tauzz&
&           *wbard+wbar*tauzzd) + (temp2-q_z)*skd(i, j, k, 3) - temp1*&
&           q_xd - temp0*q_yd - temp*q_zd
          frhoe = temp6*temp7 + temp4*temp5 + temp2*temp3 - q_x*temp1 - &
&           q_y*temp0 - q_z*temp
! update the residuals of cell j and j+1.
          fwd(i, j, k, imx) = fwd(i, j, k, imx) - fmxd
          fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
          fwd(i, j, k, imy) = fwd(i, j, k, imy) - fmyd
          fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
          fwd(i, j, k, imz) = fwd(i, j, k, imz) - fmzd
          fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
          fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - frhoed
          fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
          fwd(i, j, k+1, imx) = fwd(i, j, k+1, imx) + fmxd
          fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fmx
          fwd(i, j, k+1, imy) = fwd(i, j, k+1, imy) + fmyd
          fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fmy
          fwd(i, j, k+1, imz) = fwd(i, j, k+1, imz) + fmzd
          fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fmz
          fwd(i, j, k+1, irhoe) = fwd(i, j, k+1, irhoe) + frhoed
          fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + frhoe
        end do
      end do
    end do
  end subroutine viscousfluxapprox_d
 
  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 forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: *w *fw
!   with respect to varying inputs: rhoinf pinfcorr *p *w *fw *radi
!                *radj *radk
!   rw status of diff variables: rhoinf:in pinfcorr:in *p:in *w:in-out
!                *fw:in-out *radi:in *radj:in *radk:in
!   plus diff mem management of: p:in w:in fw:in radi:in radj:in
!                radk:in
  subroutine invisciddissfluxscalarapprox_d()
!
!       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) :: arg1
    real(kind=realtype) :: temp
    real(kind=realtype) :: tempd
    real(kind=realtype) :: temp0
    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.
        sslimd = 0.001_realtype*pinfcorrd
        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.
        temp = rhoinf**gammainf
        if (rhoinf .le. 0.0_8 .and. (gammainf .eq. 0.0_8 .or. gammainf &
&           .ne. int(gammainf))) then
          tempd = 0.0_8
        else
          tempd = gammainf*rhoinf**(gammainf-1)*rhoinfd
        end if
        sslimd = 0.001_realtype*(pinfcorrd-pinfcorr*tempd/temp)/temp
        sslim = 0.001_realtype*(pinfcorr/temp)
      case default
        sslimd = 0.0_8
      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
        arg1 = -(disscontsharpness*(log10(totalr/totalr0)+&
&         disscontmidpoint))
        fis2 = rfil*(vis2+disscontmagnitude/(1+exp(arg1)))
      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
            temp = w(i, j, k, ivx)
            temp0 = w(i, j, k, irho)
            wd(i, j, k, ivx) = temp*wd(i, j, k, irho) + temp0*wd(i, j, k&
&             , ivx)
            w(i, j, k, ivx) = temp0*temp
            temp0 = w(i, j, k, ivy)
            temp = w(i, j, k, irho)
            wd(i, j, k, ivy) = temp0*wd(i, j, k, irho) + temp*wd(i, j, k&
&             , ivy)
            w(i, j, k, ivy) = temp*temp0
            temp0 = w(i, j, k, ivz)
            temp = w(i, j, k, irho)
            wd(i, j, k, ivz) = temp0*wd(i, j, k, irho) + temp*wd(i, j, k&
&             , ivz)
            w(i, j, k, ivz) = temp*temp0
            wd(i, j, k, irhoe) = wd(i, j, k, irhoe) + pd(i, j, k)
            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
          temp0 = w(0, j, k, ivx)
          temp = w(0, j, k, irho)
          wd(0, j, k, ivx) = temp0*wd(0, j, k, irho) + temp*wd(0, j, k, &
&           ivx)
          w(0, j, k, ivx) = temp*temp0
          temp0 = w(0, j, k, ivy)
          temp = w(0, j, k, irho)
          wd(0, j, k, ivy) = temp0*wd(0, j, k, irho) + temp*wd(0, j, k, &
&           ivy)
          w(0, j, k, ivy) = temp*temp0
          temp0 = w(0, j, k, ivz)
          temp = w(0, j, k, irho)
          wd(0, j, k, ivz) = temp0*wd(0, j, k, irho) + temp*wd(0, j, k, &
&           ivz)
          w(0, j, k, ivz) = temp*temp0
          wd(0, j, k, irhoe) = wd(0, j, k, irhoe) + pd(0, j, k)
          w(0, j, k, irhoe) = w(0, j, k, irhoe) + p(0, j, k)
          temp0 = w(1, j, k, ivx)
          temp = w(1, j, k, irho)
          wd(1, j, k, ivx) = temp0*wd(1, j, k, irho) + temp*wd(1, j, k, &
&           ivx)
          w(1, j, k, ivx) = temp*temp0
          temp0 = w(1, j, k, ivy)
          temp = w(1, j, k, irho)
          wd(1, j, k, ivy) = temp0*wd(1, j, k, irho) + temp*wd(1, j, k, &
&           ivy)
          w(1, j, k, ivy) = temp*temp0
          temp0 = w(1, j, k, ivz)
          temp = w(1, j, k, irho)
          wd(1, j, k, ivz) = temp0*wd(1, j, k, irho) + temp*wd(1, j, k, &
&           ivz)
          w(1, j, k, ivz) = temp*temp0
          wd(1, j, k, irhoe) = wd(1, j, k, irhoe) + pd(1, j, k)
          w(1, j, k, irhoe) = w(1, j, k, irhoe) + p(1, j, k)
          temp0 = w(ie, j, k, ivx)
          temp = w(ie, j, k, irho)
          wd(ie, j, k, ivx) = temp0*wd(ie, j, k, irho) + temp*wd(ie, j, &
&           k, ivx)
          w(ie, j, k, ivx) = temp*temp0
          temp0 = w(ie, j, k, ivy)
          temp = w(ie, j, k, irho)
          wd(ie, j, k, ivy) = temp0*wd(ie, j, k, irho) + temp*wd(ie, j, &
&           k, ivy)
          w(ie, j, k, ivy) = temp*temp0
          temp0 = w(ie, j, k, ivz)
          temp = w(ie, j, k, irho)
          wd(ie, j, k, ivz) = temp0*wd(ie, j, k, irho) + temp*wd(ie, j, &
&           k, ivz)
          w(ie, j, k, ivz) = temp*temp0
          wd(ie, j, k, irhoe) = wd(ie, j, k, irhoe) + pd(ie, j, k)
          w(ie, j, k, irhoe) = w(ie, j, k, irhoe) + p(ie, j, k)
          temp0 = w(ib, j, k, ivx)
          temp = w(ib, j, k, irho)
          wd(ib, j, k, ivx) = temp0*wd(ib, j, k, irho) + temp*wd(ib, j, &
&           k, ivx)
          w(ib, j, k, ivx) = temp*temp0
          temp0 = w(ib, j, k, ivy)
          temp = w(ib, j, k, irho)
          wd(ib, j, k, ivy) = temp0*wd(ib, j, k, irho) + temp*wd(ib, j, &
&           k, ivy)
          w(ib, j, k, ivy) = temp*temp0
          temp0 = w(ib, j, k, ivz)
          temp = w(ib, j, k, irho)
          wd(ib, j, k, ivz) = temp0*wd(ib, j, k, irho) + temp*wd(ib, j, &
&           k, ivz)
          w(ib, j, k, ivz) = temp*temp0
          wd(ib, j, k, irhoe) = wd(ib, j, k, irhoe) + pd(ib, j, k)
          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
          temp0 = w(i, 0, k, ivx)
          temp = w(i, 0, k, irho)
          wd(i, 0, k, ivx) = temp0*wd(i, 0, k, irho) + temp*wd(i, 0, k, &
&           ivx)
          w(i, 0, k, ivx) = temp*temp0
          temp0 = w(i, 0, k, ivy)
          temp = w(i, 0, k, irho)
          wd(i, 0, k, ivy) = temp0*wd(i, 0, k, irho) + temp*wd(i, 0, k, &
&           ivy)
          w(i, 0, k, ivy) = temp*temp0
          temp0 = w(i, 0, k, ivz)
          temp = w(i, 0, k, irho)
          wd(i, 0, k, ivz) = temp0*wd(i, 0, k, irho) + temp*wd(i, 0, k, &
&           ivz)
          w(i, 0, k, ivz) = temp*temp0
          wd(i, 0, k, irhoe) = wd(i, 0, k, irhoe) + pd(i, 0, k)
          w(i, 0, k, irhoe) = w(i, 0, k, irhoe) + p(i, 0, k)
          temp0 = w(i, 1, k, ivx)
          temp = w(i, 1, k, irho)
          wd(i, 1, k, ivx) = temp0*wd(i, 1, k, irho) + temp*wd(i, 1, k, &
&           ivx)
          w(i, 1, k, ivx) = temp*temp0
          temp0 = w(i, 1, k, ivy)
          temp = w(i, 1, k, irho)
          wd(i, 1, k, ivy) = temp0*wd(i, 1, k, irho) + temp*wd(i, 1, k, &
&           ivy)
          w(i, 1, k, ivy) = temp*temp0
          temp0 = w(i, 1, k, ivz)
          temp = w(i, 1, k, irho)
          wd(i, 1, k, ivz) = temp0*wd(i, 1, k, irho) + temp*wd(i, 1, k, &
&           ivz)
          w(i, 1, k, ivz) = temp*temp0
          wd(i, 1, k, irhoe) = wd(i, 1, k, irhoe) + pd(i, 1, k)
          w(i, 1, k, irhoe) = w(i, 1, k, irhoe) + p(i, 1, k)
          temp0 = w(i, je, k, ivx)
          temp = w(i, je, k, irho)
          wd(i, je, k, ivx) = temp0*wd(i, je, k, irho) + temp*wd(i, je, &
&           k, ivx)
          w(i, je, k, ivx) = temp*temp0
          temp0 = w(i, je, k, ivy)
          temp = w(i, je, k, irho)
          wd(i, je, k, ivy) = temp0*wd(i, je, k, irho) + temp*wd(i, je, &
&           k, ivy)
          w(i, je, k, ivy) = temp*temp0
          temp0 = w(i, je, k, ivz)
          temp = w(i, je, k, irho)
          wd(i, je, k, ivz) = temp0*wd(i, je, k, irho) + temp*wd(i, je, &
&           k, ivz)
          w(i, je, k, ivz) = temp*temp0
          wd(i, je, k, irhoe) = wd(i, je, k, irhoe) + pd(i, je, k)
          w(i, je, k, irhoe) = w(i, je, k, irhoe) + p(i, je, k)
          temp0 = w(i, jb, k, ivx)
          temp = w(i, jb, k, irho)
          wd(i, jb, k, ivx) = temp0*wd(i, jb, k, irho) + temp*wd(i, jb, &
&           k, ivx)
          w(i, jb, k, ivx) = temp*temp0
          temp0 = w(i, jb, k, ivy)
          temp = w(i, jb, k, irho)
          wd(i, jb, k, ivy) = temp0*wd(i, jb, k, irho) + temp*wd(i, jb, &
&           k, ivy)
          w(i, jb, k, ivy) = temp*temp0
          temp0 = w(i, jb, k, ivz)
          temp = w(i, jb, k, irho)
          wd(i, jb, k, ivz) = temp0*wd(i, jb, k, irho) + temp*wd(i, jb, &
&           k, ivz)
          w(i, jb, k, ivz) = temp*temp0
          wd(i, jb, k, irhoe) = wd(i, jb, k, irhoe) + pd(i, jb, k)
          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
            fwd(i, j, k, irho) = sfil*fwd(i, j, k, irho)
            fw(i, j, k, irho) = sfil*fw(i, j, k, irho)
            fwd(i, j, k, imx) = sfil*fwd(i, j, k, imx)
            fw(i, j, k, imx) = sfil*fw(i, j, k, imx)
            fwd(i, j, k, imy) = sfil*fwd(i, j, k, imy)
            fw(i, j, k, imy) = sfil*fw(i, j, k, imy)
            fwd(i, j, k, imz) = sfil*fwd(i, j, k, imz)
            fw(i, j, k, imz) = sfil*fw(i, j, k, imz)
            fwd(i, j, k, irhoe) = sfil*fwd(i, j, k, irhoe)
            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
          temp0 = (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)
          x1d = -(temp0*sslimd/(shocksensor(2, j, k)+two*shocksensor(1, &
&           j, k)+shocksensor(0, j, k)+sslim))
          x1 = temp0
          if (x1 .ge. 0.) then
            dss1d = x1d
            dss1 = x1
          else
            dss1d = -x1d
            dss1 = -x1
          end if
! loop in i-direction.
          do i=1,il
            temp0 = (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)
            x2d = -(temp0*sslimd/(shocksensor(i+2, j, k)+two*shocksensor&
&             (i+1, j, k)+shocksensor(i, j, k)+sslim))
            x2 = temp0
            if (x2 .ge. 0.) then
              dss2d = x2d
              dss2 = x2
            else
              dss2d = -x2d
              dss2 = -x2
            end if
! compute the dissipation coefficients for this face.
            ppor = zero
            if (pori(i, j, k) .eq. normalflux) ppor = half
            rradd = ppor*(radid(i, j, k)+radid(i+1, j, k))
            rrad = ppor*(radi(i, j, k)+radi(i+1, j, k))
            if (dss1 .lt. dss2) then
              y1d = dss2d
              y1 = dss2
            else
              y1d = dss1d
              y1 = dss1
            end if
            if (dssmax .gt. y1) then
              min1d = y1d
              min1 = y1
            else
              min1 = dssmax
              min1d = 0.0_8
            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
            dis2d = fis2*(min1*rradd+rrad*min1d) + sigma*fis4*rradd
            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.
            ddwd = wd(i+1, j, k, irho) - wd(i, j, k, irho)
            ddw = w(i+1, j, k, irho) - w(i, j, k, irho)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i+1, j, k, irho) = fwd(i+1, j, k, irho) + fsd
            fw(i+1, j, k, irho) = fw(i+1, j, k, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            ddwd = wd(i+1, j, k, ivx) - wd(i, j, k, ivx)
            ddw = w(i+1, j, k, ivx) - w(i, j, k, ivx)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i+1, j, k, imx) = fwd(i+1, j, k, imx) + fsd
            fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            ddwd = wd(i+1, j, k, ivy) - wd(i, j, k, ivy)
            ddw = w(i+1, j, k, ivy) - w(i, j, k, ivy)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i+1, j, k, imy) = fwd(i+1, j, k, imy) + fsd
            fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            ddwd = wd(i+1, j, k, ivz) - wd(i, j, k, ivz)
            ddw = w(i+1, j, k, ivz) - w(i, j, k, ivz)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i+1, j, k, imz) = fwd(i+1, j, k, imz) + fsd
            fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            ddwd = wd(i+1, j, k, irhoe) - wd(i, j, k, irhoe)
            ddw = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i+1, j, k, irhoe) = fwd(i+1, j, k, irhoe) + fsd
            fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dss1 to dss2 for the next face.
            dss1d = dss2d
            dss1 = dss2
          end do
        end do
      end do
!
!       dissipative fluxes in the j-direction.
!
      do k=2,kl
        do i=2,il
          temp0 = (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)
          x3d = -(temp0*sslimd/(shocksensor(i, 2, k)+two*shocksensor(i, &
&           1, k)+shocksensor(i, 0, k)+sslim))
          x3 = temp0
          if (x3 .ge. 0.) then
            dss1d = x3d
            dss1 = x3
          else
            dss1d = -x3d
            dss1 = -x3
          end if
! loop in j-direction.
          do j=1,jl
            temp0 = (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)
            x4d = -(temp0*sslimd/(shocksensor(i, j+2, k)+two*shocksensor&
&             (i, j+1, k)+shocksensor(i, j, k)+sslim))
            x4 = temp0
            if (x4 .ge. 0.) then
              dss2d = x4d
              dss2 = x4
            else
              dss2d = -x4d
              dss2 = -x4
            end if
! compute the dissipation coefficients for this face.
            ppor = zero
            if (porj(i, j, k) .eq. normalflux) ppor = half
            rradd = ppor*(radjd(i, j, k)+radjd(i, j+1, k))
            rrad = ppor*(radj(i, j, k)+radj(i, j+1, k))
            if (dss1 .lt. dss2) then
              y2d = dss2d
              y2 = dss2
            else
              y2d = dss1d
              y2 = dss1
            end if
            if (dssmax .gt. y2) then
              min2d = y2d
              min2 = y2
            else
              min2 = dssmax
              min2d = 0.0_8
            end if
! modification for fd preconditioner
            dis2d = fis2*(min2*rradd+rrad*min2d) + sigma*fis4*rradd
            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.
            ddwd = wd(i, j+1, k, irho) - wd(i, j, k, irho)
            ddw = w(i, j+1, k, irho) - w(i, j, k, irho)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i, j+1, k, irho) = fwd(i, j+1, k, irho) + fsd
            fw(i, j+1, k, irho) = fw(i, j+1, k, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            ddwd = wd(i, j+1, k, ivx) - wd(i, j, k, ivx)
            ddw = w(i, j+1, k, ivx) - w(i, j, k, ivx)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i, j+1, k, imx) = fwd(i, j+1, k, imx) + fsd
            fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            ddwd = wd(i, j+1, k, ivy) - wd(i, j, k, ivy)
            ddw = w(i, j+1, k, ivy) - w(i, j, k, ivy)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i, j+1, k, imy) = fwd(i, j+1, k, imy) + fsd
            fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            ddwd = wd(i, j+1, k, ivz) - wd(i, j, k, ivz)
            ddw = w(i, j+1, k, ivz) - w(i, j, k, ivz)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i, j+1, k, imz) = fwd(i, j+1, k, imz) + fsd
            fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            ddwd = wd(i, j+1, k, irhoe) - wd(i, j, k, irhoe)
            ddw = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i, j+1, k, irhoe) = fwd(i, j+1, k, irhoe) + fsd
            fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dss1 to dss2 for the next face.
            dss1d = dss2d
            dss1 = dss2
          end do
        end do
      end do
!
!       dissipative fluxes in the k-direction.
!
      do j=2,jl
        do i=2,il
          temp0 = (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)
          x5d = -(temp0*sslimd/(shocksensor(i, j, 2)+two*shocksensor(i, &
&           j, 1)+shocksensor(i, j, 0)+sslim))
          x5 = temp0
          if (x5 .ge. 0.) then
            dss1d = x5d
            dss1 = x5
          else
            dss1d = -x5d
            dss1 = -x5
          end if
! loop in k-direction.
          do k=1,kl
            temp0 = (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)
            x6d = -(temp0*sslimd/(shocksensor(i, j, k+2)+two*shocksensor&
&             (i, j, k+1)+shocksensor(i, j, k)+sslim))
            x6 = temp0
            if (x6 .ge. 0.) then
              dss2d = x6d
              dss2 = x6
            else
              dss2d = -x6d
              dss2 = -x6
            end if
! compute the dissipation coefficients for this face.
            ppor = zero
            if (pork(i, j, k) .eq. normalflux) ppor = half
            rradd = ppor*(radkd(i, j, k)+radkd(i, j, k+1))
            rrad = ppor*(radk(i, j, k)+radk(i, j, k+1))
            if (dss1 .lt. dss2) then
              y3d = dss2d
              y3 = dss2
            else
              y3d = dss1d
              y3 = dss1
            end if
            if (dssmax .gt. y3) then
              min3d = y3d
              min3 = y3
            else
              min3 = dssmax
              min3d = 0.0_8
            end if
! modification for fd preconditioner
            dis2d = fis2*(min3*rradd+rrad*min3d) + sigma*fis4*rradd
            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.
            ddwd = wd(i, j, k+1, irho) - wd(i, j, k, irho)
            ddw = w(i, j, k+1, irho) - w(i, j, k, irho)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i, j, k+1, irho) = fwd(i, j, k+1, irho) + fsd
            fw(i, j, k+1, irho) = fw(i, j, k+1, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            ddwd = wd(i, j, k+1, ivx) - wd(i, j, k, ivx)
            ddw = w(i, j, k+1, ivx) - w(i, j, k, ivx)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i, j, k+1, imx) = fwd(i, j, k+1, imx) + fsd
            fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            ddwd = wd(i, j, k+1, ivy) - wd(i, j, k, ivy)
            ddw = w(i, j, k+1, ivy) - w(i, j, k, ivy)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i, j, k+1, imy) = fwd(i, j, k+1, imy) + fsd
            fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            ddwd = wd(i, j, k+1, ivz) - wd(i, j, k, ivz)
            ddw = w(i, j, k+1, ivz) - w(i, j, k, ivz)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i, j, k+1, imz) = fwd(i, j, k+1, imz) + fsd
            fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            ddwd = wd(i, j, k+1, irhoe) - wd(i, j, k, irhoe)
            ddw = w(i, j, k+1, irhoe) - w(i, j, k, irhoe)
            fsd = ddw*dis2d + dis2*ddwd
            fs = dis2*ddw
            fwd(i, j, k+1, irhoe) = fwd(i, j, k+1, irhoe) + fsd
            fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dss1 to dss2 for the next face.
            dss1d = dss2d
            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
            temp0 = one/w(i, j, k, irho)
            rhoid = -(temp0*wd(i, j, k, irho)/w(i, j, k, irho))
            rhoi = temp0
            temp0 = w(i, j, k, ivx)
            wd(i, j, k, ivx) = rhoi*wd(i, j, k, ivx) + temp0*rhoid
            w(i, j, k, ivx) = temp0*rhoi
            temp0 = w(i, j, k, ivy)
            wd(i, j, k, ivy) = rhoi*wd(i, j, k, ivy) + temp0*rhoid
            w(i, j, k, ivy) = temp0*rhoi
            temp0 = w(i, j, k, ivz)
            wd(i, j, k, ivz) = rhoi*wd(i, j, k, ivz) + temp0*rhoid
            w(i, j, k, ivz) = temp0*rhoi
            wd(i, j, k, irhoe) = wd(i, j, k, irhoe) - pd(i, j, k)
            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
          temp0 = one/w(0, j, k, irho)
          rhoid = -(temp0*wd(0, j, k, irho)/w(0, j, k, irho))
          rhoi = temp0
          temp0 = w(0, j, k, ivx)
          wd(0, j, k, ivx) = rhoi*wd(0, j, k, ivx) + temp0*rhoid
          w(0, j, k, ivx) = temp0*rhoi
          temp0 = w(0, j, k, ivy)
          wd(0, j, k, ivy) = rhoi*wd(0, j, k, ivy) + temp0*rhoid
          w(0, j, k, ivy) = temp0*rhoi
          temp0 = w(0, j, k, ivz)
          wd(0, j, k, ivz) = rhoi*wd(0, j, k, ivz) + temp0*rhoid
          w(0, j, k, ivz) = temp0*rhoi
          wd(0, j, k, irhoe) = wd(0, j, k, irhoe) - pd(0, j, k)
          w(0, j, k, irhoe) = w(0, j, k, irhoe) - p(0, j, k)
          temp0 = one/w(1, j, k, irho)
          rhoid = -(temp0*wd(1, j, k, irho)/w(1, j, k, irho))
          rhoi = temp0
          temp0 = w(1, j, k, ivx)
          wd(1, j, k, ivx) = rhoi*wd(1, j, k, ivx) + temp0*rhoid
          w(1, j, k, ivx) = temp0*rhoi
          temp0 = w(1, j, k, ivy)
          wd(1, j, k, ivy) = rhoi*wd(1, j, k, ivy) + temp0*rhoid
          w(1, j, k, ivy) = temp0*rhoi
          temp0 = w(1, j, k, ivz)
          wd(1, j, k, ivz) = rhoi*wd(1, j, k, ivz) + temp0*rhoid
          w(1, j, k, ivz) = temp0*rhoi
          wd(1, j, k, irhoe) = wd(1, j, k, irhoe) - pd(1, j, k)
          w(1, j, k, irhoe) = w(1, j, k, irhoe) - p(1, j, k)
          temp0 = one/w(ie, j, k, irho)
          rhoid = -(temp0*wd(ie, j, k, irho)/w(ie, j, k, irho))
          rhoi = temp0
          temp0 = w(ie, j, k, ivx)
          wd(ie, j, k, ivx) = rhoi*wd(ie, j, k, ivx) + temp0*rhoid
          w(ie, j, k, ivx) = temp0*rhoi
          temp0 = w(ie, j, k, ivy)
          wd(ie, j, k, ivy) = rhoi*wd(ie, j, k, ivy) + temp0*rhoid
          w(ie, j, k, ivy) = temp0*rhoi
          temp0 = w(ie, j, k, ivz)
          wd(ie, j, k, ivz) = rhoi*wd(ie, j, k, ivz) + temp0*rhoid
          w(ie, j, k, ivz) = temp0*rhoi
          wd(ie, j, k, irhoe) = wd(ie, j, k, irhoe) - pd(ie, j, k)
          w(ie, j, k, irhoe) = w(ie, j, k, irhoe) - p(ie, j, k)
          temp0 = one/w(ib, j, k, irho)
          rhoid = -(temp0*wd(ib, j, k, irho)/w(ib, j, k, irho))
          rhoi = temp0
          temp0 = w(ib, j, k, ivx)
          wd(ib, j, k, ivx) = rhoi*wd(ib, j, k, ivx) + temp0*rhoid
          w(ib, j, k, ivx) = temp0*rhoi
          temp0 = w(ib, j, k, ivy)
          wd(ib, j, k, ivy) = rhoi*wd(ib, j, k, ivy) + temp0*rhoid
          w(ib, j, k, ivy) = temp0*rhoi
          temp0 = w(ib, j, k, ivz)
          wd(ib, j, k, ivz) = rhoi*wd(ib, j, k, ivz) + temp0*rhoid
          w(ib, j, k, ivz) = temp0*rhoi
          wd(ib, j, k, irhoe) = wd(ib, j, k, irhoe) - pd(ib, j, k)
          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
          temp0 = one/w(i, 0, k, irho)
          rhoid = -(temp0*wd(i, 0, k, irho)/w(i, 0, k, irho))
          rhoi = temp0
          temp0 = w(i, 0, k, ivx)
          wd(i, 0, k, ivx) = rhoi*wd(i, 0, k, ivx) + temp0*rhoid
          w(i, 0, k, ivx) = temp0*rhoi
          temp0 = w(i, 0, k, ivy)
          wd(i, 0, k, ivy) = rhoi*wd(i, 0, k, ivy) + temp0*rhoid
          w(i, 0, k, ivy) = temp0*rhoi
          temp0 = w(i, 0, k, ivz)
          wd(i, 0, k, ivz) = rhoi*wd(i, 0, k, ivz) + temp0*rhoid
          w(i, 0, k, ivz) = temp0*rhoi
          wd(i, 0, k, irhoe) = wd(i, 0, k, irhoe) - pd(i, 0, k)
          w(i, 0, k, irhoe) = w(i, 0, k, irhoe) - p(i, 0, k)
          temp0 = one/w(i, 1, k, irho)
          rhoid = -(temp0*wd(i, 1, k, irho)/w(i, 1, k, irho))
          rhoi = temp0
          temp0 = w(i, 1, k, ivx)
          wd(i, 1, k, ivx) = rhoi*wd(i, 1, k, ivx) + temp0*rhoid
          w(i, 1, k, ivx) = temp0*rhoi
          temp0 = w(i, 1, k, ivy)
          wd(i, 1, k, ivy) = rhoi*wd(i, 1, k, ivy) + temp0*rhoid
          w(i, 1, k, ivy) = temp0*rhoi
          temp0 = w(i, 1, k, ivz)
          wd(i, 1, k, ivz) = rhoi*wd(i, 1, k, ivz) + temp0*rhoid
          w(i, 1, k, ivz) = temp0*rhoi
          wd(i, 1, k, irhoe) = wd(i, 1, k, irhoe) - pd(i, 1, k)
          w(i, 1, k, irhoe) = w(i, 1, k, irhoe) - p(i, 1, k)
          temp0 = one/w(i, je, k, irho)
          rhoid = -(temp0*wd(i, je, k, irho)/w(i, je, k, irho))
          rhoi = temp0
          temp0 = w(i, je, k, ivx)
          wd(i, je, k, ivx) = rhoi*wd(i, je, k, ivx) + temp0*rhoid
          w(i, je, k, ivx) = temp0*rhoi
          temp0 = w(i, je, k, ivy)
          wd(i, je, k, ivy) = rhoi*wd(i, je, k, ivy) + temp0*rhoid
          w(i, je, k, ivy) = temp0*rhoi
          temp0 = w(i, je, k, ivz)
          wd(i, je, k, ivz) = rhoi*wd(i, je, k, ivz) + temp0*rhoid
          w(i, je, k, ivz) = temp0*rhoi
          wd(i, je, k, irhoe) = wd(i, je, k, irhoe) - pd(i, je, k)
          w(i, je, k, irhoe) = w(i, je, k, irhoe) - p(i, je, k)
          temp0 = one/w(i, jb, k, irho)
          rhoid = -(temp0*wd(i, jb, k, irho)/w(i, jb, k, irho))
          rhoi = temp0
          temp0 = w(i, jb, k, ivx)
          wd(i, jb, k, ivx) = rhoi*wd(i, jb, k, ivx) + temp0*rhoid
          w(i, jb, k, ivx) = temp0*rhoi
          temp0 = w(i, jb, k, ivy)
          wd(i, jb, k, ivy) = rhoi*wd(i, jb, k, ivy) + temp0*rhoid
          w(i, jb, k, ivy) = temp0*rhoi
          temp0 = w(i, jb, k, ivz)
          wd(i, jb, k, ivz) = rhoi*wd(i, jb, k, ivz) + temp0*rhoid
          w(i, jb, k, ivz) = temp0*rhoi
          wd(i, jb, k, irhoe) = wd(i, jb, k, irhoe) - pd(i, jb, k)
          w(i, jb, k, irhoe) = w(i, jb, k, irhoe) - p(i, jb, k)
        end do
      end do
    end if
  end subroutine invisciddissfluxscalarapprox_d
 
  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
    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
!===============================================================
      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
        arg1 = -(disscontsharpness*(log10(totalr/totalr0)+&
&         disscontmidpoint))
        fis2 = rfil*(vis2+disscontmagnitude/(1+exp(arg1)))
      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 forward (tangent) mode (with options i4 dr8 r8):
!   variations   of useful results: *fw
!   with respect to varying inputs: pinfcorr *p *sfacei *sfacej
!                *sfacek *w *si *sj *sk *fw
!   rw status of diff variables: pinfcorr:in *p:in *sfacei:in *sfacej:in
!                *sfacek:in *w:in *si:in *sj:in *sk:in *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_d()
!
!       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_d, 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) :: arg1
    real(kind=realtype) :: arg1d
    real(kind=realtype) :: temp
    real(kind=realtype) :: temp0
    real(kind=realtype) :: temp1
    real(kind=realtype) :: temp2
    real(kind=realtype) :: temp3
    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.
      plimd = 0.001_realtype*pinfcorrd
      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
            fwd(i, j, k, irho) = sfil*fwd(i, j, k, irho)
            fw(i, j, k, irho) = sfil*fw(i, j, k, irho)
            fwd(i, j, k, imx) = sfil*fwd(i, j, k, imx)
            fw(i, j, k, imx) = sfil*fw(i, j, k, imx)
            fwd(i, j, k, imy) = sfil*fwd(i, j, k, imy)
            fw(i, j, k, imy) = sfil*fw(i, j, k, imy)
            fwd(i, j, k, imz) = sfil*fwd(i, j, k, imz)
            fw(i, j, k, imz) = sfil*fw(i, j, k, imz)
            fwd(i, j, k, irhoe) = sfil*fwd(i, j, k, irhoe)
            fw(i, j, k, irhoe) = sfil*fw(i, j, k, irhoe)
          end do
        end do
      end do
      sfaced = 0.0_8
!
!       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
          temp = (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)
          x1d = -(temp*plimd/(omega*(shocksensor(2, j, k)+two*&
&           shocksensor(1, j, k)+shocksensor(0, j, k))+oneminomega*(abs1&
&           +abs7)+plim))
          x1 = temp
          if (x1 .ge. 0.) then
            dp1d = x1d
            dp1 = x1
          else
            dp1d = -x1d
            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
            temp = (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)
            x2d = -(temp*plimd/(omega*(shocksensor(i+2, j, k)+two*&
&             shocksensor(i+1, j, k)+shocksensor(i, j, k))+oneminomega*(&
&             abs2+abs8)+plim))
            x2 = temp
            if (x2 .ge. 0.) then
              dp2d = x2d
              dp2 = x2
            else
              dp2d = -x2d
              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
              y1d = dp2d
              y1 = dp2
            else
              y1d = dp1d
              y1 = dp1
            end if
            if (dpmax .gt. y1) then
              min1d = y1d
              min1 = y1
            else
              min1 = dpmax
              min1d = 0.0_8
            end if
            dis2d = fis2*ppor*min1d
            dis2 = fis2*ppor*min1 + sigma*fis4*ppor
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            ddwd = wd(i+1, j, k, irho) - wd(i, j, k, irho)
            ddw = w(i+1, j, k, irho) - w(i, j, k, irho)
            drd = ddw*dis2d + dis2*ddwd
            dr = dis2*ddw
            temp = w(i+1, j, k, ivx)
            temp0 = w(i+1, j, k, irho)
            temp1 = w(i, j, k, ivx)
            temp2 = w(i, j, k, irho)
            ddwd = temp*wd(i+1, j, k, irho) + temp0*wd(i+1, j, k, ivx) -&
&             temp1*wd(i, j, k, irho) - temp2*wd(i, j, k, ivx)
            ddw = temp0*temp - temp2*temp1
            drud = ddw*dis2d + dis2*ddwd
            dru = dis2*ddw
            temp2 = w(i+1, j, k, ivy)
            temp1 = w(i+1, j, k, irho)
            temp0 = w(i, j, k, ivy)
            temp = w(i, j, k, irho)
            ddwd = temp2*wd(i+1, j, k, irho) + temp1*wd(i+1, j, k, ivy) &
&             - temp0*wd(i, j, k, irho) - temp*wd(i, j, k, ivy)
            ddw = temp1*temp2 - temp*temp0
            drvd = ddw*dis2d + dis2*ddwd
            drv = dis2*ddw
            temp2 = w(i+1, j, k, ivz)
            temp1 = w(i+1, j, k, irho)
            temp0 = w(i, j, k, ivz)
            temp = w(i, j, k, irho)
            ddwd = temp2*wd(i+1, j, k, irho) + temp1*wd(i+1, j, k, ivz) &
&             - temp0*wd(i, j, k, irho) - temp*wd(i, j, k, ivz)
            ddw = temp1*temp2 - temp*temp0
            drwd = ddw*dis2d + dis2*ddwd
            drw = dis2*ddw
            ddwd = wd(i+1, j, k, irhoe) - wd(i, j, k, irhoe)
            ddw = w(i+1, j, k, irhoe) - w(i, j, k, irhoe)
            dred = ddw*dis2d + dis2*ddwd
            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
              temp2 = w(i+1, j, k, itu1)
              temp1 = w(i+1, j, k, irho)
              temp0 = w(i, j, k, itu1)
              temp = w(i, j, k, irho)
              ddwd = temp2*wd(i+1, j, k, irho) + temp1*wd(i+1, j, k, &
&               itu1) - temp0*wd(i, j, k, irho) - temp*wd(i, j, k, itu1)
              ddw = temp1*temp2 - temp*temp0
              drkd = ddw*dis2d + dis2*ddwd
              drk = dis2*ddw
              kavgd = half*(wd(i, j, k, itu1)+wd(i+1, j, k, itu1))
              kavg = half*(w(i, j, k, itu1)+w(i+1, j, k, itu1))
            else
              drk = zero
              kavg = zero
              kavgd = 0.0_8
              drkd = 0.0_8
            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.
            uavgd = half*(wd(i+1, j, k, ivx)+wd(i, j, k, ivx))
            uavg = half*(w(i+1, j, k, ivx)+w(i, j, k, ivx))
            vavgd = half*(wd(i+1, j, k, ivy)+wd(i, j, k, ivy))
            vavg = half*(w(i+1, j, k, ivy)+w(i, j, k, ivy))
            wavgd = half*(wd(i+1, j, k, ivz)+wd(i, j, k, ivz))
            wavg = half*(w(i+1, j, k, ivz)+w(i, j, k, ivz))
            temp2 = gamma(i+1, j, k)
            temp1 = w(i+1, j, k, irho)
            temp0 = p(i+1, j, k)/temp1
            temp = w(i, j, k, irho)
            temp3 = p(i, j, k)/temp
            a2avgd = half*(temp2*(pd(i+1, j, k)-temp0*wd(i+1, j, k, irho&
&             ))/temp1+gamma(i, j, k)*(pd(i, j, k)-temp3*wd(i, j, k, &
&             irho))/temp)
            a2avg = half*(temp2*temp0+gamma(i, j, k)*temp3)
            sxd = sid(i, j, k, 1)
            sx = si(i, j, k, 1)
            syd = sid(i, j, k, 2)
            sy = si(i, j, k, 2)
            szd = sid(i, j, k, 3)
            sz = si(i, j, k, 3)
            arg1d = 2*sx*sxd + 2*sy*syd + 2*sz*szd
            arg1 = sx**2 + sy**2 + sz**2
            temp3 = sqrt(arg1)
            if (arg1 .eq. 0.0_8) then
              aread = 0.0_8
            else
              aread = arg1d/(2.0*temp3)
            end if
            area = temp3
            if (1.e-25_realtype .lt. area) then
              max1d = aread
              max1 = area
            else
              max1 = 1.e-25_realtype
              max1d = 0.0_8
            end if
            tmpd = -(one*max1d/max1**2)
            tmp = one/max1
            sxd = tmp*sxd + sx*tmpd
            sx = sx*tmp
            syd = tmp*syd + sy*tmpd
            sy = sy*tmp
            szd = tmp*szd + sz*tmpd
            sz = sz*tmp
            alphaavgd = half*(2*uavg*uavgd+2*vavg*vavgd+2*wavg*wavgd)
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            havgd = alphaavgd + ovgm1*(a2avgd-gm53*kavgd)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            temp3 = sqrt(a2avg)
            if (a2avg .eq. 0.0_8) then
              aavgd = 0.0_8
            else
              aavgd = a2avgd/(2.0*temp3)
            end if
            aavg = temp3
            unavgd = sx*uavgd + uavg*sxd + sy*vavgd + vavg*syd + sz*&
&             wavgd + wavg*szd
            unavg = uavg*sx + vavg*sy + wavg*sz
            ovaavgd = -(one*aavgd/aavg**2)
            ovaavg = one/aavg
            ova2avgd = -(one*a2avgd/a2avg**2)
            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
              sfaced = tmp*sfaceid(i, j, k) + sfacei(i, j, k)*tmpd
              sface = sfacei(i, j, k)*tmp
            end if
            if (unavg - sface + aavg .ge. 0.) then
              lam1d = unavgd - sfaced + aavgd
              lam1 = unavg - sface + aavg
            else
              lam1d = sfaced - unavgd - aavgd
              lam1 = -(unavg-sface+aavg)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2d = unavgd - sfaced - aavgd
              lam2 = unavg - sface - aavg
            else
              lam2d = sfaced - unavgd + aavgd
              lam2 = -(unavg-sface-aavg)
            end if
            if (unavg - sface .ge. 0.) then
              lam3d = unavgd - sfaced
              lam3 = unavg - sface
            else
              lam3d = sfaced - unavgd
              lam3 = -(unavg-sface)
            end if
            rradd = lam3d + aavgd
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              lam1d = epsacoustic*rradd
              lam1 = epsacoustic*rrad
            else
              lam1 = lam1
            end if
            if (lam2 .lt. epsacoustic*rrad) then
              lam2d = epsacoustic*rradd
              lam2 = epsacoustic*rrad
            else
              lam2 = lam2
            end if
            if (lam3 .lt. epsshear*rrad) then
              lam3d = epsshear*rradd
              lam3 = epsshear*rrad
            else
              lam3 = lam3
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            lam1d = area*lam1d + lam1*aread
            lam1 = lam1*area
            lam2d = area*lam2d + lam2*aread
            lam2 = lam2*area
            lam3d = area*lam3d + lam3*aread
            lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1d = half*(lam1d+lam2d)
            abv1 = half*(lam1+lam2)
            abv2d = half*(lam1d-lam2d)
            abv2 = half*(lam1-lam2)
            abv3d = abv1d - lam3d
            abv3 = abv1 - lam3
            abv4d = gm1*(dr*alphaavgd+alphaavg*drd-dru*uavgd-uavg*drud-&
&             drv*vavgd-vavg*drvd+dred-drw*wavgd-wavg*drwd) - gm53*drkd
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
            abv5d = dru*sxd + sx*drud + drv*syd + sy*drvd + drw*szd + sz&
&             *drwd - dr*unavgd - unavg*drd
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            abv6d = ova2avg*(abv4*abv3d+abv3*abv4d) + abv3*abv4*ova2avgd&
&             + ovaavg*(abv5*abv2d+abv2*abv5d) + abv2*abv5*ovaavgd
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7d = ovaavg*(abv4*abv2d+abv2*abv4d) + abv2*abv4*ovaavgd +&
&             abv5*abv3d + abv3*abv5d
            abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
            fsd = dr*lam3d + lam3*drd + abv6d
            fs = lam3*dr + abv6
            fwd(i+1, j, k, irho) = fwd(i+1, j, k, irho) + fsd
            fw(i+1, j, k, irho) = fw(i+1, j, k, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            fsd = dru*lam3d + lam3*drud + abv6*uavgd + uavg*abv6d + abv7&
&             *sxd + sx*abv7d
            fs = lam3*dru + uavg*abv6 + sx*abv7
            fwd(i+1, j, k, imx) = fwd(i+1, j, k, imx) + fsd
            fw(i+1, j, k, imx) = fw(i+1, j, k, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            fsd = drv*lam3d + lam3*drvd + abv6*vavgd + vavg*abv6d + abv7&
&             *syd + sy*abv7d
            fs = lam3*drv + vavg*abv6 + sy*abv7
            fwd(i+1, j, k, imy) = fwd(i+1, j, k, imy) + fsd
            fw(i+1, j, k, imy) = fw(i+1, j, k, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            fsd = drw*lam3d + lam3*drwd + abv6*wavgd + wavg*abv6d + abv7&
&             *szd + sz*abv7d
            fs = lam3*drw + wavg*abv6 + sz*abv7
            fwd(i+1, j, k, imz) = fwd(i+1, j, k, imz) + fsd
            fw(i+1, j, k, imz) = fw(i+1, j, k, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            fsd = dre*lam3d + lam3*dred + abv6*havgd + havg*abv6d + abv7&
&             *unavgd + unavg*abv7d
            fs = lam3*dre + havg*abv6 + unavg*abv7
            fwd(i+1, j, k, irhoe) = fwd(i+1, j, k, irhoe) + fsd
            fw(i+1, j, k, irhoe) = fw(i+1, j, k, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dp1 to dp2 for the next face.
            dp1d = dp2d
            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
          temp3 = (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)
          x3d = -(temp3*plimd/(omega*(shocksensor(i, 2, k)+two*&
&           shocksensor(i, 1, k)+shocksensor(i, 0, k))+oneminomega*(abs3&
&           +abs9)+plim))
          x3 = temp3
          if (x3 .ge. 0.) then
            dp1d = x3d
            dp1 = x3
          else
            dp1d = -x3d
            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
            temp3 = (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)
            x4d = -(temp3*plimd/(omega*(shocksensor(i, j+2, k)+two*&
&             shocksensor(i, j+1, k)+shocksensor(i, j, k))+oneminomega*(&
&             abs4+abs10)+plim))
            x4 = temp3
            if (x4 .ge. 0.) then
              dp2d = x4d
              dp2 = x4
            else
              dp2d = -x4d
              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
              y2d = dp2d
              y2 = dp2
            else
              y2d = dp1d
              y2 = dp1
            end if
            if (dpmax .gt. y2) then
              min2d = y2d
              min2 = y2
            else
              min2 = dpmax
              min2d = 0.0_8
            end if
            dis2d = fis2*ppor*min2d
            dis2 = fis2*ppor*min2 + sigma*fis4*ppor
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            ddwd = wd(i, j+1, k, irho) - wd(i, j, k, irho)
            ddw = w(i, j+1, k, irho) - w(i, j, k, irho)
            drd = ddw*dis2d + dis2*ddwd
            dr = dis2*ddw
            temp3 = w(i, j+1, k, ivx)
            temp2 = w(i, j+1, k, irho)
            temp1 = w(i, j, k, ivx)
            temp0 = w(i, j, k, irho)
            ddwd = temp3*wd(i, j+1, k, irho) + temp2*wd(i, j+1, k, ivx) &
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivx)
            ddw = temp2*temp3 - temp0*temp1
            drud = ddw*dis2d + dis2*ddwd
            dru = dis2*ddw
            temp3 = w(i, j+1, k, ivy)
            temp2 = w(i, j+1, k, irho)
            temp1 = w(i, j, k, ivy)
            temp0 = w(i, j, k, irho)
            ddwd = temp3*wd(i, j+1, k, irho) + temp2*wd(i, j+1, k, ivy) &
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivy)
            ddw = temp2*temp3 - temp0*temp1
            drvd = ddw*dis2d + dis2*ddwd
            drv = dis2*ddw
            temp3 = w(i, j+1, k, ivz)
            temp2 = w(i, j+1, k, irho)
            temp1 = w(i, j, k, ivz)
            temp0 = w(i, j, k, irho)
            ddwd = temp3*wd(i, j+1, k, irho) + temp2*wd(i, j+1, k, ivz) &
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivz)
            ddw = temp2*temp3 - temp0*temp1
            drwd = ddw*dis2d + dis2*ddwd
            drw = dis2*ddw
            ddwd = wd(i, j+1, k, irhoe) - wd(i, j, k, irhoe)
            ddw = w(i, j+1, k, irhoe) - w(i, j, k, irhoe)
            dred = ddw*dis2d + dis2*ddwd
            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
              temp3 = w(i, j+1, k, itu1)
              temp2 = w(i, j+1, k, irho)
              temp1 = w(i, j, k, itu1)
              temp0 = w(i, j, k, irho)
              ddwd = temp3*wd(i, j+1, k, irho) + temp2*wd(i, j+1, k, &
&               itu1) - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, itu1&
&               )
              ddw = temp2*temp3 - temp0*temp1
              drkd = ddw*dis2d + dis2*ddwd
              drk = dis2*ddw
              kavgd = half*(wd(i, j, k, itu1)+wd(i, j+1, k, itu1))
              kavg = half*(w(i, j, k, itu1)+w(i, j+1, k, itu1))
            else
              drk = zero
              kavg = zero
              kavgd = 0.0_8
              drkd = 0.0_8
            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.
            uavgd = half*(wd(i, j+1, k, ivx)+wd(i, j, k, ivx))
            uavg = half*(w(i, j+1, k, ivx)+w(i, j, k, ivx))
            vavgd = half*(wd(i, j+1, k, ivy)+wd(i, j, k, ivy))
            vavg = half*(w(i, j+1, k, ivy)+w(i, j, k, ivy))
            wavgd = half*(wd(i, j+1, k, ivz)+wd(i, j, k, ivz))
            wavg = half*(w(i, j+1, k, ivz)+w(i, j, k, ivz))
            temp3 = gamma(i, j+1, k)
            temp2 = w(i, j+1, k, irho)
            temp1 = p(i, j+1, k)/temp2
            temp0 = w(i, j, k, irho)
            temp = p(i, j, k)/temp0
            a2avgd = half*(temp3*(pd(i, j+1, k)-temp1*wd(i, j+1, k, irho&
&             ))/temp2+gamma(i, j, k)*(pd(i, j, k)-temp*wd(i, j, k, irho&
&             ))/temp0)
            a2avg = half*(temp3*temp1+gamma(i, j, k)*temp)
            sxd = sjd(i, j, k, 1)
            sx = sj(i, j, k, 1)
            syd = sjd(i, j, k, 2)
            sy = sj(i, j, k, 2)
            szd = sjd(i, j, k, 3)
            sz = sj(i, j, k, 3)
            arg1d = 2*sx*sxd + 2*sy*syd + 2*sz*szd
            arg1 = sx**2 + sy**2 + sz**2
            temp3 = sqrt(arg1)
            if (arg1 .eq. 0.0_8) then
              aread = 0.0_8
            else
              aread = arg1d/(2.0*temp3)
            end if
            area = temp3
            if (1.e-25_realtype .lt. area) then
              max2d = aread
              max2 = area
            else
              max2 = 1.e-25_realtype
              max2d = 0.0_8
            end if
            tmpd = -(one*max2d/max2**2)
            tmp = one/max2
            sxd = tmp*sxd + sx*tmpd
            sx = sx*tmp
            syd = tmp*syd + sy*tmpd
            sy = sy*tmp
            szd = tmp*szd + sz*tmpd
            sz = sz*tmp
            alphaavgd = half*(2*uavg*uavgd+2*vavg*vavgd+2*wavg*wavgd)
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            havgd = alphaavgd + ovgm1*(a2avgd-gm53*kavgd)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            temp3 = sqrt(a2avg)
            if (a2avg .eq. 0.0_8) then
              aavgd = 0.0_8
            else
              aavgd = a2avgd/(2.0*temp3)
            end if
            aavg = temp3
            unavgd = sx*uavgd + uavg*sxd + sy*vavgd + vavg*syd + sz*&
&             wavgd + wavg*szd
            unavg = uavg*sx + vavg*sy + wavg*sz
            ovaavgd = -(one*aavgd/aavg**2)
            ovaavg = one/aavg
            ova2avgd = -(one*a2avgd/a2avg**2)
            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
              sfaced = tmp*sfacejd(i, j, k) + sfacej(i, j, k)*tmpd
              sface = sfacej(i, j, k)*tmp
            end if
            if (unavg - sface + aavg .ge. 0.) then
              lam1d = unavgd - sfaced + aavgd
              lam1 = unavg - sface + aavg
            else
              lam1d = sfaced - unavgd - aavgd
              lam1 = -(unavg-sface+aavg)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2d = unavgd - sfaced - aavgd
              lam2 = unavg - sface - aavg
            else
              lam2d = sfaced - unavgd + aavgd
              lam2 = -(unavg-sface-aavg)
            end if
            if (unavg - sface .ge. 0.) then
              lam3d = unavgd - sfaced
              lam3 = unavg - sface
            else
              lam3d = sfaced - unavgd
              lam3 = -(unavg-sface)
            end if
            rradd = lam3d + aavgd
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              lam1d = epsacoustic*rradd
              lam1 = epsacoustic*rrad
            else
              lam1 = lam1
            end if
            if (lam2 .lt. epsacoustic*rrad) then
              lam2d = epsacoustic*rradd
              lam2 = epsacoustic*rrad
            else
              lam2 = lam2
            end if
            if (lam3 .lt. epsshear*rrad) then
              lam3d = epsshear*rradd
              lam3 = epsshear*rrad
            else
              lam3 = lam3
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            lam1d = area*lam1d + lam1*aread
            lam1 = lam1*area
            lam2d = area*lam2d + lam2*aread
            lam2 = lam2*area
            lam3d = area*lam3d + lam3*aread
            lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1d = half*(lam1d+lam2d)
            abv1 = half*(lam1+lam2)
            abv2d = half*(lam1d-lam2d)
            abv2 = half*(lam1-lam2)
            abv3d = abv1d - lam3d
            abv3 = abv1 - lam3
            abv4d = gm1*(dr*alphaavgd+alphaavg*drd-dru*uavgd-uavg*drud-&
&             drv*vavgd-vavg*drvd+dred-drw*wavgd-wavg*drwd) - gm53*drkd
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
            abv5d = dru*sxd + sx*drud + drv*syd + sy*drvd + drw*szd + sz&
&             *drwd - dr*unavgd - unavg*drd
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            abv6d = ova2avg*(abv4*abv3d+abv3*abv4d) + abv3*abv4*ova2avgd&
&             + ovaavg*(abv5*abv2d+abv2*abv5d) + abv2*abv5*ovaavgd
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7d = ovaavg*(abv4*abv2d+abv2*abv4d) + abv2*abv4*ovaavgd +&
&             abv5*abv3d + abv3*abv5d
            abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
            fsd = dr*lam3d + lam3*drd + abv6d
            fs = lam3*dr + abv6
            fwd(i, j+1, k, irho) = fwd(i, j+1, k, irho) + fsd
            fw(i, j+1, k, irho) = fw(i, j+1, k, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            fsd = dru*lam3d + lam3*drud + abv6*uavgd + uavg*abv6d + abv7&
&             *sxd + sx*abv7d
            fs = lam3*dru + uavg*abv6 + sx*abv7
            fwd(i, j+1, k, imx) = fwd(i, j+1, k, imx) + fsd
            fw(i, j+1, k, imx) = fw(i, j+1, k, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            fsd = drv*lam3d + lam3*drvd + abv6*vavgd + vavg*abv6d + abv7&
&             *syd + sy*abv7d
            fs = lam3*drv + vavg*abv6 + sy*abv7
            fwd(i, j+1, k, imy) = fwd(i, j+1, k, imy) + fsd
            fw(i, j+1, k, imy) = fw(i, j+1, k, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            fsd = drw*lam3d + lam3*drwd + abv6*wavgd + wavg*abv6d + abv7&
&             *szd + sz*abv7d
            fs = lam3*drw + wavg*abv6 + sz*abv7
            fwd(i, j+1, k, imz) = fwd(i, j+1, k, imz) + fsd
            fw(i, j+1, k, imz) = fw(i, j+1, k, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            fsd = dre*lam3d + lam3*dred + abv6*havgd + havg*abv6d + abv7&
&             *unavgd + unavg*abv7d
            fs = lam3*dre + havg*abv6 + unavg*abv7
            fwd(i, j+1, k, irhoe) = fwd(i, j+1, k, irhoe) + fsd
            fw(i, j+1, k, irhoe) = fw(i, j+1, k, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dp1 to dp2 for the next face.
            dp1d = dp2d
            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
          temp3 = (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)
          x5d = -(temp3*plimd/(omega*(shocksensor(i, j, 2)+two*&
&           shocksensor(i, j, 1)+shocksensor(i, j, 0))+oneminomega*(abs5&
&           +abs11)+plim))
          x5 = temp3
          if (x5 .ge. 0.) then
            dp1d = x5d
            dp1 = x5
          else
            dp1d = -x5d
            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
            temp3 = (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)
            x6d = -(temp3*plimd/(omega*(shocksensor(i, j, k+2)+two*&
&             shocksensor(i, j, k+1)+shocksensor(i, j, k))+oneminomega*(&
&             abs6+abs12)+plim))
            x6 = temp3
            if (x6 .ge. 0.) then
              dp2d = x6d
              dp2 = x6
            else
              dp2d = -x6d
              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
              y3d = dp2d
              y3 = dp2
            else
              y3d = dp1d
              y3 = dp1
            end if
            if (dpmax .gt. y3) then
              min3d = y3d
              min3 = y3
            else
              min3 = dpmax
              min3d = 0.0_8
            end if
            dis2d = fis2*ppor*min3d
            dis2 = fis2*ppor*min3 + sigma*fis4*ppor
! construct the vector of the first and third differences
! multiplied by the appropriate constants.
            ddwd = wd(i, j, k+1, irho) - wd(i, j, k, irho)
            ddw = w(i, j, k+1, irho) - w(i, j, k, irho)
            drd = ddw*dis2d + dis2*ddwd
            dr = dis2*ddw
            temp3 = w(i, j, k+1, ivx)
            temp2 = w(i, j, k+1, irho)
            temp1 = w(i, j, k, ivx)
            temp0 = w(i, j, k, irho)
            ddwd = temp3*wd(i, j, k+1, irho) + temp2*wd(i, j, k+1, ivx) &
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivx)
            ddw = temp2*temp3 - temp0*temp1
            drud = ddw*dis2d + dis2*ddwd
            dru = dis2*ddw
            temp3 = w(i, j, k+1, ivy)
            temp2 = w(i, j, k+1, irho)
            temp1 = w(i, j, k, ivy)
            temp0 = w(i, j, k, irho)
            ddwd = temp3*wd(i, j, k+1, irho) + temp2*wd(i, j, k+1, ivy) &
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivy)
            ddw = temp2*temp3 - temp0*temp1
            drvd = ddw*dis2d + dis2*ddwd
            drv = dis2*ddw
            temp3 = w(i, j, k+1, ivz)
            temp2 = w(i, j, k+1, irho)
            temp1 = w(i, j, k, ivz)
            temp0 = w(i, j, k, irho)
            ddwd = temp3*wd(i, j, k+1, irho) + temp2*wd(i, j, k+1, ivz) &
&             - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, ivz)
            ddw = temp2*temp3 - temp0*temp1
            drwd = ddw*dis2d + dis2*ddwd
            drw = dis2*ddw
            ddwd = wd(i, j, k+1, irhoe) - wd(i, j, k, irhoe)
            ddw = w(i, j, k+1, irhoe) - w(i, j, k, irhoe)
            dred = ddw*dis2d + dis2*ddwd
            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
              temp3 = w(i, j, k+1, itu1)
              temp2 = w(i, j, k+1, irho)
              temp1 = w(i, j, k, itu1)
              temp0 = w(i, j, k, irho)
              ddwd = temp3*wd(i, j, k+1, irho) + temp2*wd(i, j, k+1, &
&               itu1) - temp1*wd(i, j, k, irho) - temp0*wd(i, j, k, itu1&
&               )
              ddw = temp2*temp3 - temp0*temp1
              drkd = ddw*dis2d + dis2*ddwd
              drk = dis2*ddw
              kavgd = half*(wd(i, j, k+1, itu1)+wd(i, j, k, itu1))
              kavg = half*(w(i, j, k+1, itu1)+w(i, j, k, itu1))
            else
              drk = zero
              kavg = zero
              kavgd = 0.0_8
              drkd = 0.0_8
            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.
            uavgd = half*(wd(i, j, k+1, ivx)+wd(i, j, k, ivx))
            uavg = half*(w(i, j, k+1, ivx)+w(i, j, k, ivx))
            vavgd = half*(wd(i, j, k+1, ivy)+wd(i, j, k, ivy))
            vavg = half*(w(i, j, k+1, ivy)+w(i, j, k, ivy))
            wavgd = half*(wd(i, j, k+1, ivz)+wd(i, j, k, ivz))
            wavg = half*(w(i, j, k+1, ivz)+w(i, j, k, ivz))
            temp3 = gamma(i, j, k+1)
            temp2 = w(i, j, k+1, irho)
            temp1 = p(i, j, k+1)/temp2
            temp0 = w(i, j, k, irho)
            temp = p(i, j, k)/temp0
            a2avgd = half*(temp3*(pd(i, j, k+1)-temp1*wd(i, j, k+1, irho&
&             ))/temp2+gamma(i, j, k)*(pd(i, j, k)-temp*wd(i, j, k, irho&
&             ))/temp0)
            a2avg = half*(temp3*temp1+gamma(i, j, k)*temp)
            sxd = skd(i, j, k, 1)
            sx = sk(i, j, k, 1)
            syd = skd(i, j, k, 2)
            sy = sk(i, j, k, 2)
            szd = skd(i, j, k, 3)
            sz = sk(i, j, k, 3)
            arg1d = 2*sx*sxd + 2*sy*syd + 2*sz*szd
            arg1 = sx**2 + sy**2 + sz**2
            temp3 = sqrt(arg1)
            if (arg1 .eq. 0.0_8) then
              aread = 0.0_8
            else
              aread = arg1d/(2.0*temp3)
            end if
            area = temp3
            if (1.e-25_realtype .lt. area) then
              max3d = aread
              max3 = area
            else
              max3 = 1.e-25_realtype
              max3d = 0.0_8
            end if
            tmpd = -(one*max3d/max3**2)
            tmp = one/max3
            sxd = tmp*sxd + sx*tmpd
            sx = sx*tmp
            syd = tmp*syd + sy*tmpd
            sy = sy*tmp
            szd = tmp*szd + sz*tmpd
            sz = sz*tmp
            alphaavgd = half*(2*uavg*uavgd+2*vavg*vavgd+2*wavg*wavgd)
            alphaavg = half*(uavg**2+vavg**2+wavg**2)
            havgd = alphaavgd + ovgm1*(a2avgd-gm53*kavgd)
            havg = alphaavg + ovgm1*(a2avg-gm53*kavg)
            temp3 = sqrt(a2avg)
            if (a2avg .eq. 0.0_8) then
              aavgd = 0.0_8
            else
              aavgd = a2avgd/(2.0*temp3)
            end if
            aavg = temp3
            unavgd = sx*uavgd + uavg*sxd + sy*vavgd + vavg*syd + sz*&
&             wavgd + wavg*szd
            unavg = uavg*sx + vavg*sy + wavg*sz
            ovaavgd = -(one*aavgd/aavg**2)
            ovaavg = one/aavg
            ova2avgd = -(one*a2avgd/a2avg**2)
            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
              sfaced = tmp*sfacekd(i, j, k) + sfacek(i, j, k)*tmpd
              sface = sfacek(i, j, k)*tmp
            end if
            if (unavg - sface + aavg .ge. 0.) then
              lam1d = unavgd - sfaced + aavgd
              lam1 = unavg - sface + aavg
            else
              lam1d = sfaced - unavgd - aavgd
              lam1 = -(unavg-sface+aavg)
            end if
            if (unavg - sface - aavg .ge. 0.) then
              lam2d = unavgd - sfaced - aavgd
              lam2 = unavg - sface - aavg
            else
              lam2d = sfaced - unavgd + aavgd
              lam2 = -(unavg-sface-aavg)
            end if
            if (unavg - sface .ge. 0.) then
              lam3d = unavgd - sfaced
              lam3 = unavg - sface
            else
              lam3d = sfaced - unavgd
              lam3 = -(unavg-sface)
            end if
            rradd = lam3d + aavgd
            rrad = lam3 + aavg
            if (lam1 .lt. epsacoustic*rrad) then
              lam1d = epsacoustic*rradd
              lam1 = epsacoustic*rrad
            else
              lam1 = lam1
            end if
            if (lam2 .lt. epsacoustic*rrad) then
              lam2d = epsacoustic*rradd
              lam2 = epsacoustic*rrad
            else
              lam2 = lam2
            end if
            if (lam3 .lt. epsshear*rrad) then
              lam3d = epsshear*rradd
              lam3 = epsshear*rrad
            else
              lam3 = lam3
            end if
! multiply the eigenvalues by the area to obtain
! the correct values for the dissipation term.
            lam1d = area*lam1d + lam1*aread
            lam1 = lam1*area
            lam2d = area*lam2d + lam2*aread
            lam2 = lam2*area
            lam3d = area*lam3d + lam3*aread
            lam3 = lam3*area
! some abbreviations, which occur quite often in the
! dissipation terms.
            abv1d = half*(lam1d+lam2d)
            abv1 = half*(lam1+lam2)
            abv2d = half*(lam1d-lam2d)
            abv2 = half*(lam1-lam2)
            abv3d = abv1d - lam3d
            abv3 = abv1 - lam3
            abv4d = gm1*(dr*alphaavgd+alphaavg*drd-dru*uavgd-uavg*drud-&
&             drv*vavgd-vavg*drvd+dred-drw*wavgd-wavg*drwd) - gm53*drkd
            abv4 = gm1*(alphaavg*dr-uavg*dru-vavg*drv-wavg*drw+dre) - &
&             gm53*drk
            abv5d = dru*sxd + sx*drud + drv*syd + sy*drvd + drw*szd + sz&
&             *drwd - dr*unavgd - unavg*drd
            abv5 = sx*dru + sy*drv + sz*drw - unavg*dr
            abv6d = ova2avg*(abv4*abv3d+abv3*abv4d) + abv3*abv4*ova2avgd&
&             + ovaavg*(abv5*abv2d+abv2*abv5d) + abv2*abv5*ovaavgd
            abv6 = abv3*abv4*ova2avg + abv2*abv5*ovaavg
            abv7d = ovaavg*(abv4*abv2d+abv2*abv4d) + abv2*abv4*ovaavgd +&
&             abv5*abv3d + abv3*abv5d
            abv7 = abv2*abv4*ovaavg + abv3*abv5
! compute and scatter the dissipative flux.
! density.
            fsd = dr*lam3d + lam3*drd + abv6d
            fs = lam3*dr + abv6
            fwd(i, j, k+1, irho) = fwd(i, j, k+1, irho) + fsd
            fw(i, j, k+1, irho) = fw(i, j, k+1, irho) + fs
            fwd(i, j, k, irho) = fwd(i, j, k, irho) - fsd
            fw(i, j, k, irho) = fw(i, j, k, irho) - fs
! x-momentum.
            fsd = dru*lam3d + lam3*drud + abv6*uavgd + uavg*abv6d + abv7&
&             *sxd + sx*abv7d
            fs = lam3*dru + uavg*abv6 + sx*abv7
            fwd(i, j, k+1, imx) = fwd(i, j, k+1, imx) + fsd
            fw(i, j, k+1, imx) = fw(i, j, k+1, imx) + fs
            fwd(i, j, k, imx) = fwd(i, j, k, imx) - fsd
            fw(i, j, k, imx) = fw(i, j, k, imx) - fs
! y-momentum.
            fsd = drv*lam3d + lam3*drvd + abv6*vavgd + vavg*abv6d + abv7&
&             *syd + sy*abv7d
            fs = lam3*drv + vavg*abv6 + sy*abv7
            fwd(i, j, k+1, imy) = fwd(i, j, k+1, imy) + fsd
            fw(i, j, k+1, imy) = fw(i, j, k+1, imy) + fs
            fwd(i, j, k, imy) = fwd(i, j, k, imy) - fsd
            fw(i, j, k, imy) = fw(i, j, k, imy) - fs
! z-momentum.
            fsd = drw*lam3d + lam3*drwd + abv6*wavgd + wavg*abv6d + abv7&
&             *szd + sz*abv7d
            fs = lam3*drw + wavg*abv6 + sz*abv7
            fwd(i, j, k+1, imz) = fwd(i, j, k+1, imz) + fsd
            fw(i, j, k+1, imz) = fw(i, j, k+1, imz) + fs
            fwd(i, j, k, imz) = fwd(i, j, k, imz) - fsd
            fw(i, j, k, imz) = fw(i, j, k, imz) - fs
! energy.
            fsd = dre*lam3d + lam3*dred + abv6*havgd + havg*abv6d + abv7&
&             *unavgd + unavg*abv7d
            fs = lam3*dre + havg*abv6 + unavg*abv7
            fwd(i, j, k+1, irhoe) = fwd(i, j, k+1, irhoe) + fsd
            fw(i, j, k+1, irhoe) = fw(i, j, k+1, irhoe) + fs
            fwd(i, j, k, irhoe) = fwd(i, j, k, irhoe) - fsd
            fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
! set dp1 to dp2 for the next face.
            dp1d = dp2d
            dp1 = dp2
          end do
        end do
      end do
    end if
  end subroutine invisciddissfluxmatrixapprox_d
 
  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_d, 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
    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. 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)
            arg1 = sx**2 + sy**2 + sz**2
            area = sqrt(arg1)
            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)
            arg1 = sx**2 + sy**2 + sz**2
            area = sqrt(arg1)
            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)
            arg1 = sx**2 + sy**2 + sz**2
            area = sqrt(arg1)
            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_d