blockette.F90

Go to the documentation of this file.

module blockette
 
    use constants
    ! This temporary module contains all cache-blocked code. It also
    ! contains the statically allocated variables on which the blocked
    ! code operates.
 
    ! Dummy Block dimensions
    integer(kind=intType), parameter :: bs = 8
    integer(kind=intType), parameter :: bbil = bs + 1, bbjl = bs + 1, bbkl = bs + 1
    integer(kind=intType), parameter :: bbie = bs + 2, bbje = bs + 2, bbke = bs + 2
    integer(kind=intType), parameter :: bbib = bs + 3, bbjb = bs + 3, bbkb = bs + 3
 
    ! Actual dimensions to execute
    integer(kind=intType) :: nx, ny, nz, il, jl, kl, ie, je, ke, ib, jb, kb
 
    ! Variables to track transferring variables between blockettes
    integer(kind=intType) :: singlehalostart, doublehalostart, nodestart
 
    ! Current indices into the original block
    integer(kind=intType) :: ii, jj, kk
 
    ! Double halos
    real(kind=realtype), dimension(0:bbib, 0:bbjb, 0:bbkb, 1:6) :: w
    real(kind=realtype), dimension(0:bbib, 0:bbjb, 0:bbkb) :: p, gamma
    real(kind=realtype), dimension(0:bbib, 0:bbjb, 0:bbkb) :: ss ! Entropy
 
    ! Single halos
    real(kind=realtype), dimension(0:bbie, 0:bbje, 0:bbke, 3) :: x
    real(kind=realtype), dimension(1:bbie, 1:bbje, 1:bbke) :: rlv, rev, vol, aa
    real(kind=realtype), dimension(1:bbie, 1:bbje, 1:bbke) :: radi, radj, radk, dtl
    real(kind=realtype), dimension(1:bbie, 1:bbje, 1:bbke, 3) :: dss ! Shock sensor
 
    ! No halos
    real(kind=realtype), dimension(2:bbil, 2:bbjl, 2:bbkl) :: volref, d2wall
    integer(kind=intType), dimension(2:bbil, 2:bbjl, 2:bbkl) :: iblank
 
    ! Face Porosities
    integer(kind=porType), dimension(1:bbil, 2:bbjl, 2:bbkl) :: pori
    integer(kind=porType), dimension(2:bbil, 1:bbjl, 2:bbkl) :: porj
    integer(kind=porType), dimension(2:bbil, 2:bbjl, 1:bbkl) :: pork
 
    ! Single halos (only owned cells significant)
    real(kind=realtype), dimension(1:bbie, 1:bbje, 1:bbke, 1:5) :: fw
    real(kind=realtype), dimension(1:bbie, 1:bbje, 1:bbke, 1:6) :: dw
 
    ! Face projected areas
    real(kind=realtype), dimension(0:bbie, 1:bbje, 1:bbke, 3) :: si
    real(kind=realtype), dimension(1:bbie, 0:bbje, 1:bbke, 3) :: sj
    real(kind=realtype), dimension(1:bbie, 1:bbje, 0:bbke, 3) :: sk
 
    ! Face velocities
    real(kind=realtype), dimension(0:bbie, 1:bbje, 1:bbke) :: sfacei
    real(kind=realtype), dimension(1:bbie, 0:bbje, 1:bbke) :: sfacej
    real(kind=realtype), dimension(1:bbie, 1:bbje, 0:bbke) :: sfacek
 
    ! Nodal gradients
    real(kind=realtype), dimension(1:bbil, 1:bbjl, 1:bbkl) :: ux, uy, uz
    real(kind=realtype), dimension(1:bbil, 1:bbjl, 1:bbkl) :: vx, vy, vz
    real(kind=realtype), dimension(1:bbil, 1:bbjl, 1:bbkl) :: wx, wy, wz
    real(kind=realtype), dimension(1:bbil, 1:bbjl, 1:bbkl) :: qx, qy, qz
 
    ! Make *all* of these variables tread-private
    !$OMP THREADPRIVATE(nx, ny, nz, il, jl, kl, ie, je, ke, ib, jb, kb)
    !$OMP THREADPRIVATE(w, p, gamma, ss, x, rlv, rev, vol, aa, radI, radJ, radK)
    !$OMP THREADPRIVATE(dss, volRef, d2wall, iblank, porI, porJ, porK, fw, dw)
    !$OMP THREADPRIVATE(sI, sJ, sK, ux, uy, uz, vx, vy, vz, wx, wy, wz, qx, qy, qz)
contains
 
    subroutine blocketteres(useDissApprox, useViscApprox, useUpdateIntermed, useFlowRes, useTurbRes, useSpatial, &
                            useStoreWall, famLists, funcValues, forces, bcDataNames, bcDataValues, bcDataFamLists)
 
        ! Copy the values from blockPointers (assumed set) into the
        ! blockette
 
        use constants
        use block, only: ndom
        use bcroutines, only: applyallbc_block
        use bcdata, only: setbcdata, setbcdatafinegrid
        use turbbcroutines, only: applyallturbbcthisblock, bcturbtreatment
        use inputphysics, only: turbprod, equationmode, equations, turbmodel
        use inputdiscretization, only: lowspeedpreconditioner, useapproxwalldistance, useblockettes
        use inputtimespectral, only: ntimeintervalsspectral
        use flowutils, only: computelamviscosity, computepressuresimple, adjustinflowangle
        use flowvarrefstate, only: nwf, nw, nt1, nt2
        use initializeflow, only: referencestate
        use section, only: sections, nsections
        use iteration, only: rfil, currentlevel
        use haloexchange, only: exchangecoor, whalo2
        use walldistance, only: updatewalldistancesquickly
        use utils, only: setpointers, echk
        use turbutils, only: computeeddyviscosity
        use residuals, only: sourceterms_block
        use surfaceintegrations, only: getsolution
        use adjointextra, only: volume_block, metric_block, boundarynormals, xhalo_block
        use oversetdata, only: oversetpresent
        use inputoverset, only: oversetupdatemode
        use oversetcommutilities, only: updateoversetconnectivity
        use actuatorregiondata, only: nactuatorregions
        implicit none
 
        ! Input/Output
        logical, intent(in), optional :: useDissApprox, useViscApprox, useUpdateIntermed, useFlowRes
        logical, intent(in), optional :: useTurbRes, useSpatial, useStoreWall
        integer(kind=intType), optional, dimension(:, :), intent(in) :: famLists
        real(kind=realtype), optional, dimension(:, :), intent(out) :: funcvalues
        character, optional, dimension(:, :), intent(in) :: bcDataNames
        real(kind=realtype), optional, dimension(:), intent(in) :: bcdatavalues
        integer(kind=intType), optional, dimension(:, :) :: bcDataFamLists
        real(kind=realtype), intent(out), optional, dimension(:, :, :) :: forces
 
        ! Misc
        logical :: dissApprox, viscApprox, updateIntermed, flowRes, turbRes, spatial, storeWall
        integer(kind=intType) :: nn, sps, fSize, lstart, lend, iRegion
        real(kind=realtype) :: plocal
 
        ! Set the defaults. The default is to compute the full, exact,
        ! RANS residual without updating the spatial values or the local
        ! timeStep.
        dissapprox = .false.
        viscapprox = .false.
        ! Update intermediate flag is to copy out intermediate variables
        ! that are computed during the blockette residual computation from
        ! blockette memory back to the main memory. These are the time
        ! step, spectral radii for all cases, and nodal gradients and
        ! speed of sound squared for viscous simulations. The regular
        ! "block" residuals do not need to copy out these since they
        ! are already computed in place. For the block residual, this
        ! flag only determines if we update the time step along with
        ! the spectral radii.
        updateintermed = .false.
        flowres = .true.
        turbres = .true.
        spatial = .false.
        storewall = .true.
 
        ! Parse the input variables
        if (present(usedissapprox)) then
            dissapprox = usedissapprox
        end if
 
        if (present(useviscapprox)) then
            viscapprox = useviscapprox
        end if
 
        if (present(useupdateintermed)) then
            updateintermed = useupdateintermed
        end if
 
        if (present(useflowres)) then
            flowres = useflowres
        end if
 
        if (present(useturbres)) then
            turbres = useturbres
        end if
 
        if (present(usespatial)) then
            spatial = usespatial
        end if
 
        if (present(usestorewall)) then
            storewall = usestorewall
        end if
 
        ! Spatial-only updates first
        if (spatial) then
            call adjustinflowangle()
 
            ! Update all the BCData
            call referencestate
            if (present(bcdatanames)) then
                do sps = 1, ntimeintervalsspectral
                    call setbcdata(bcdatanames, bcdatavalues, bcdatafamlists, sps, &
                                   size(bcdatavalues), size(bcdatafamlists, 2))
                end do
                call setbcdatafinegrid(.true.)
            end if
 
            do sps = 1, ntimeintervalsspectral
                do nn = 1, ndom
                    call setpointers(nn, currentlevel, sps)
                    call xhalo_block()
                end do
            end do
 
            ! Now exchange the coordinates (fine level only)
            call exchangecoor(1)
 
            do sps = 1, ntimeintervalsspectral
                ! Update overset connectivity if necessary
                if (oversetpresent .and. oversetupdatemode == updatefast) then
                    call updateoversetconnectivity(1_inttype, sps)
                end if
            end do
        end if
 
        ! Compute the required derived values and apply the BCs
        do sps = 1, ntimeintervalsspectral
            do nn = 1, ndom
                call setpointers(nn, currentlevel, sps)
 
                if (spatial) then
                    call volume_block
                    call metric_block
                    call boundarynormals
 
                    if (equations == ransequations .and. useapproxwalldistance) then
                        call updatewalldistancesquickly(nn, 1, sps)
                    end if
                end if
 
                ! Compute the pressures/viscositites
                call computepressuresimple(.false.)
 
                ! Compute Laminar/eddy viscosity if required
                call computelamviscosity(.false.)
                call computeeddyviscosity(.false.)
 
                ! Make sure to call the turb BC's first incase we need to
                ! correct for K
                if (equations == ransequations .and. turbres) then
                    call bcturbtreatment
                    call applyallturbbcthisblock(.true.)
                end if
                call applyallbc_block(.true.)
 
            end do
        end do
 
        ! Compute the ranges of the residuals we are dealing with:
        if (flowres .and. turbres) then
            lstart = 1
            lend = nw
 
        else if (flowres .and. (.not. turbres)) then
            lstart = 1
            lend = nwf
 
        else if ((.not. flowres) .and. turbres) then
            lstart = nt1
            lend = nt2
        end if
 
        ! Exchange values
        call whalo2(1_inttype, lstart, lend, .true., .true., .true.)
 
        ! Need to re-apply the BCs. The reason is that BC halos behind
        ! interpolated cells need to be recomputed with their new
        ! interpolated values from actual compute cells. Only needed for
        ! overset.
        if (oversetpresent) then
            do sps = 1, ntimeintervalsspectral
                do nn = 1, ndom
                    call setpointers(nn, currentlevel, sps)
                    if (equations == ransequations .and. turbres) then
                        call bcturbtreatment
                        call applyallturbbcthisblock(.true.)
                    end if
                    call applyallbc_block(.true.)
                end do
            end do
        end if
 
        ! Main loop for the residual...This is where the blockette magic happens.
        spsloop: do sps = 1, ntimeintervalsspectral
            blockloop: do nn = 1, ndom
                call setpointers(nn, currentlevel, sps)
 
                rfil = one
                blockettes: if (useblockettes) then
                    call blocketterescore(dissapprox, viscapprox, updateintermed, flowres, turbres, storewall)
                else
                    call blockrescore(dissapprox, viscapprox, updateintermed, flowres, turbres, storewall, nn, sps)
                end if blockettes
 
                if (currentlevel == 1) then
                    do iregion = 1, nactuatorregions
                        call sourceterms_block(nn, .true., iregion, plocal)
                    end do
                end if
            end do blockloop
        end do spsloop
 
        ! Compute the final solution values
        if (present(famlists)) then
            call getsolution(famlists, funcvalues)
        end if
 
        if (present(forces)) then
            do sps = 1, ntimeintervalsspectral
                ! Now we can retrieve the forces/tractions for this spectral instance
                fsize = size(forces, 2)
                call getforces(forces(:, :, sps), fsize, sps)
            end do
        end if
    end subroutine blocketteres
 
    subroutine blocketterescore(dissApprox, viscApprox, updateIntermed, flowRes, turbRes, storeWall)
 
        ! Main subroutine for computing the reisdual for the given block using blockettes
        use constants
 
        use constants
        use blockpointers, only: &
            bnx => nx, bny => ny, bnz => nz, &
            bil => il, bjl => jl, bkl => kl, &
            bie => ie, bje => je, bke => ke, &
            bib => ib, bjb => jb, bkb => kb, &
            bw => w, bp => p, bgamma => gamma, &
            bradi => radi, bradj => radj, bradk => radk, &
            bux => ux, buy => uy, buz => uz, &
            bvx => vx, bvy => vy, bvz => vz, &
            bwx => wx, bwy => wy, bwz => wz, &
            bqx => qx, bqy => qy, bqz => qz, &
            bx => x, brlv => rlv, brev => rev, bvol => vol, bvolref => volref, bd2wall => d2wall, &
            biblank => iblank, bpori => pori, bporj => porj, bpork => pork, bdw => dw, bfw => fw, &
            bshocksensor => shocksensor, &
            bsi => si, bsj => sj, bsk => sk, &
            bsfacei => sfacei, bsfacej => sfacej, bsfacek => sfacek, &
            bdtl => dtl, baa => aa, &
            addgridvelocities
        use flowvarrefstate, only: nwf, nw, viscous, nt1, nt2
        use iteration, only: currentlevel
        use inputphysics, only: equationmode, equations, turbmodel
        use inputdiscretization, only: spacediscr
        use utils, only: setpointers, echk
        use turbutils, only: computeeddyviscosity
        use oversetdata, only: oversetpresent
 
        implicit none
 
        ! Input
        logical, intent(in) :: dissApprox, viscApprox, updateIntermed, flowRes, turbRes, storeWall
 
        ! Working:
        integer(kind=intType) :: i, j, k, l, lStart, lEnd
 
        ! Compute the ranges of the residuals we are dealing with:
        if (flowres .and. turbres) then
            lstart = 1
            lend = nw
 
        else if (flowres .and. (.not. turbres)) then
            lstart = 1
            lend = nwf
 
        else if ((.not. flowres) .and. turbres) then
            lstart = nt1
            lend = nt2
        end if
 
        ! Block loop over the owned cells
        !$OMP parallel do private(i,j,k,l) collapse(2)
        do kk = 2, bkl, bs
            do jj = 2, bjl, bs
                do ii = 2, bil, bs
 
                    ! Determine the actual size this block will be and set
                    ! the sizes in the blockette module for each of the
                    ! subroutines.
 
                    nx = min(ii + bs - 1, bil) - ii + 1
                    ny = min(jj + bs - 1, bjl) - jj + 1
                    nz = min(kk + bs - 1, bkl) - kk + 1
 
                    il = nx + 1; jl = ny + 1; kl = nz + 1
                    ie = nx + 2; je = ny + 2; ke = nz + 2
                    ib = nx + 3; jb = ny + 3; kb = nz + 3
 
                    firstblockette: if (ii == 2) then
 
                        ! First loop. Need to compute the extra stuff. Set
                        ! the generic starts and copy the extra
                        ! variables in to the starting slots
                        singlehalostart = 1
                        doublehalostart = 0
                        nodestart = 1
 
                        ! Double halos
                        do k = 0, kb
                            do j = 0, jb
                                do i = 0, 3
                                    w(i, j, k, 1:nw) = bw(i + ii - 2, j + jj - 2, k + kk - 2, 1:nw)
                                    p(i, j, k) = bp(i + ii - 2, j + jj - 2, k + kk - 2)
                                    gamma(i, j, k) = bgamma(i + ii - 2, j + jj - 2, k + kk - 2)
                                    if (currentlevel == 1) then
                                        ss(i, j, k) = bshocksensor(i + ii - 2, j + jj - 2, k + kk - 2)
                                    end if
                                end do
                            end do
                        end do
 
                        ! Single halos
                        do k = 1, ke
                            do j = 1, je
                                do i = 1, 2
                                    rlv(i, j, k) = brlv(i + ii - 2, j + jj - 2, k + kk - 2)
                                    rev(i, j, k) = brev(i + ii - 2, j + jj - 2, k + kk - 2)
                                    vol(i, j, k) = bvol(i + ii - 2, j + jj - 2, k + kk - 2)
                                end do
                            end do
                        end do
 
                        ! X
                        do k = 0, ke
                            do j = 0, je
                                do i = 0, 1
                                    x(i, j, k, :) = bx(i + ii - 2, j + jj - 2, k + kk - 2, :)
                                end do
                            end do
                        end do
                    else
 
                        ! Subsequent loop. We can save a bunch of work by
                        ! copying some of the pre-computed values from the
                        ! previous blockette to this blockette. Basically the
                        ! values that are at the "I end" get shuffled back to
                        ! the I-start. We *also* do this for some of the
                        ! intermediate variables that are costly to compute
                        ! like the nodal gradients, and spectral radius which
                        ! helps cut back on the amount of data duplication.
 
                        ! Important Note: This cell is not the first cell. If
                        ! this code is being executed, the previous blockette
                        ! was copied fully in the i direction.
                        ! Therefore, we can just copy the values from
                        ! the end of the blockette as it is allocated.
                        ! To do this, we ignore the dimensions of the "current"
                        ! blockette, and just take the baseline BS dimensions
                        ! as the current blockette might be partially filled
                        ! in the i direction.
 
                        singlehalostart = 3
                        doublehalostart = 4
                        nodestart = 2
 
                        ! Double halos
                        do k = 0, kb
                            do j = 0, jb
                                do i = 0, 3
                                    w(i, j, k, 1:nw) = w(bs + i, j, k, 1:nw)
                                    p(i, j, k) = p(bs + i, j, k)
                                    gamma(i, j, k) = gamma(bs + i, j, k)
                                    ss(i, j, k) = ss(bs + i, j, k)
                                end do
                            end do
                        end do
 
                        ! Single halos
                        do k = 1, ke
                            do j = 1, je
                                do i = 1, 2
                                    rlv(i, j, k) = rlv(bs + i, j, k)
                                    rev(i, j, k) = rev(bs + i, j, k)
                                    vol(i, j, k) = vol(bs + i, j, k)
 
                                    ! Computed variables
 
                                    ! DONT Copy the spectral-radii. The loop that calculates
                                    ! spectral radii also calculates portion of the time step,
                                    ! so we don't want to mess with its boundaries to keep
                                    ! it simple.
                                    aa(i, j, k) = aa(bs + i, j, k)
                                    dss(i, j, k, :) = dss(bs + i, j, k, :)
                                end do
                            end do
                        end do
 
                        ! X
                        do k = 0, ke
                            do j = 0, je
                                do i = 0, 1
                                    x(i, j, k, :) = x(bs + i, j, k, :)
                                end do
                            end do
                        end do
 
                        ! Nodal gradients
                        do k = 1, kl
                            do j = 1, jl
                                ux(1, j, k) = ux(bs + 1, j, k)
                                uy(1, j, k) = uy(bs + 1, j, k)
                                uz(1, j, k) = uz(bs + 1, j, k)
 
                                vx(1, j, k) = vx(bs + 1, j, k)
                                vy(1, j, k) = vy(bs + 1, j, k)
                                vz(1, j, k) = vz(bs + 1, j, k)
 
                                wx(1, j, k) = wx(bs + 1, j, k)
                                wy(1, j, k) = wy(bs + 1, j, k)
                                wz(1, j, k) = wz(bs + 1, j, k)
 
                                qx(1, j, k) = qx(bs + 1, j, k)
                                qy(1, j, k) = qy(bs + 1, j, k)
                                qz(1, j, k) = qz(bs + 1, j, k)
                            end do
                        end do
                    end if firstblockette
 
                    ! -------------------------------------
                    !      Fill in the remaining values
                    ! -------------------------------------
 
                    ! Double halos
                    do k = 0, kb
                        do j = 0, jb
                            do i = 4, ib
                                w(i, j, k, 1:nw) = bw(i + ii - 2, j + jj - 2, k + kk - 2, 1:nw)
                                p(i, j, k) = bp(i + ii - 2, j + jj - 2, k + kk - 2)
                                gamma(i, j, k) = bgamma(i + ii - 2, j + jj - 2, k + kk - 2)
                                if (currentlevel == 1) then
                                    ss(i, j, k) = bshocksensor(i + ii - 2, j + jj - 2, k + kk - 2)
                                end if
                            end do
                        end do
                    end do
 
                    ! Single halos
                    do k = 1, ke
                        do j = 1, je
                            do i = 3, ie
                                rlv(i, j, k) = brlv(i + ii - 2, j + jj - 2, k + kk - 2)
                                rev(i, j, k) = brev(i + ii - 2, j + jj - 2, k + kk - 2)
                                vol(i, j, k) = bvol(i + ii - 2, j + jj - 2, k + kk - 2)
                            end do
                        end do
                    end do
 
                    ! X
                    do k = 0, ke
                        do j = 0, je
                            do i = 2, ie
                                x(i, j, k, :) = bx(i + ii - 2, j + jj - 2, k + kk - 2, :)
                            end do
                        end do
                    end do
 
                    ! No Halos (no change)
                    do k = 2, kl
                        do j = 2, jl
                            do i = 2, il
                                iblank(i, j, k) = biblank(i + ii - 2, j + jj - 2, k + kk - 2)
                                if (equations .eq. ransequations) &
                                    d2wall(i, j, k) = bd2wall(i + ii - 2, j + jj - 2, k + kk - 2)
                                volref(i, j, k) = bvolref(i + ii - 2, j + jj - 2, k + kk - 2)
                            end do
                        end do
                    end do
 
                    ! Porosities (no change)
                    do k = 2, kl
                        do j = 2, jl
                            do i = 1, il
                                pori(i, j, k) = bpori(i + ii - 2, j + jj - 2, k + kk - 2)
                            end do
                        end do
                    end do
 
                    do k = 2, kl
                        do j = 1, jl
                            do i = 2, il
                                porj(i, j, k) = bporj(i + ii - 2, j + jj - 2, k + kk - 2)
                            end do
                        end do
                    end do
 
                    do k = 1, kl
                        do j = 2, jl
                            do i = 2, il
                                pork(i, j, k) = bpork(i + ii - 2, j + jj - 2, k + kk - 2)
                            end do
                        end do
                    end do
 
                    ! Face velocities if necessary
                    if (addgridvelocities) then
                        do k = 1, ke
                            do j = 1, je
                                do i = 0, ie
                                    sfacei(i, j, k) = bsfacei(i + ii - 2, j + jj - 2, k + kk - 2)
                                end do
                            end do
                        end do
 
                        do k = 1, ke
                            do j = 0, je
                                do i = 1, ie
                                    sfacej(i, j, k) = bsfacej(i + ii - 2, j + jj - 2, k + kk - 2)
                                end do
                            end do
                        end do
 
                        do k = 0, ke
                            do j = 1, je
                                do i = 1, ie
                                    sfacek(i, j, k) = bsfacek(i + ii - 2, j + jj - 2, k + kk - 2)
                                end do
                            end do
                        end do
                    else
                        sfacei = zero
                        sfacej = zero
                        sfacek = zero
                    end if
 
                    ! Clear the viscous flux before we start.
                    fw = zero
 
                    ! Call the routines in order:
                    call metrics
                    call initres(lstart, lend)
 
                    ! Compute turbulence residual for RANS equations
                    if (equations == ransequations .and. turbres) then
 
                        ! Initialize only the Turblent Variables
                        !call unsteadyTurbSpectral_block(itu1, itu1, nn, sps)
 
                        select case (turbmodel)
 
                        case (spalartallmaras)
                            call sasource
                            call saadvection
                            !call unsteadyTurbTerm(1_intType, 1_intType, itu1-1, qq)
                            call saviscous
                            call saresscale
                        end select
                    end if
 
                    call timestep(updateintermed)
 
                    if (flowres) then
                        call inviscidcentralflux
 
                        if (dissapprox) then
                            select case (spacediscr)
                            case (dissscalar)
                                call invisciddissfluxscalarapprox
                            case (dissmatrix)
                                call invisciddissfluxmatrixapprox
                            case (upwind)
                                call inviscidupwindflux(.false.)
                            end select
                        else
                            select case (spacediscr)
                            case (dissscalar)
                                call invisciddissfluxscalar
                            case (dissmatrix)
                                call invisciddissfluxmatrix
                            case (upwind)
                                call inviscidupwindflux(.true.)
                            end select
                        end if
 
                        if (viscous) then
                            call computespeedofsoundsquared
                            if (viscapprox) then
                                call viscousfluxapprox
                            else
                                call allnodalgradients
                                call viscousflux(storewall)
                            end if
                        end if
 
                        call sumdwandfw
                    end if
 
                    ! Now we can just set the part of dw we computed
                    ! (owned cells only) and we're done!
                    do l = lstart, lend
                        do k = 2, kl
                            do j = 2, jl
                                do i = 2, il
                                    bdw(i + ii - 2, j + jj - 2, k + kk - 2, l) = dw(i, j, k, l)
                                end do
                            end do
                        end do
                    end do
 
                    ! Also copy out the intermediate variables if asked for them
                    ! we need these to be updated in main memory because
                    ! the reverse mode AD routines do use these variables.
                    ! after every ANK and NK step, blocketteRes is called
                    ! with updateIntermed = True, and it will update these
                    ! arrays in main memory. The time step is required
                    ! for the ANK and MG solver steps.
                    intermed: if (updateintermed) then
                        ! time step
                        do k = 2, kl
                            do j = 2, jl
                                do i = 2, il
                                    bdtl(i + ii - 2, j + jj - 2, k + kk - 2) = dtl(i, j, k)
                                end do
                            end do
                        end do
 
                        ! Spectral radii
                        do k = 1, ke
                            do j = 1, je
                                do i = 1, ie
                                    bradi(i + ii - 2, j + jj - 2, k + kk - 2) = radi(i, j, k)
                                    bradj(i + ii - 2, j + jj - 2, k + kk - 2) = radj(i, j, k)
                                    bradk(i + ii - 2, j + jj - 2, k + kk - 2) = radk(i, j, k)
                                end do
                            end do
                        end do
 
                        ! need aa and nodal gradients if we have viscous fluxes
                        visc: if (viscous .and. flowres) then
 
                            ! speed of sound squared
                            do k = 1, ke
                                do j = 1, je
                                    do i = 1, ie
                                        baa(i + ii - 2, j + jj - 2, k + kk - 2) = aa(i, j, k)
                                    end do
                                end do
                            end do
 
                            ! nodal gradients
                            do k = 1, kl
                                do j = 1, jl
                                    do i = 1, il
 
                                        bux(i + ii - 2, j + jj - 2, k + kk - 2) = ux(i, j, k)
                                        buy(i + ii - 2, j + jj - 2, k + kk - 2) = uy(i, j, k)
                                        buz(i + ii - 2, j + jj - 2, k + kk - 2) = uz(i, j, k)
 
                                        bvx(i + ii - 2, j + jj - 2, k + kk - 2) = vx(i, j, k)
                                        bvy(i + ii - 2, j + jj - 2, k + kk - 2) = vy(i, j, k)
                                        bvz(i + ii - 2, j + jj - 2, k + kk - 2) = vz(i, j, k)
 
                                        bwx(i + ii - 2, j + jj - 2, k + kk - 2) = wx(i, j, k)
                                        bwy(i + ii - 2, j + jj - 2, k + kk - 2) = wy(i, j, k)
                                        bwz(i + ii - 2, j + jj - 2, k + kk - 2) = wz(i, j, k)
 
                                        bqx(i + ii - 2, j + jj - 2, k + kk - 2) = qx(i, j, k)
                                        bqy(i + ii - 2, j + jj - 2, k + kk - 2) = qy(i, j, k)
                                        bqz(i + ii - 2, j + jj - 2, k + kk - 2) = qz(i, j, k)
 
                                    end do
                                end do
                            end do
                        end if visc
 
                    end if intermed
 
                end do
            end do
        end do
        !$OMP END PARALLEL DO
    end subroutine blocketterescore
 
    subroutine blockrescore(dissApprox, viscApprox, updateIntermed, flowRes, turbRes, storeWall, nn, sps)
 
        use constants
        use fluxes, only: inviscidcentralflux_block => inviscidcentralflux, &
                          invisciddissfluxscalar_block => invisciddissfluxscalar, &
                          invisciddissfluxmatrix_block => invisciddissfluxmatrix, &
                          inviscidupwindflux_block => inviscidupwindflux, &
                          invisciddissfluxscalarapprox_block => invisciddissfluxscalarapprox, &
                          invisciddissfluxmatrixapprox_block => invisciddissfluxmatrixapprox, &
                          viscousflux_block => viscousflux, &
                          viscousfluxapprox_block => viscousfluxapprox
        use solverutils, only: timestep_block
        use flowvarrefstate, only: nwf, nw, viscous, nt1, nt2
        use inputphysics, only: equationmode, equations, turbmodel
        use residuals, only: initres_block
        use sa, only: sa_block
        use adjointextra, only: sumdwandfw_block => sumdwandfw
        use inputdiscretization, only: spacediscr
        use flowutils, only: allnodalgradients_block => allnodalgradients, &
                             computespeedofsoundsquared_block => computespeedofsoundsquared
 
        implicit none
        ! Input
        logical, intent(in) :: dissApprox, viscApprox, updateIntermed, flowRes, turbRes, storeWall
        integer(kind=intType), intent(in) :: nn, sps
 
        ! Working:
        integer(kind=intType) :: i, j, k, lStart, lEnd
 
        ! Compute the ranges of the residuals we are dealing with:
        if (flowres .and. turbres) then
            lstart = 1
            lend = nw
 
        else if (flowres .and. (.not. turbres)) then
            lstart = 1
            lend = nwf
 
        else if ((.not. flowres) .and. turbres) then
            lstart = nt1
            lend = nt2
        end if
 
        ! Compute time step
        call timestep_block(.not. updateintermed)
 
        call initres_block(lstart, lend, nn, sps) ! Initialize only the Turblent Variables
 
        fw = zero
 
        ! Possible Turblent Equations
        if (equations == ransequations .and. turbres) then
            ! Compute the skin-friction velocity (wall functions only)
            !call computeUtau_block
 
            ! Now call the selected turbulence model
            select case (turbmodel)
            case (spalartallmaras)
                call sa_block(.true.)
            end select
        end if
 
        if (flowres) then
 
            call inviscidcentralflux_block
            if (dissapprox) then
                select case (spacediscr)
                case (dissscalar)
                    call invisciddissfluxscalarapprox_block
                case (dissmatrix)
                    call invisciddissfluxmatrixapprox_block
                case (upwind)
                    call inviscidupwindflux_block(.true.)
                end select
            else
                select case (spacediscr)
                case (dissscalar)
                    call invisciddissfluxscalar_block
                case (dissmatrix)
                    call invisciddissfluxmatrix_block
                case (upwind)
                    call inviscidupwindflux_block(.true.)
                end select
            end if
 
            if (viscous) then
                call computespeedofsoundsquared_block
                if (viscapprox) then
                    call viscousfluxapprox_block
                else
                    call allnodalgradients_block
                    call viscousflux_block
                end if
            end if
 
            call sumdwandfw_block
        end if
    end subroutine blockrescore
 
    subroutine metrics
        ! ---------------------------------------------
        !              Metric computation
        ! ---------------------------------------------
 
        use constants
        use blockpointers, only: righthanded
        implicit none
 
        integer(kind=intType) :: i, j, k, l, m, n
        real(kind=realtype), dimension(3) :: v1, v2
        real(kind=realtype) :: fact
 
        ! Projected areas of cell faces in the i direction.
        if (righthanded) then
            fact = half
        else
            fact = -half
        end if
        do k = 1, ke
            n = k - 1
            do j = 1, je
                m = j - 1
                do i = 0, ie
 
                    ! Determine the two diagonal vectors of the face.
 
                    v1(1) = x(i, j, n, 1) - x(i, m, k, 1)
                    v1(2) = x(i, j, n, 2) - x(i, m, k, 2)
                    v1(3) = x(i, j, n, 3) - x(i, m, k, 3)
 
                    v2(1) = x(i, j, k, 1) - x(i, m, n, 1)
                    v2(2) = x(i, j, k, 2) - x(i, m, n, 2)
                    v2(3) = x(i, j, k, 3) - x(i, m, n, 3)
 
                    ! The face normal, which is the cross product of the two
                    ! diagonal vectors times fact; remember that fact is
                    ! either -0.5 or 0.5.
 
                    si(i, j, k, 1) = fact * (v1(2) * v2(3) - v1(3) * v2(2))
                    si(i, j, k, 2) = fact * (v1(3) * v2(1) - v1(1) * v2(3))
                    si(i, j, k, 3) = fact * (v1(1) * v2(2) - v1(2) * v2(1))
 
                end do
            end do
        end do
 
        ! Projected areas of cell faces in the j direction.
 
        do k = 1, ke
            n = k - 1
            do j = 0, je
                do i = 1, ie
                    l = i - 1
 
                    ! Determine the two diagonal vectors of the face.
 
                    v1(1) = x(i, j, n, 1) - x(l, j, k, 1)
                    v1(2) = x(i, j, n, 2) - x(l, j, k, 2)
                    v1(3) = x(i, j, n, 3) - x(l, j, k, 3)
 
                    v2(1) = x(l, j, n, 1) - x(i, j, k, 1)
                    v2(2) = x(l, j, n, 2) - x(i, j, k, 2)
                    v2(3) = x(l, j, n, 3) - x(i, j, k, 3)
 
                    ! The face normal, which is the cross product of the two
                    ! diagonal vectors times fact; remember that fact is
                    ! either -0.5 or 0.5.
 
                    sj(i, j, k, 1) = fact * (v1(2) * v2(3) - v1(3) * v2(2))
                    sj(i, j, k, 2) = fact * (v1(3) * v2(1) - v1(1) * v2(3))
                    sj(i, j, k, 3) = fact * (v1(1) * v2(2) - v1(2) * v2(1))
 
                end do
            end do
        end do
 
        ! Projected areas of cell faces in the k direction.
 
        do k = 0, ke
            do j = 1, je
                m = j - 1
                do i = 1, ie
                    l = i - 1
 
                    ! Determine the two diagonal vectors of the face.
 
                    v1(1) = x(i, j, k, 1) - x(l, m, k, 1)
                    v1(2) = x(i, j, k, 2) - x(l, m, k, 2)
                    v1(3) = x(i, j, k, 3) - x(l, m, k, 3)
 
                    v2(1) = x(l, j, k, 1) - x(i, m, k, 1)
                    v2(2) = x(l, j, k, 2) - x(i, m, k, 2)
                    v2(3) = x(l, j, k, 3) - x(i, m, k, 3)
 
                    ! The face normal, which is the cross product of the two
                    ! diagonal vectors times fact; remember that fact is
                    ! either -0.5 or 0.5.
 
                    sk(i, j, k, 1) = fact * (v1(2) * v2(3) - v1(3) * v2(2))
                    sk(i, j, k, 2) = fact * (v1(3) * v2(1) - v1(1) * v2(3))
                    sk(i, j, k, 3) = fact * (v1(1) * v2(2) - v1(2) * v2(1))
 
                end do
            end do
        end do
    end subroutine metrics
 
    subroutine initres(varStart, varEnd)
        ! ---------------------------------------------
        !                     Init Res
        ! ---------------------------------------------
 
        use constants
        implicit none
 
        integer(kind=intType) :: varStart, varEnd
        ! Obviously this needs to be more complex for the actual code.
        dw(:, :, :, varstart:varend) = zero
 
    end subroutine initres
 
    subroutine sasource
        ! ---------------------------------------------
        !                    SA Source Term
        ! ---------------------------------------------
 
        use constants
        use paramturb
        use blockpointers, only: sectionid
        use inputphysics, only: useft2sa, userotationsa, turbprod, equations
        use inputdiscretization, only: approxsa
        use section, only: sections
        use sa, only: cv13, kar2inv, cw36, cb3inv
        use flowvarrefstate, only: timeref
 
        implicit none
 
        ! Variables for sa Souce
        real(kind=realtype) :: fv1, fv2, ft2
        real(kind=realtype) :: sst, nu, dist2inv, chi, chi2, chi3
        real(kind=realtype) :: rr, gg, gg6, termfw, fwsa, term1, term2
        real(kind=realtype) :: dfv1, dfv2, dft2, drr, dgg, dfw, sqrtprod
        real(kind=realtype) :: uux, uuy, uuz, vvx, vvy, vvz, wwx, wwy, wwz
        real(kind=realtype) :: div2, fact, sxx, syy, szz, sxy, sxz, syz
        real(kind=realtype) :: vortx, vorty, vortz
        real(kind=realtype) :: omegax, omegay, omegaz
        real(kind=realtype) :: strainmag2, prod
        real(kind=realtype), parameter :: xminn = 1.e-10_realtype
        real(kind=realtype), parameter :: f23 = two * third
        integer(kind=intType) :: i, j, k
        real(kind=realtype) :: term1fact
 
        ! Set model constants
        cv13 = rsacv1**3
        kar2inv = one / (rsak**2)
        cw36 = rsacw3**6
        cb3inv = one / rsacb3
 
        ! set the approximate multiplier here
        term1fact = one
        if (approxsa) term1fact = zero
 
        ! Determine the non-dimensional wheel speed of this block.
 
        omegax = timeref * sections(sectionid)%rotRate(1)
        omegay = timeref * sections(sectionid)%rotRate(2)
        omegaz = timeref * sections(sectionid)%rotRate(3)
        do k = 2, kl
            do j = 2, jl
                do i = 2, il
 
                    ! Compute the gradient of u in the cell center. Use is made
                    ! of the fact that the surrounding normals sum up to zero,
                    ! such that the cell i,j,k does not give a contribution.
                    ! The gradient is scaled by the factor 2*vol.
 
                    uux = w(i + 1, j, k, ivx) * si(i, j, k, 1) - w(i - 1, j, k, ivx) * si(i - 1, j, k, 1) &
                          + w(i, j + 1, k, ivx) * sj(i, j, k, 1) - w(i, j - 1, k, ivx) * sj(i, j - 1, k, 1) &
                          + w(i, j, k + 1, ivx) * sk(i, j, k, 1) - w(i, j, k - 1, ivx) * sk(i, j, k - 1, 1)
                    uuy = w(i + 1, j, k, ivx) * si(i, j, k, 2) - w(i - 1, j, k, ivx) * si(i - 1, j, k, 2) &
                          + w(i, j + 1, k, ivx) * sj(i, j, k, 2) - w(i, j - 1, k, ivx) * sj(i, j - 1, k, 2) &
                          + w(i, j, k + 1, ivx) * sk(i, j, k, 2) - w(i, j, k - 1, ivx) * sk(i, j, k - 1, 2)
                    uuz = w(i + 1, j, k, ivx) * si(i, j, k, 3) - w(i - 1, j, k, ivx) * si(i - 1, j, k, 3) &
                          + w(i, j + 1, k, ivx) * sj(i, j, k, 3) - w(i, j - 1, k, ivx) * sj(i, j - 1, k, 3) &
                          + w(i, j, k + 1, ivx) * sk(i, j, k, 3) - w(i, j, k - 1, ivx) * sk(i, j, k - 1, 3)
 
                    ! Idem for the gradient of v.
 
                    vvx = w(i + 1, j, k, ivy) * si(i, j, k, 1) - w(i - 1, j, k, ivy) * si(i - 1, j, k, 1) &
                          + w(i, j + 1, k, ivy) * sj(i, j, k, 1) - w(i, j - 1, k, ivy) * sj(i, j - 1, k, 1) &
                          + w(i, j, k + 1, ivy) * sk(i, j, k, 1) - w(i, j, k - 1, ivy) * sk(i, j, k - 1, 1)
                    vvy = w(i + 1, j, k, ivy) * si(i, j, k, 2) - w(i - 1, j, k, ivy) * si(i - 1, j, k, 2) &
                          + w(i, j + 1, k, ivy) * sj(i, j, k, 2) - w(i, j - 1, k, ivy) * sj(i, j - 1, k, 2) &
                          + w(i, j, k + 1, ivy) * sk(i, j, k, 2) - w(i, j, k - 1, ivy) * sk(i, j, k - 1, 2)
                    vvz = w(i + 1, j, k, ivy) * si(i, j, k, 3) - w(i - 1, j, k, ivy) * si(i - 1, j, k, 3) &
                          + w(i, j + 1, k, ivy) * sj(i, j, k, 3) - w(i, j - 1, k, ivy) * sj(i, j - 1, k, 3) &
                          + w(i, j, k + 1, ivy) * sk(i, j, k, 3) - w(i, j, k - 1, ivy) * sk(i, j, k - 1, 3)
 
                    ! And for the gradient of w.
 
                    wwx = w(i + 1, j, k, ivz) * si(i, j, k, 1) - w(i - 1, j, k, ivz) * si(i - 1, j, k, 1) &
                          + w(i, j + 1, k, ivz) * sj(i, j, k, 1) - w(i, j - 1, k, ivz) * sj(i, j - 1, k, 1) &
                          + w(i, j, k + 1, ivz) * sk(i, j, k, 1) - w(i, j, k - 1, ivz) * sk(i, j, k - 1, 1)
                    wwy = w(i + 1, j, k, ivz) * si(i, j, k, 2) - w(i - 1, j, k, ivz) * si(i - 1, j, k, 2) &
                          + w(i, j + 1, k, ivz) * sj(i, j, k, 2) - w(i, j - 1, k, ivz) * sj(i, j - 1, k, 2) &
                          + w(i, j, k + 1, ivz) * sk(i, j, k, 2) - w(i, j, k - 1, ivz) * sk(i, j, k - 1, 2)
                    wwz = w(i + 1, j, k, ivz) * si(i, j, k, 3) - w(i - 1, j, k, ivz) * si(i - 1, j, k, 3) &
                          + w(i, j + 1, k, ivz) * sj(i, j, k, 3) - w(i, j - 1, k, ivz) * sj(i, j - 1, k, 3) &
                          + w(i, j, k + 1, ivz) * sk(i, j, k, 3) - w(i, j, k - 1, ivz) * sk(i, j, k - 1, 3)
 
                    ! Compute the components of the stress tensor.
                    ! The combination of the current scaling of the velocity
                    ! gradients (2*vol) and the definition of the stress tensor,
                    ! leads to the factor 1/(4*vol).
 
                    fact = fourth / vol(i, j, k)
 
                    ! -- Calcs for strain --
                    sxx = two * fact * uux
                    syy = two * fact * vvy
                    szz = two * fact * wwz
 
                    sxy = fact * (uuy + vvx)
                    sxz = fact * (uuz + wwx)
                    syz = fact * (vvz + wwy)
 
                    ! Compute 2/3 * divergence of velocity squared
 
                    div2 = f23 * (sxx + syy + szz)**2
 
                    ! Compute strain production term
 
                    strainmag2 = two * (sxy**2 + sxz**2 + syz**2) &
                                 + sxx**2 + syy**2 + szz**2
 
                    ! -- Calcs for vorticity --
 
                    ! Compute the three components of the vorticity vector.
                    ! Substract the part coming from the rotating frame.
 
                    vortx = two * fact * (wwy - vvz) - two * omegax
                    vorty = two * fact * (uuz - wwx) - two * omegay
                    vortz = two * fact * (vvx - uuy) - two * omegaz
 
                    if (turbprod == strain) then
                        sqrtprod = sqrt(max(two * strainmag2 - div2, eps))
                    else
                        sqrtprod = sqrt(vortx**2 + vorty**2 + vortz**2)
                    end if
 
                    ! Compute the laminar kinematic viscosity, the inverse of
                    ! wall distance squared, the ratio chi (ratio of nuTilde
                    ! and nu) and the functions fv1 and fv2. The latter corrects
                    ! the production term near a viscous wall.
 
                    nu = rlv(i, j, k) / w(i, j, k, irho)
                    dist2inv = one / (d2wall(i, j, k)**2)
                    chi = w(i, j, k, itu1) / nu
                    chi2 = chi * chi
                    chi3 = chi * chi2
                    fv1 = chi3 / (chi3 + cv13)
                    fv2 = one - chi / (one + chi * fv1)
 
                    ! The function ft2, which is designed to keep a laminar
                    ! solution laminar. When running in fully turbulent mode
                    ! this function should be set to 0.0.
 
                    ft2 = zero
                    if (useft2sa) then
                        ft2 = rsact3 * exp(-rsact4 * chi2)
                    end if
 
                    ! Correct the production term to account for the influence
                    ! of the wall.
 
                    sst = sqrtprod + w(i, j, k, itu1) * fv2 * kar2inv * dist2inv
 
                    ! Add rotation term (useRotationSA defined in inputParams.F90)
 
                    if (userotationsa) then
                        sst = sst + rsacrot * min(zero, sqrt(two * strainmag2))
                    end if
 
                    ! Make sure that this term remains positive
                    ! (the function fv2 is negative between chi = 1 and 18.4,
                    ! which can cause sst to go negative, which is undesirable).
 
                    sst = max(sst, xminn)
 
                    ! Compute the function fw. The argument rr is cut off at 10
                    ! to avoid numerical problems. This is ok, because the
                    ! asymptotical value of fw is then already reached.
 
                    rr = w(i, j, k, itu1) * kar2inv * dist2inv / sst
                    rr = min(rr, 10.0_realtype)
                    gg = rr + rsacw2 * (rr**6 - rr)
                    gg6 = gg**6
                    termfw = ((one + cw36) / (gg6 + cw36))**sixth
                    fwsa = gg * termfw
 
                    ! Compute the source term; some terms are saved for the
                    ! linearization. The source term is stored in dvt.
 
                    term1 = rsacb1 * (one - ft2) * sqrtprod * term1fact
                    term2 = dist2inv * (kar2inv * rsacb1 * ((one - ft2) * fv2 + ft2) &
                                        - rsacw1 * fwsa)
 
                    dw(i, j, k, itu1) = dw(i, j, k, itu1) + (term1 + term2 * w(i, j, k, itu1)) * w(i, j, k, itu1)
 
                end do
            end do
        end do
    end subroutine sasource
 
    subroutine saviscous
        ! ---------------------------------------------
        !                    SA Viscous Term
        ! ---------------------------------------------
 
        use constants
        use sa, only: cv13, kar2inv, cw36, cb3inv
        use paramturb
        implicit none
 
        ! Variables for sa Viscous
        real(kind=realtype) :: voli, volmi, volpi, xm, ym, zm, xp, yp, zp
        real(kind=realtype) :: xa, ya, za, ttm, ttp, cnud, cam, cap
        real(kind=realtype) :: nutm, nutp, num, nup, cdm, cdp
        real(kind=realtype) :: c1m, c1p, c10, b1, c1, d1, qs, nu
        integer(Kind=intType) :: i, j, k
 
        ! Set model constants
        cv13 = rsacv1**3
        kar2inv = one / (rsak**2)
        cw36 = rsacw3**6
        cb3inv = one / rsacb3
 
        !
        !       Viscous terms in k-direction.
        !
        do k = 2, kl
            do j = 2, jl
                do i = 2, il
 
                    ! Compute the metrics in zeta-direction, i.e. along the
                    ! line k = constant.
 
                    voli = one / vol(i, j, k)
                    volmi = two / (vol(i, j, k) + vol(i, j, k - 1))
                    volpi = two / (vol(i, j, k) + vol(i, j, k + 1))
 
                    xm = sk(i, j, k - 1, 1) * volmi
                    ym = sk(i, j, k - 1, 2) * volmi
                    zm = sk(i, j, k - 1, 3) * volmi
                    xp = sk(i, j, k, 1) * volpi
                    yp = sk(i, j, k, 2) * volpi
                    zp = sk(i, j, k, 3) * volpi
 
                    xa = half * (sk(i, j, k, 1) + sk(i, j, k - 1, 1)) * voli
                    ya = half * (sk(i, j, k, 2) + sk(i, j, k - 1, 2)) * voli
                    za = half * (sk(i, j, k, 3) + sk(i, j, k - 1, 3)) * voli
                    ttm = xm * xa + ym * ya + zm * za
                    ttp = xp * xa + yp * ya + zp * za
 
                    ! Computation of the viscous terms in zeta-direction; note
                    ! that cross-derivatives are neglected, i.e. the mesh is
                    ! assumed to be orthogonal.
                    ! Furthermore, the grad(nu)**2 has been rewritten as
                    ! div(nu grad(nu)) - nu div(grad nu) to enhance stability.
                    ! The second derivative in zeta-direction is constructed as
                    ! the central difference of the first order derivatives, i.e.
                    ! d^2/dzeta^2 = d/dzeta (d/dzeta k+1/2 - d/dzeta k-1/2).
                    ! In this way the metric can be taken into account.
 
                    ! Compute the diffusion coefficients multiplying the nodes
                    ! k+1, k and k-1 in the second derivative. Make sure that
                    ! these coefficients are nonnegative.
 
                    cnud = -rsacb2 * w(i, j, k, itu1) * cb3inv
                    cam = ttm * cnud
                    cap = ttp * cnud
 
                    nutm = half * (w(i, j, k - 1, itu1) + w(i, j, k, itu1))
                    nutp = half * (w(i, j, k + 1, itu1) + w(i, j, k, itu1))
                    nu = rlv(i, j, k) / w(i, j, k, irho)
                    num = half * (rlv(i, j, k - 1) / w(i, j, k - 1, irho) + nu)
                    nup = half * (rlv(i, j, k + 1) / w(i, j, k + 1, irho) + nu)
                    cdm = (num + (one + rsacb2) * nutm) * ttm * cb3inv
                    cdp = (nup + (one + rsacb2) * nutp) * ttp * cb3inv
 
                    c1m = max(cdm + cam, zero)
                    c1p = max(cdp + cap, zero)
                    c10 = c1m + c1p
 
                    ! Update the residual for this cell and store the possible
                    ! coefficients for the matrix in b1, c1 and d1.
 
                    dw(i, j, k, itu1) = dw(i, j, k, itu1) + c1m * w(i, j, k - 1, itu1) &
                                        - c10 * w(i, j, k, itu1) + c1p * w(i, j, k + 1, itu1)
                end do
            end do
        end do
        !
        !       Viscous terms in j-direction.
        !
        do k = 2, kl
            do j = 2, jl
                do i = 2, il
 
                    ! Compute the metrics in eta-direction, i.e. along the
                    ! line j = constant.
 
                    voli = one / vol(i, j, k)
                    volmi = two / (vol(i, j, k) + vol(i, j - 1, k))
                    volpi = two / (vol(i, j, k) + vol(i, j + 1, k))
 
                    xm = sj(i, j - 1, k, 1) * volmi
                    ym = sj(i, j - 1, k, 2) * volmi
                    zm = sj(i, j - 1, k, 3) * volmi
                    xp = sj(i, j, k, 1) * volpi
                    yp = sj(i, j, k, 2) * volpi
                    zp = sj(i, j, k, 3) * volpi
 
                    xa = half * (sj(i, j, k, 1) + sj(i, j - 1, k, 1)) * voli
                    ya = half * (sj(i, j, k, 2) + sj(i, j - 1, k, 2)) * voli
                    za = half * (sj(i, j, k, 3) + sj(i, j - 1, k, 3)) * voli
                    ttm = xm * xa + ym * ya + zm * za
                    ttp = xp * xa + yp * ya + zp * za
 
                    ! Computation of the viscous terms in eta-direction; note
                    ! that cross-derivatives are neglected, i.e. the mesh is
                    ! assumed to be orthogonal.
                    ! Furthermore, the grad(nu)**2 has been rewritten as
                    ! div(nu grad(nu)) - nu div(grad nu) to enhance stability.
                    ! The second derivative in eta-direction is constructed as
                    ! the central difference of the first order derivatives, i.e.
                    ! d^2/deta^2 = d/deta (d/deta j+1/2 - d/deta j-1/2).
                    ! In this way the metric can be taken into account.
 
                    ! Compute the diffusion coefficients multiplying the nodes
                    ! j+1, j and j-1 in the second derivative. Make sure that
                    ! these coefficients are nonnegative.
 
                    cnud = -rsacb2 * w(i, j, k, itu1) * cb3inv
                    cam = ttm * cnud
                    cap = ttp * cnud
 
                    nutm = half * (w(i, j - 1, k, itu1) + w(i, j, k, itu1))
                    nutp = half * (w(i, j + 1, k, itu1) + w(i, j, k, itu1))
                    nu = rlv(i, j, k) / w(i, j, k, irho)
                    num = half * (rlv(i, j - 1, k) / w(i, j - 1, k, irho) + nu)
                    nup = half * (rlv(i, j + 1, k) / w(i, j + 1, k, irho) + nu)
                    cdm = (num + (one + rsacb2) * nutm) * ttm * cb3inv
                    cdp = (nup + (one + rsacb2) * nutp) * ttp * cb3inv
 
                    c1m = max(cdm + cam, zero)
                    c1p = max(cdp + cap, zero)
                    c10 = c1m + c1p
 
                    ! Update the residual for this cell and store the possible
                    ! coefficients for the matrix in b1, c1 and d1.
 
                    dw(i, j, k, itu1) = dw(i, j, k, itu1) + c1m * w(i, j - 1, k, itu1) &
                                        - c10 * w(i, j, k, itu1) + c1p * w(i, j + 1, k, itu1)
 
                end do
            end do
        end do
        !
        !       Viscous terms in i-direction.
        !
        do k = 2, kl
            do j = 2, jl
                do i = 2, il
 
                    ! Compute the metrics in xi-direction, i.e. along the
                    ! line i = constant.
 
                    voli = one / vol(i, j, k)
                    volmi = two / (vol(i, j, k) + vol(i - 1, j, k))
                    volpi = two / (vol(i, j, k) + vol(i + 1, j, k))
 
                    xm = si(i - 1, j, k, 1) * volmi
                    ym = si(i - 1, j, k, 2) * volmi
                    zm = si(i - 1, j, k, 3) * volmi
                    xp = si(i, j, k, 1) * volpi
                    yp = si(i, j, k, 2) * volpi
                    zp = si(i, j, k, 3) * volpi
 
                    xa = half * (si(i, j, k, 1) + si(i - 1, j, k, 1)) * voli
                    ya = half * (si(i, j, k, 2) + si(i - 1, j, k, 2)) * voli
                    za = half * (si(i, j, k, 3) + si(i - 1, j, k, 3)) * voli
                    ttm = xm * xa + ym * ya + zm * za
                    ttp = xp * xa + yp * ya + zp * za
 
                    ! Computation of the viscous terms in xi-direction; note
                    ! that cross-derivatives are neglected, i.e. the mesh is
                    ! assumed to be orthogonal.
                    ! Furthermore, the grad(nu)**2 has been rewritten as
                    ! div(nu grad(nu)) - nu div(grad nu) to enhance stability.
                    ! The second derivative in xi-direction is constructed as
                    ! the central difference of the first order derivatives, i.e.
                    ! d^2/dxi^2 = d/dxi (d/dxi i+1/2 - d/dxi i-1/2).
                    ! In this way the metric can be taken into account.
 
                    ! Compute the diffusion coefficients multiplying the nodes
                    ! i+1, i and i-1 in the second derivative. Make sure that
                    ! these coefficients are nonnegative.
 
                    cnud = -rsacb2 * w(i, j, k, itu1) * cb3inv
                    cam = ttm * cnud
                    cap = ttp * cnud
 
                    nutm = half * (w(i - 1, j, k, itu1) + w(i, j, k, itu1))
                    nutp = half * (w(i + 1, j, k, itu1) + w(i, j, k, itu1))
                    nu = rlv(i, j, k) / w(i, j, k, irho)
                    num = half * (rlv(i - 1, j, k) / w(i - 1, j, k, irho) + nu)
                    nup = half * (rlv(i + 1, j, k) / w(i + 1, j, k, irho) + nu)
                    cdm = (num + (one + rsacb2) * nutm) * ttm * cb3inv
                    cdp = (nup + (one + rsacb2) * nutp) * ttp * cb3inv
 
                    c1m = max(cdm + cam, zero)
                    c1p = max(cdp + cap, zero)
                    c10 = c1m + c1p
 
                    ! Update the residual for this cell and store the possible
                    ! coefficients for the matrix in b1, c1 and d1.
 
                    dw(i, j, k, itu1) = dw(i, j, k, itu1) + c1m * w(i - 1, j, k, itu1) &
                                        - c10 * w(i, j, k, itu1) + c1p * w(i + 1, j, k, itu1)
                end do
            end do
        end do
    end subroutine saviscous
 
    subroutine saadvection
        ! ---------------------------------------------
        !                SA Advection
        ! ---------------------------------------------
        use constants
        use inputdiscretization, only: orderturb
        use iteration, only: groundlevel
        use turbmod, only: secondord
        implicit none
 
        ! Variables for sa Advection
        real(kind=realtype) :: uu, dwt, dwtm1, dwtp1, dwti, dwtj, dwtk, qs
        real(kind=realtype) :: voli, xa, ya, za
        integer(kind=intType), parameter :: nAdv = 1
        integer(kind=intType) :: offset, i, j, k, ii, jj
 
        ! Determine whether or not a second order discretization for the
        ! advective terms must be used.
        secondord = .false.
        if (groundlevel == 1_inttype .and. &
            orderturb == secondorder) secondord = .true.
 
        offset = itu1 - 1
        do k = 2, kl
            do j = 2, jl
                do i = 2, il
 
                    ! Compute the grid velocity if present.
                    ! It is taken as the average of k and k-1,
 
                    voli = half / vol(i, j, k)
                    qs = (sfacek(i, j, k) + sfacek(i, j, k - 1)) * voli
 
                    ! Compute the normal velocity, where the normal direction
                    ! is taken as the average of faces k and k-1.
 
                    xa = (sk(i, j, k, 1) + sk(i, j, k - 1, 1)) * voli
                    ya = (sk(i, j, k, 2) + sk(i, j, k - 1, 2)) * voli
                    za = (sk(i, j, k, 3) + sk(i, j, k - 1, 3)) * voli
 
                    uu = xa * w(i, j, k, ivx) + ya * w(i, j, k, ivy) + za * w(i, j, k, ivz) - qs
 
                    ! Determine the situation we are having here, i.e. positive
                    ! or negative normal velocity.
 
                    velkdir: if (uu > zero) then
 
                        ! Velocity has a component in positive k-direction.
                        ! Loop over the number of advection equations.
 
                        do ii = 1, nadv
 
                            ! Set the value of jj such that it corresponds to the
                            ! turbulent entry in w.
 
                            jj = ii + offset
 
                            ! Check whether a first or a second order discretization
                            ! must be used.
 
                            if (secondord) then
 
                                ! Second order; store the three differences for the
                                ! discretization of the derivative in k-direction.
 
                                dwtm1 = w(i, j, k - 1, jj) - w(i, j, k - 2, jj)
                                dwt = w(i, j, k, jj) - w(i, j, k - 1, jj)
                                dwtp1 = w(i, j, k + 1, jj) - w(i, j, k, jj)
 
                                ! Construct the derivative in this cell center. This
                                ! is the first order upwind derivative with two
                                ! nonlinear corrections.
 
                                dwtk = dwt
 
                                if (dwt * dwtp1 > zero) then
                                    if (abs(dwt) < abs(dwtp1)) then
                                        dwtk = dwtk + half * dwt
                                    else
                                        dwtk = dwtk + half * dwtp1
                                    end if
                                end if
 
                                if (dwt * dwtm1 > zero) then
                                    if (abs(dwt) < abs(dwtm1)) then
                                        dwtk = dwtk - half * dwt
                                    else
                                        dwtk = dwtk - half * dwtm1
                                    end if
                                end if
 
                            else
 
                                ! 1st order upwind scheme.
 
                                dwtk = w(i, j, k, jj) - w(i, j, k - 1, jj)
 
                            end if
 
                            ! Update the residual. The convective term must be
                            ! substracted, because it appears on the other side of
                            ! the equation as the source and viscous terms.
 
                            dw(i, j, k, itu1 + ii - 1) = dw(i, j, k, itu1 + ii - 1) - uu * dwtk
                        end do
 
                        else velkdir
 
                        ! Velocity has a component in negative k-direction.
                        ! Loop over the number of advection equations
                        do ii = 1, nadv
 
                            ! Set the value of jj such that it corresponds to the
                            ! turbulent entry in w.
 
                            jj = ii + offset
 
                            ! Check whether a first or a second order discretization
                            ! must be used.
 
                            if (secondord) then
 
                                ! Store the three differences for the discretization of
                                ! the derivative in k-direction.
 
                                dwtm1 = w(i, j, k, jj) - w(i, j, k - 1, jj)
                                dwt = w(i, j, k + 1, jj) - w(i, j, k, jj)
                                dwtp1 = w(i, j, k + 2, jj) - w(i, j, k + 1, jj)
 
                                ! Construct the derivative in this cell center. This is
                                ! the first order upwind derivative with two nonlinear
                                ! corrections.
 
                                dwtk = dwt
 
                                if (dwt * dwtp1 > zero) then
                                    if (abs(dwt) < abs(dwtp1)) then
                                        dwtk = dwtk - half * dwt
                                    else
                                        dwtk = dwtk - half * dwtp1
                                    end if
                                end if
 
                                if (dwt * dwtm1 > zero) then
                                    if (abs(dwt) < abs(dwtm1)) then
                                        dwtk = dwtk + half * dwt
                                    else
                                        dwtk = dwtk + half * dwtm1
                                    end if
                                end if
 
                            else
 
                                ! 1st order upwind scheme.
 
                                dwtk = w(i, j, k + 1, jj) - w(i, j, k, jj)
 
                            end if
 
                            ! Update the residual. The convective term must be
                            ! substracted, because it appears on the other side
                            ! of the equation as the source and viscous terms.
 
                            dw(i, j, k, itu1 + ii - 1) = dw(i, j, k, itu1 + ii - 1) - uu * dwtk
                        end do
                    end if velkdir
                end do
            end do
        end do
 
        !
        !       Upwind discretization of the convective term in j (eta)
        !       direction. Either the 1st order upwind or the second order
        !       fully upwind interpolation scheme, kappa = -1, is used in
        !       combination with the minmod limiter.
        !       The possible grid velocity must be taken into account.
        !
        do k = 2, kl
            do j = 2, jl
                do i = 2, il
 
                    ! Compute the grid velocity if present.
                    ! It is taken as the average of j and j-1,
 
                    voli = half / vol(i, j, k)
                    qs = (sfacej(i, j, k) + sfacej(i, j - 1, k)) * voli
 
                    ! Compute the normal velocity, where the normal direction
                    ! is taken as the average of faces j and j-1.
 
                    xa = (sj(i, j, k, 1) + sj(i, j - 1, k, 1)) * voli
                    ya = (sj(i, j, k, 2) + sj(i, j - 1, k, 2)) * voli
                    za = (sj(i, j, k, 3) + sj(i, j - 1, k, 3)) * voli
 
                    uu = xa * w(i, j, k, ivx) + ya * w(i, j, k, ivy) + za * w(i, j, k, ivz) - qs
 
                    ! Determine the situation we are having here, i.e. positive
                    ! or negative normal velocity.
 
                    veljdir: if (uu > zero) then
 
                        ! Velocity has a component in positive j-direction.
                        ! Loop over the number of advection equations.
                        do ii = 1, nadv
 
                            ! Set the value of jj such that it corresponds to the
                            ! turbulent entry in w.
 
                            jj = ii + offset
 
                            ! Check whether a first or a second order discretization
                            ! must be used.
 
                            if (secondord) then
 
                                ! Second order; store the three differences for the
                                ! discretization of the derivative in j-direction.
 
                                dwtm1 = w(i, j - 1, k, jj) - w(i, j - 2, k, jj)
                                dwt = w(i, j, k, jj) - w(i, j - 1, k, jj)
                                dwtp1 = w(i, j + 1, k, jj) - w(i, j, k, jj)
 
                                ! Construct the derivative in this cell center. This is
                                ! the first order upwind derivative with two nonlinear
                                ! corrections.
 
                                dwtj = dwt
 
                                if (dwt * dwtp1 > zero) then
                                    if (abs(dwt) < abs(dwtp1)) then
                                        dwtj = dwtj + half * dwt
                                    else
                                        dwtj = dwtj + half * dwtp1
                                    end if
                                end if
 
                                if (dwt * dwtm1 > zero) then
                                    if (abs(dwt) < abs(dwtm1)) then
                                        dwtj = dwtj - half * dwt
                                    else
                                        dwtj = dwtj - half * dwtm1
                                    end if
                                end if
 
                            else
 
                                ! 1st order upwind scheme.
 
                                dwtj = w(i, j, k, jj) - w(i, j - 1, k, jj)
 
                            end if
 
                            ! Update the residual. The convective term must be
                            ! substracted, because it appears on the other side of
                            ! the equation as the source and viscous terms.
 
                            dw(i, j, k, itu1 + ii - 1) = dw(i, j, k, itu1 + ii - 1) - uu * dwtj
                        end do
 
                        else veljdir
 
                        ! Velocity has a component in negative j-direction.
                        ! Loop over the number of advection equations.
                        do ii = 1, nadv
 
                            ! Set the value of jj such that it corresponds to the
                            ! turbulent entry in w.
 
                            jj = ii + offset
 
                            ! Check whether a first or a second order discretization
                            ! must be used.
 
                            if (secondord) then
 
                                ! Store the three differences for the discretization of
                                ! the derivative in j-direction.
 
                                dwtm1 = w(i, j, k, jj) - w(i, j - 1, k, jj)
                                dwt = w(i, j + 1, k, jj) - w(i, j, k, jj)
                                dwtp1 = w(i, j + 2, k, jj) - w(i, j + 1, k, jj)
 
                                ! Construct the derivative in this cell center. This is
                                ! the first order upwind derivative with two nonlinear
                                ! corrections.
 
                                dwtj = dwt
 
                                if (dwt * dwtp1 > zero) then
                                    if (abs(dwt) < abs(dwtp1)) then
                                        dwtj = dwtj - half * dwt
                                    else
                                        dwtj = dwtj - half * dwtp1
                                    end if
                                end if
 
                                if (dwt * dwtm1 > zero) then
                                    if (abs(dwt) < abs(dwtm1)) then
                                        dwtj = dwtj + half * dwt
                                    else
                                        dwtj = dwtj + half * dwtm1
                                    end if
                                end if
 
                            else
 
                                ! 1st order upwind scheme.
 
                                dwtj = w(i, j + 1, k, jj) - w(i, j, k, jj)
 
                            end if
 
                            ! Update the residual. The convective term must be
                            ! substracted, because it appears on the other side
                            ! of the equation as the source and viscous terms.
 
                            dw(i, j, k, itu1 + ii - 1) = dw(i, j, k, itu1 + ii - 1) - uu * dwtj
                        end do
                    end if veljdir
                end do
            end do
        end do
        !
        !       Upwind discretization of the convective term in i (xi)
        !       direction. Either the 1st order upwind or the second order
        !       fully upwind interpolation scheme, kappa = -1, is used in
        !       combination with the minmod limiter.
        !       The possible grid velocity must be taken into account.
        !
        qs = zero
        do k = 2, kl
            do j = 2, jl
                do i = 2, il
                    ! Compute the grid velocity if present.
                    ! It is taken as the average of i and i-1,
 
                    voli = half / vol(i, j, k)
                    qs = (sfacei(i, j, k) + sfacei(i - 1, j, k)) * voli
 
                    ! Compute the normal velocity, where the normal direction
                    ! is taken as the average of faces i and i-1.
 
                    xa = (si(i, j, k, 1) + si(i - 1, j, k, 1)) * voli
                    ya = (si(i, j, k, 2) + si(i - 1, j, k, 2)) * voli
                    za = (si(i, j, k, 3) + si(i - 1, j, k, 3)) * voli
 
                    uu = xa * w(i, j, k, ivx) + ya * w(i, j, k, ivy) + za * w(i, j, k, ivz) - qs
 
                    ! Determine the situation we are having here, i.e. positive
                    ! or negative normal velocity.
 
                    velidir: if (uu > zero) then
 
                        ! Velocity has a component in positive i-direction.
                        ! Loop over the number of advection equations.
                        do ii = 1, nadv
 
                            ! Set the value of jj such that it corresponds to the
                            ! turbulent entry in w.
 
                            jj = ii + offset
 
                            ! Check whether a first or a second order discretization
                            ! must be used.
 
                            if (secondord) then
 
                                ! Second order; store the three differences for the
                                ! discretization of the derivative in i-direction.
 
                                dwtm1 = w(i - 1, j, k, jj) - w(i - 2, j, k, jj)
                                dwt = w(i, j, k, jj) - w(i - 1, j, k, jj)
                                dwtp1 = w(i + 1, j, k, jj) - w(i, j, k, jj)
 
                                ! Construct the derivative in this cell center. This is
                                ! the first order upwind derivative with two nonlinear
                                ! corrections.
 
                                dwti = dwt
 
                                if (dwt * dwtp1 > zero) then
                                    if (abs(dwt) < abs(dwtp1)) then
                                        dwti = dwti + half * dwt
                                    else
                                        dwti = dwti + half * dwtp1
                                    end if
                                end if
 
                                if (dwt * dwtm1 > zero) then
                                    if (abs(dwt) < abs(dwtm1)) then
                                        dwti = dwti - half * dwt
                                    else
                                        dwti = dwti - half * dwtm1
                                    end if
                                end if
 
                            else
 
                                ! 1st order upwind scheme.
 
                                dwti = w(i, j, k, jj) - w(i - 1, j, k, jj)
 
                            end if
 
                            ! Update the residual. The convective term must be
                            ! substracted, because it appears on the other side of
                            ! the equation as the source and viscous terms.
 
                            dw(i, j, k, itu1 + ii - 1) = dw(i, j, k, itu1 + ii - 1) - uu * dwti
                        end do
 
                        else velidir
 
                        ! Velocity has a component in negative i-direction.
                        ! Loop over the number of advection equations.
                        do ii = 1, nadv
 
                            ! Set the value of jj such that it corresponds to the
                            ! turbulent entry in w.
 
                            jj = ii + offset
 
                            ! Check whether a first or a second order discretization
                            ! must be used.
 
                            if (secondord) then
 
                                ! Second order; store the three differences for the
                                ! discretization of the derivative in i-direction.
 
                                dwtm1 = w(i, j, k, jj) - w(i - 1, j, k, jj)
                                dwt = w(i + 1, j, k, jj) - w(i, j, k, jj)
                                dwtp1 = w(i + 2, j, k, jj) - w(i + 1, j, k, jj)
 
                                ! Construct the derivative in this cell center. This is
                                ! the first order upwind derivative with two nonlinear
                                ! corrections.
 
                                dwti = dwt
 
                                if (dwt * dwtp1 > zero) then
                                    if (abs(dwt) < abs(dwtp1)) then
                                        dwti = dwti - half * dwt
                                    else
                                        dwti = dwti - half * dwtp1
                                    end if
                                end if
 
                                if (dwt * dwtm1 > zero) then
                                    if (abs(dwt) < abs(dwtm1)) then
                                        dwti = dwti + half * dwt
                                    else
                                        dwti = dwti + half * dwtm1
                                    end if
                                end if
 
                            else
 
                                ! 1st order upwind scheme.
 
                                dwti = w(i + 1, j, k, jj) - w(i, j, k, jj)
 
                            end if
 
                            ! Update the residual. The convective term must be
                            ! substracted, because it appears on the other side
                            ! of the equation as the source and viscous terms.
 
                            dw(i, j, k, itu1 + ii - 1) = dw(i, j, k, itu1 + ii - 1) - uu * dwti
 
                            ! Update the central jacobian. First the term which is
                            ! always present, i.e. -uu.
                        end do
 
                    end if velidir
                end do
            end do
        end do
    end subroutine saadvection
 
    subroutine saresscale
 
        !
        !  Multiply the residual by the volume and store this in dw; this
        ! * is done for monitoring reasons only. The multiplication with the
        ! * volume is present to be consistent with the flow residuals; also
        !  the negative value is taken, again to be consistent with the
        ! * flow equations. Also multiply by iblank so that no updates occur
        !  in holes or the overset boundary.
        use constants
        implicit none
 
        ! Local variables
        integer(kind=intType) :: i, j, k, ii
        real(kind=realtype) :: rblank
 
        do k = 2, kl
            do j = 2, jl
                do i = 2, il
                    rblank = max(real(iblank(i, j, k), realtype), zero)
                    dw(i, j, k, itu1) = -volref(i, j, k) * dw(i, j, k, itu1) * rblank
                end do
            end do
        end do
 
    end subroutine saresscale
 
    subroutine timestep(updateDtl)
        ! ---------------------------------------------
        !               Spectral Radius
        ! ---------------------------------------------
 
        use constants
        use blockpointers, only: sectionid
        use flowvarrefstate, only: pinfcorr, rhoinf, gammainf, viscous, timeref
        use inputphysics, only: equationmode
        use inputdiscretization, only: adis, acousticscalefactor
        use section, only: sections
        use inputtimespectral, only: ntimeintervalsspectral
 
        implicit none
 
        ! Input
        logical, intent(in), optional :: updateDtl
 
        ! Local parameters.
        real(kind=realtype), parameter :: b = 2.0_realtype
 
        ! Variables for spectral Radius
        real(kind=realtype) :: plim, rlim, clim2
        real(kind=realtype) :: cc2, qsi, qsj, qsk, sx, sy, sz, rmu
        real(kind=realtype) :: ri, rj, rk, rij, rjk, rki
        real(kind=realtype) :: vsi, vsj, vsk, rfl, dpi, dpj, dpk
        real(kind=realtype) :: sface, tmp, uux, uuy, uuz
        logical :: doScaling, updateDt
        integer(kind=intType) :: i, j, k
 
        updatedt = .false.
        if (present(updatedtl)) then
            updatedt = .true.
        end if
 
        ! Set the value of plim. To be fully consistent this must have
        ! the dimension of a pressure. Therefore a fraction of pInfCorr
        ! is used. Idem for rlim; compute clim2 as well.
 
        plim = 0.001_realtype * pinfcorr
        rlim = 0.001_realtype * rhoinf
        clim2 = 0.000001_realtype * gammainf * pinfcorr / rhoinf
        doscaling = .true.
 
        ! Initialize sFace to zero. This value will be used if the
        ! block is not moving.
 
        sface = zero
        !
        !           Inviscid contribution, depending on the preconditioner.
        !           Compute the cell centered values of the spectral radii.
        !
        ! Note:  DON'T change the ranges for i. It will mess up dtl.
        ! we don't copy the spectral-radii and dtl to keep the
        ! code simple, therefore this loop needs the full single
        ! halo range.
        do k = 1, ke
            do j = 1, je
                do i = 1, ie
 
                    ! Compute the velocities and speed of sound squared.
 
                    uux = w(i, j, k, ivx)
                    uuy = w(i, j, k, ivy)
                    uuz = w(i, j, k, ivz)
                    cc2 = gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho)
                    cc2 = max(cc2, clim2)
 
                    ! Set the dot product of the grid velocity and the
                    ! normal in i-direction for a moving face. To avoid
                    ! a number of multiplications by 0.5 simply the sum
                    ! is taken.
 
                    sface = sfacei(i - 1, j, k) + sfacei(i, j, k)
 
                    ! Spectral radius in i-direction.
 
                    sx = si(i - 1, j, k, 1) + si(i, j, k, 1)
                    sy = si(i - 1, j, k, 2) + si(i, j, k, 2)
                    sz = si(i - 1, j, k, 3) + si(i, j, k, 3)
 
                    qsi = uux * sx + uuy * sy + uuz * sz - sface
 
                    ri = half * (abs(qsi) &
                                 + acousticscalefactor * sqrt(cc2 * (sx**2 + sy**2 + sz**2)))
 
                    ! The grid velocity in j-direction.
                    sface = sfacej(i, j - 1, k) + sfacej(i, j, k)
 
                    ! Spectral radius in j-direction.
 
                    sx = sj(i, j - 1, k, 1) + sj(i, j, k, 1)
                    sy = sj(i, j - 1, k, 2) + sj(i, j, k, 2)
                    sz = sj(i, j - 1, k, 3) + sj(i, j, k, 3)
 
                    qsj = uux * sx + uuy * sy + uuz * sz - sface
 
                    rj = half * (abs(qsj) &
                                 + acousticscalefactor * sqrt(cc2 * (sx**2 + sy**2 + sz**2)))
 
                    ! The grid velocity in k-direction.
                    sface = sfacek(i, j, k - 1) + sfacek(i, j, k)
 
                    ! Spectral radius in k-direction.
 
                    sx = sk(i, j, k - 1, 1) + sk(i, j, k, 1)
                    sy = sk(i, j, k - 1, 2) + sk(i, j, k, 2)
                    sz = sk(i, j, k - 1, 3) + sk(i, j, k, 3)
 
                    qsk = uux * sx + uuy * sy + uuz * sz - sface
 
                    rk = half * (abs(qsk) &
                                 + acousticscalefactor * sqrt(cc2 * (sx**2 + sy**2 + sz**2)))
 
                    ! Store in tdl if required
                    if (updatedt) then
                        dtl(i, j, k) = ri + rj + rk
                    end if
 
                    ! Avoid division by zero by clipping radi, radJ and
                    ! radK.
 
                    ri = max(ri, eps)
                    rj = max(rj, eps)
                    rk = max(rk, eps)
 
                    ! Compute the scaling in the three coordinate
                    ! directions.
 
                    rij = (ri / rj)**adis
                    rjk = (rj / rk)**adis
                    rki = (rk / ri)**adis
 
                    ! Create the scaled versions of the aspect ratios.
                    ! Note that the multiplication is done with radi, radJ
                    ! and radK, such that the influence of the clipping
                    ! is negligible.
 
                    radi(i, j, k) = ri * (one + one / rij + rki)
                    radj(i, j, k) = rj * (one + one / rjk + rij)
                    radk(i, j, k) = rk * (one + one / rki + rjk)
                end do
            end do
        end do
 
        ! The rest is only necessary if the timeStep needs to be computed
        if (updatedt) then
 
            viscousterm: if (viscous) then
 
                ! Loop over the owned cell centers.
 
                do k = 2, kl
                    do j = 2, jl
                        do i = 2, il
 
                            ! Compute the effective viscosity coefficient. The
                            ! factor 0.5 is a combination of two things. In the
                            ! standard central discretization of a second
                            ! derivative there is a factor 2 multiplying the
                            ! central node. However in the code below not the
                            ! average but the sum of the left and the right face
                            ! is taken and squared. This leads to a factor 4.
                            ! Combining both effects leads to 0.5. Furthermore,
                            ! it is divided by the volume and density to obtain
                            ! the correct dimensions and multiplied by the
                            ! non-dimensional factor factVis.
 
                            rmu = rlv(i, j, k)
                            rmu = rmu + rev(i, j, k)
                            rmu = half * rmu / (w(i, j, k, irho) * vol(i, j, k))
 
                            ! Add the viscous contribution in i-direction to the
                            ! (inverse) of the time step.
 
                            sx = si(i, j, k, 1) + si(i - 1, j, k, 1)
                            sy = si(i, j, k, 2) + si(i - 1, j, k, 2)
                            sz = si(i, j, k, 3) + si(i - 1, j, k, 3)
 
                            vsi = rmu * (sx * sx + sy * sy + sz * sz)
                            dtl(i, j, k) = dtl(i, j, k) + vsi
 
                            ! Add the viscous contribution in j-direction to the
                            ! (inverse) of the time step.
 
                            sx = sj(i, j, k, 1) + sj(i, j - 1, k, 1)
                            sy = sj(i, j, k, 2) + sj(i, j - 1, k, 2)
                            sz = sj(i, j, k, 3) + sj(i, j - 1, k, 3)
 
                            vsj = rmu * (sx * sx + sy * sy + sz * sz)
                            dtl(i, j, k) = dtl(i, j, k) + vsj
 
                            ! Add the viscous contribution in k-direction to the
                            ! (inverse) of the time step.
 
                            sx = sk(i, j, k, 1) + sk(i, j, k - 1, 1)
                            sy = sk(i, j, k, 2) + sk(i, j, k - 1, 2)
                            sz = sk(i, j, k, 3) + sk(i, j, k - 1, 3)
 
                            vsk = rmu * (sx * sx + sy * sy + sz * sz)
                            dtl(i, j, k) = dtl(i, j, k) + vsk
 
                        end do
                    end do
                end do
            end if viscousterm
 
            ! For the spectral mode an additional term term must be
            ! taken into account, which corresponds to the contribution
            ! of the highest frequency.
 
            if (equationmode == timespectral) then
 
                tmp = ntimeintervalsspectral * pi * timeref &
                      / sections(sectionid)%timePeriod
 
                ! Loop over the owned cell centers and add the term.
 
                do k = 2, kl
                    do j = 2, jl
                        do i = 2, il
                            dtl(i, j, k) = dtl(i, j, k) + tmp * vol(i, j, k)
                        end do
                    end do
                end do
 
            end if
 
            ! Currently the inverse of dt/vol is stored in dtl. Invert
            ! this value such that the time step per unit cfl number is
            ! stored and correct in cases of high gradients.
 
            do k = 2, kl
                do j = 2, jl
                    do i = 2, il
                        dpi = abs(p(i + 1, j, k) - two * p(i, j, k) + p(i - 1, j, k)) &
                              / (p(i + 1, j, k) + two * p(i, j, k) + p(i - 1, j, k) + plim)
                        dpj = abs(p(i, j + 1, k) - two * p(i, j, k) + p(i, j - 1, k)) &
                              / (p(i, j + 1, k) + two * p(i, j, k) + p(i, j - 1, k) + plim)
                        dpk = abs(p(i, j, k + 1) - two * p(i, j, k) + p(i, j, k - 1)) &
                              / (p(i, j, k + 1) + two * p(i, j, k) + p(i, j, k - 1) + plim)
                        rfl = one / (one + b * (dpi + dpj + dpk))
 
                        dtl(i, j, k) = rfl / dtl(i, j, k)
                    end do
                end do
            end do
        end if
 
    end subroutine timestep
 
    subroutine inviscidcentralflux
 
        ! ---------------------------------------------
        !               Inviscid central flux
        ! ---------------------------------------------
        use constants
        use blockpointers, only: blockismoving, nbkglobal
        use flowvarrefstate, only: timeref
        use cgnsgrid, only: cgnsdoms
        use inputphysics, only: equationmode
        implicit none
 
        ! Variables for inviscid central flux
        real(kind=realtype) :: qsp, qsm, rqsp, rqsm, porvel, porflux
        real(kind=realtype) :: pa, vnp, vnm, fs, sface
        integer(kind=intType) :: i, j, k
        real(kind=realtype) :: wwx, wwy, wwz, rvol
 
        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.
 
                    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) == noflux) porflux = zero
                    if (pori(i, j, k) == 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
 
        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.
 
                    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) == noflux) porflux = zero
                    if (porj(i, j, k) == 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
 
        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.
 
                    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) == noflux) porflux = zero
                    if (pork(i, j, k) == 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
 
        rotation: if (blockismoving .and. equationmode == 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)
 
            ! Loop over the internal cells of this block to compute the
            ! rotational terms for the momentum equations.
            do k = 2, kl
                do j = 2, jl
                    do i = 2, il
                        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 do
            end do
        end if rotation
 
    end subroutine inviscidcentralflux
 
    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 flowvarrefstate, only: pinfcorr
        use inputdiscretization, only: vis2, vis4
        use inputphysics, only: equations
        use iteration, only: rfil
        use utils, 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
        logical :: correctForK
 
        ! 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 = singlehalostart, ie
                    dss(i, j, k, 1) = abs((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 * (abs(p(i + 1, j, k) - p(i, j, k)) &
                                                              + abs(p(i, j, k) - p(i - 1, j, k))) + plim))
 
                    dss(i, j, k, 2) = abs((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 * (abs(p(i, j + 1, k) - p(i, j, k)) &
                                                              + abs(p(i, j, k) - p(i, j - 1, k))) + plim))
 
                    dss(i, j, k, 3) = abs((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 * (abs(p(i, j, k + 1) - p(i, j, k)) &
                                                              + abs(p(i, j, k) - p(i, j, k - 1))) + plim))
                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) == normalflux) ppor = one
                    dis2 = ppor * fis2 * min(dpmax, max(dss(i, j, k, 1), dss(i + 1, j, k, 1)))
                    dis4 = dim(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.
                    drk = zero
                    kavg = zero
 
                    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))
                    end if
 
                    ! Compute the average value of gamma and compute some
                    ! expressions in which it occurs.
 
                    gammaavg = half * (gamma(i + 1, j, k) + gamma(i, j, k))
                    gm1 = gammaavg - one
                    ovgm1 = one / gm1
                    gm53 = gammaavg - five * third
 
                    ! Compute the average state at the interface.
 
                    uavg = half * (w(i + 1, j, k, ivx) + w(i, j, k, ivx))
                    vavg = half * (w(i + 1, j, k, ivy) + w(i, j, k, ivy))
                    wavg = half * (w(i + 1, j, k, ivz) + w(i, j, k, ivz))
                    a2avg = half * (gamma(i + 1, j, k) * p(i + 1, j, k) / w(i + 1, j, k, irho) &
                                    + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
 
                    area = sqrt(si(i, j, k, 1)**2 + si(i, j, k, 2)**2 + si(i, j, k, 3)**2)
                    tmp = one / max(1.e-25_realtype, area)
                    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.
 
                    sface = sfacei(i, j, k) * tmp
 
                    ! Compute the absolute values of the three eigenvalues
                    ! and make sure they don't become zero by cutting them
                    ! off to a certain minimum.
 
                    lam1 = abs(unavg - sface + aavg)
                    lam2 = abs(unavg - sface - aavg)
                    lam3 = abs(unavg - sface)
 
                    rrad = lam3 + aavg
 
                    ! Multiply the eigenvalues by the area to obtain
                    ! the correct values for the dissipation term.
 
                    lam1 = max(lam1, epsacoustic * rrad) * area
                    lam2 = max(lam2, epsacoustic * rrad) * area
                    lam3 = max(lam3, epsshear * rrad) * 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) == normalflux) ppor = one
 
                    dis2 = ppor * fis2 * min(dpmax, max(dss(i, j, k, 2), dss(i, j + 1, k, 2)))
                    dis4 = dim(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.
                    drk = zero
                    kavg = zero
 
                    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))
                    end if
 
                    ! Compute the average value of gamma and compute some
                    ! expressions in which it occurs.
 
                    gammaavg = half * (gamma(i, j + 1, k) + gamma(i, j, k))
                    gm1 = gammaavg - one
                    ovgm1 = one / gm1
                    gm53 = gammaavg - five * third
 
                    ! Compute the average state at the interface.
 
                    uavg = half * (w(i, j + 1, k, ivx) + w(i, j, k, ivx))
                    vavg = half * (w(i, j + 1, k, ivy) + w(i, j, k, ivy))
                    wavg = half * (w(i, j + 1, k, ivz) + w(i, j, k, ivz))
                    a2avg = half * (gamma(i, j + 1, k) * p(i, j + 1, k) / w(i, j + 1, k, irho) &
                                    + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
 
                    area = sqrt(sj(i, j, k, 1)**2 + sj(i, j, k, 2)**2 + sj(i, j, k, 3)**2)
                    tmp = one / max(1.e-25_realtype, area)
                    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.
 
                    sface = sfacej(i, j, k) * tmp
 
                    ! Compute the absolute values of the three eigenvalues
                    ! and make sure they don't become zero by cutting them
                    ! off to a certain minimum.
 
                    lam1 = abs(unavg - sface + aavg)
                    lam2 = abs(unavg - sface - aavg)
                    lam3 = abs(unavg - sface)
 
                    rrad = lam3 + aavg
 
                    ! Multiply the eigenvalues by the area to obtain
                    ! the correct values for the dissipation term.
 
                    lam1 = max(lam1, epsacoustic * rrad) * area
                    lam2 = max(lam2, epsacoustic * rrad) * area
                    lam3 = max(lam3, epsshear * rrad) * 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) == normalflux) ppor = one
 
                    dis2 = ppor * fis2 * min(dpmax, max(dss(i, j, k, 3), dss(i, j, k + 1, 3)))
                    dis4 = dim(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.
                    drk = zero
                    kavg = zero
 
                    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))
                    end if
 
                    ! Compute the average value of gamma and compute some
                    ! expressions in which it occurs.
 
                    gammaavg = half * (gamma(i, j, k + 1) + gamma(i, j, k))
                    gm1 = gammaavg - one
                    ovgm1 = one / gm1
                    gm53 = gammaavg - five * third
 
                    ! Compute the average state at the interface.
 
                    uavg = half * (w(i, j, k + 1, ivx) + w(i, j, k, ivx))
                    vavg = half * (w(i, j, k + 1, ivy) + w(i, j, k, ivy))
                    wavg = half * (w(i, j, k + 1, ivz) + w(i, j, k, ivz))
                    a2avg = half * (gamma(i, j, k + 1) * p(i, j, k + 1) / w(i, j, k + 1, irho) &
                                    + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
 
                    area = sqrt(sk(i, j, k, 1)**2 + sk(i, j, k, 2)**2 + sk(i, j, k, 3)**2)
                    tmp = one / max(1.e-25_realtype, area)
                    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.
 
                    sface = sfacek(i, j, k) * tmp
 
                    ! Compute the absolute values of the three eigenvalues
                    ! and make sure they don't become zero by cutting them
                    ! off to a certain minimum.
 
                    lam1 = abs(unavg - sface + aavg)
                    lam2 = abs(unavg - sface - aavg)
                    lam3 = abs(unavg - sface)
 
                    rrad = lam3 + aavg
 
                    ! Multiply the eigenvalues by the area to obtain
                    ! the correct values for the dissipation term.
 
                    lam1 = max(lam1, epsacoustic * rrad) * area
                    lam2 = max(lam2, epsacoustic * rrad) * area
                    lam3 = max(lam3, epsshear * rrad) * 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 subroutine invisciddissfluxmatrix
 
    subroutine invisciddissfluxscalar
        ! ---------------------------------------------
        !             Inviscid Diss Flux Scalar
        ! ---------------------------------------------
 
        use constants
        use flowvarrefstate, only: pinfcorr
        use inputdiscretization, only: vis2, vis4
        use inputiteration, only: usedisscontinuation, disscontmagnitude, disscontmidpoint, disscontsharpness
        use inputphysics, only: equations
        use iteration, only: rfil, totalr0, totalr
        use flowvarrefstate, only: gammainf, pinfcorr, rhoinf
        implicit none
 
        ! Variables for inviscid diss flux scalar
        real(kind=realtype), parameter :: dssmax = 0.25_realtype
        real(kind=realtype) :: sslim, rhoi
        real(kind=realtype) :: sfil, fis2, fis4
        real(kind=realtype) :: ppor, rrad, dis2, dis4, fs
        real(kind=realtype) :: ddw1, ddw2, ddw3, ddw4, ddw5
        integer(kind=intType) :: i, j, k
 
        ! 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 = doublehalostart, 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 = singlehalostart, ie
                    dss(i, j, k, 1) = abs((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))
 
                    dss(i, j, k, 2) = abs((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))
 
                    dss(i, j, k, 3) = abs((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))
                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.
        ! For the blockette code, rFil is always one, so 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 == zero .or. totalr0 == zero) then
                fis2 = rfil * (vis2 + disscontmagnitude / (1 + exp(-disscontsharpness * disscontmidpoint)))
            else
                fis2 = rfil * (vis2 + disscontmagnitude / &
                               (1 + exp(-disscontsharpness * (log10(totalr / totalr0) + disscontmidpoint))))
            end if
        else
            fis2 = rfil * vis2
        end if
        fis4 = rfil * vis4
        sfil = one - rfil
 
        ! Initialize the dissipative residual to a certain times,
        ! possibly zero, the previously stored value. Owned cells
        ! only, because the halo values do not matter.
 
        fw = sfil * fw
        !
        !       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) == normalflux) ppor = half
                    rrad = ppor * (radi(i, j, k) + radi(i + 1, j, k))
 
                    dis2 = fis2 * rrad * min(dssmax, max(dss(i, j, k, 1), dss(i + 1, j, k, 1)))
                    dis4 = dim(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) == normalflux) ppor = half
                    rrad = ppor * (radj(i, j, k) + radj(i, j + 1, k))
 
                    dis2 = fis2 * rrad * min(dssmax, max(dss(i, j, k, 2), dss(i, j + 1, k, 2)))
                    dis4 = dim(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) == normalflux) ppor = half
                    rrad = ppor * (radk(i, j, k) + radk(i, j, k + 1))
 
                    dis2 = fis2 * rrad * min(dssmax, max(dss(i, j, k, 3), dss(i, j, k + 1, 3)))
                    dis4 = dim(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 subroutine invisciddissfluxscalar
 
    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 flowvarrefstate, only: kpresent, nw, nwf, rgas, tref
        use blockpointers, only: rotmatrixi, rotmatrixj, rotmatrixk
        use inputdiscretization, only: limiter, precond, riemann, &
                                       riemanncoarse, orderturb, kappacoef
        use inputphysics, only: equations
        use iteration, only: rfil, currentlevel, groundlevel
        use utils, only: getcorrectfork, terminate
        use flowutils, 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
 
        ! 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()
 
        ! Compute the factor used in the minmod limiter.
 
        factminmod = (three - kappacoef) &
                     / max(1.e-10_realtype, one - kappacoef)
 
        ! 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
 
        ! 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)
 
        ! 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 == 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.
        !
        ordertest: if (limused == 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)
                        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)
 
                    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)
                        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)
                    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)
                        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)
 
                    end do
                end do
            end do
 
            !      ==================================================================
 
            else ordertest
 
            !      ==================================================================
            !
            !         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)
                        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)
 
                    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)
                        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)
                    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)
                        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)
 
                    end do
                end do
            end do
 
        end if ordertest
 
        !      ==================================================================
 
    contains
 
        subroutine leftrightstate(du1, du2, du3, rotMatrix, left, right)
            !
            !         leftRightState computes the differences in the left and
            !         right state compared to the first order interpolation. For a
            !         monotonic second order discretization the interpolations
            !         need to be nonlinear. The linear second order scheme can be
            !         stable (depending on the value of kappa), but it will have
            !         oscillations near discontinuities.
            !
            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
 
            ! 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 + ii - 2, j + jj - 2, k + kk - 2, 1, 1)
                rot(1, 2) = rotmatrix(i + ii - 2, j + jj - 2, k + kk - 2, 1, 2)
                rot(1, 3) = rotmatrix(i + ii - 2, j + jj - 2, k + kk - 2, 1, 3)
 
                rot(2, 1) = rotmatrix(i + ii - 2, j + jj - 2, k + kk - 2, 2, 1)
                rot(2, 2) = rotmatrix(i + ii - 2, j + jj - 2, k + kk - 2, 2, 2)
                rot(2, 3) = rotmatrix(i + ii - 2, j + jj - 2, k + kk - 2, 2, 3)
 
                rot(3, 1) = rotmatrix(i + ii - 2, j + jj - 2, k + kk - 2, 3, 1)
                rot(3, 2) = rotmatrix(i + ii - 2, j + jj - 2, k + kk - 2, 3, 2)
                rot(3, 3) = rotmatrix(i + ii - 2, j + jj - 2, k + kk - 2, 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
 
                    ! Compute the limiter argument rl1, rl2, rr1 and rr2.
                    ! Note the cut off to 0.0.
 
                    tmp = one / sign(max(abs(du2(l)), epslim), du2(l))
                    rl1 = max(zero, &
                              du2(l) / sign(max(abs(du1(l)), epslim), du1(l)))
                    rl2 = max(zero, du1(l) * tmp)
 
                    rr1 = max(zero, du3(l) * tmp)
                    rr2 = max(zero, &
                              du2(l) / sign(max(abs(du3(l)), epslim), du3(l)))
 
                    ! 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
 
                    ! Compute the limiter argument rl1, rl2, rr1 and rr2.
                    ! Note the cut off to 0.0.
 
                    tmp = one / sign(max(abs(du2(l)), epslim), du2(l))
                    rl1 = max(zero, &
                              du2(l) / sign(max(abs(du1(l)), epslim), du1(l)))
                    rl2 = max(zero, du1(l) * tmp)
 
                    rr1 = max(zero, du3(l) * tmp)
                    rr2 = max(zero, &
                              du2(l) / sign(max(abs(du3(l)), epslim), du3(l)))
 
                    ! Compute the corresponding limiter values.
 
                    rl1 = min(one, factminmod * rl1)
                    rl2 = min(one, factminmod * rl2)
                    rr1 = min(one, factminmod * rr1)
                    rr2 = min(one, factminmod * rr2)
 
                    ! 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)
            !
            !         riemannFlux computes the flux for the given face and left
            !         and right states.
            !
            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
 
            ! 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 == noflux .or. por == boundflux) porflux = zero
 
            ! Abbreviate some expressions in which gamma occurs.
 
            gm1 = gammaface - one
            gm53 = gammaface - five * third
 
            ! Determine which riemann solver must be solved.
 
            select case (riemannused)
 
            case (roe)
 
                ! Determine the preconditioner used.
 
                select case (precond)
 
                case (noprecond)
 
                    ! No preconditioner used. Use the Roe scheme of the
                    ! standard equations.
 
                    ! Compute the square root of the left and right densities
                    ! and the inverse of the sum.
 
                    z1l = sqrt(left(irho))
                    z1r = sqrt(right(irho))
                    tmp = one / (z1l + z1r)
 
                    ! Compute some variables depending whether or not a
                    ! k-equation is present.
 
                    if (correctfork) then
 
                        ! Store the left and right kinetic energy in ktmp,
                        ! which is needed to compute the total energy.
 
                        ktmp(1) = left(itu1)
                        ktmp(2) = right(itu1)
 
                        ! Store the difference of the turbulent kinetic energy
                        ! per unit volume, i.e. the conserved variable.
 
                        drk = right(irho) * right(itu1) - left(irho) * left(itu1)
 
                        ! Compute the average turbulent energy per unit mass
                        ! using Roe averages.
 
                        kavg = tmp * (z1l * left(itu1) + z1r * right(itu1))
 
                    else
 
                        ! Set the difference of the turbulent kinetic energy
                        ! per unit volume and the averaged kinetic energy per
                        ! unit mass to zero.
 
                        drk = 0.0
                        kavg = 0.0
 
                    end if
 
                    ! Compute the total energy of the left and right state.
                    call etot(left(irho), left(ivx), left(ivy), left(ivz), &
                              left(irhoe), ktmp(1), etl, correctfork)
 
                    call etot(right(irho), right(ivx), right(ivy), right(ivz), &
                              right(irhoe), ktmp(2), etr, correctfork)
 
                    ! Compute the difference of the conservative mean
                    ! flow variables.
 
                    dr = right(irho) - left(irho)
                    dru = right(irho) * right(ivx) - left(irho) * left(ivx)
                    drv = right(irho) * right(ivy) - left(irho) * left(ivy)
                    drw = right(irho) * right(ivz) - left(irho) * left(ivz)
                    dre = etr - etl
 
                    ! Compute the Roe average variables, which can be
                    ! computed directly from the average Roe vector.
 
                    ravg = fourth * (z1r + z1l)**2
                    uavg = tmp * (z1l * left(ivx) + z1r * right(ivx))
                    vavg = tmp * (z1l * left(ivy) + z1r * right(ivy))
                    wavg = tmp * (z1l * left(ivz) + z1r * right(ivz))
                    havg = tmp * ((etl + left(irhoe)) / z1l &
                                  + (etr + right(irhoe)) / z1r)
 
                    ! Compute the unit vector and store the area of the
                    ! normal. Also compute the unit normal velocity of the face.
 
                    area = sqrt(sx**2 + sy**2 + sz**2)
                    tmp = one / max(1.e-25_realtype, area)
                    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)
                    a2avg = abs(gm1 * (havg - alphaavg) - gm53 * kavg)
                    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 == boundflux) unavg = rface
 
                    ! 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 * (abs((left(ivx) - right(ivx)) * sx &
                                      + (left(ivy) - right(ivy)) * sy &
                                      + (left(ivz) - right(ivz)) * sz) &
                                  + abs(sqrt(gammaface * left(irhoe) / left(irho)) &
                                        - sqrt(gammaface * right(irhoe) / right(irho))))
 
                    ! Compute the absolute values of the three eigenvalues.
 
                    lam1 = abs(unavg - rface + aavg)
                    lam2 = abs(unavg - rface - aavg)
                    lam3 = abs(unavg - rface)
 
                    ! Apply the entropy correction to the eigenvalues.
 
                    tmp = two * eta
                    if (lam1 < tmp) lam1 = eta + fourth * lam1 * lam1 / eta
                    if (lam2 < tmp) lam2 = eta + fourth * lam2 * lam2 / eta
                    if (lam3 < 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
 
    subroutine invisciddissfluxscalarapprox
        ! ---------------------------------------------
        !             Inviscid Diss Flux Scalar
        ! ---------------------------------------------
 
        use constants
        use flowvarrefstate, only: pinfcorr
        use inputdiscretization, only: vis2, vis4, sigma
        use inputiteration, only: usedisscontinuation, disscontmagnitude, disscontmidpoint, disscontsharpness
        use inputphysics, only: equations
        use iteration, only: rfil, totalr0, totalr
        use flowvarrefstate, only: gammainf, pinfcorr, rhoinf
        implicit none
 
        ! Variables for inviscid diss flux scalar
        real(kind=realtype), parameter :: dssmax = 0.25_realtype
        real(kind=realtype) :: sslim, rhoi
        real(kind=realtype) :: sfil, fis2, fis4
        real(kind=realtype) :: ppor, rrad, dis2, dis4, fs
        real(kind=realtype) :: ddw
        integer(kind=intType) :: i, j, k
        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
 
        ! Compute the pressure sensor for each cell, in each direction:
        do k = 1, ke
            do j = 1, je
                do i = singlehalostart, ie
                    dss(i, j, k, 1) = abs((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))
 
                    dss(i, j, k, 2) = abs((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))
 
                    dss(i, j, k, 3) = abs((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))
                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.
        ! For the blockette code, rFil is always one, so sFil==0, fis2==vis2, and fis4==vis4.
 
        ! The sigmoid function used for dissipation-based continuation is described in Eq. 28 and Eq. 29 from the paper:
        ! "Improving the Performance of a Compressible RANS Solver for Low and High Mach Number Flows" (Seraj2022c).
        ! The options documentation also has information on the parameters in this formulation.
        if (usedisscontinuation) then
            fis2 = vis2 + disscontmagnitude / &
                   (1 + exp(-disscontsharpness * (log10(totalr / totalr0) + disscontmidpoint)))
        else
            fis2 = vis2
        end if
        fis4 = vis4
 
        !
        !       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) == normalflux) ppor = half
                    rrad = ppor * (radi(i, j, k) + radi(i + 1, j, k))
 
                    dis2 = fis2 * rrad * min(dssmax, max(dss(i, j, k, 1), dss(i + 1, j, k, 1))) + 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 + 1, j, k, irho) - w(i, j, k, ivx) * w(i, j, k, irho)
                    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 + 1, j, k, irho) - w(i, j, k, ivy) * w(i, j, k, irho)
                    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 + 1, j, k, irho) - w(i, j, k, ivz) * w(i, j, k, irho)
                    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) + p(i + 1, j, k)) - (w(i, j, k, irhoe) + p(i, j, k))
                    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
 
                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) == normalflux) ppor = half
                    rrad = ppor * (radj(i, j, k) + radj(i, j + 1, k))
 
                    dis2 = fis2 * rrad * min(dssmax, max(dss(i, j, k, 2), dss(i, j + 1, k, 2))) + 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 + 1, k, irho) - w(i, j, k, ivx) * w(i, j, k, irho)
                    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 + 1, k, irho) - w(i, j, k, ivy) * w(i, j, k, irho)
                    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 + 1, k, irho) - w(i, j, k, ivz) * w(i, j, k, irho)
                    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) + p(i, j + 1, k)) - (w(i, j, k, irhoe) + p(i, j, k))
                    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
                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) == normalflux) ppor = half
                    rrad = ppor * (radk(i, j, k) + radk(i, j, k + 1))
 
                    dis2 = fis2 * rrad * min(dssmax, max(dss(i, j, k, 3), dss(i, j, k + 1, 3))) + 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 + 1, irho) - w(i, j, k, ivx) * w(i, j, k, irho)
                    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 + 1, irho) - w(i, j, k, ivy) * w(i, j, k, irho)
                    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 + 1, irho) - w(i, j, k, ivz) * w(i, j, k, irho)
                    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) + p(i, j, k + 1)) - (w(i, j, k, irhoe) + p(i, j, k))
                    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
                end do
            end do
        end do
    end subroutine invisciddissfluxscalarapprox
 
    subroutine invisciddissfluxmatrixapprox
        !
        !       inviscidDissFluxMatrix computes the matrix artificial
        !       dissipation term. Instead of the spectral radius, as used in
        !       the scalar dissipation scheme, the absolute value of the flux
        !       jacobian is used. This leads to a less diffusive and
        !       consequently more accurate scheme. It is assumed that the
        !       pointers in blockPointers already point to the correct block.
        !
        use constants
        use flowvarrefstate, only: pinfcorr
        use inputdiscretization, only: vis2, vis4, sigma
        use inputphysics, only: equations
        use iteration, only: rfil
        use utils, 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) :: ddw, 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
        logical :: correctForK
 
        ! 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 = singlehalostart, ie
                    dss(i, j, k, 1) = abs((ss(i + 1, j, k) - two * ss(i, j, k) + ss(i - 1, j, k)) &
                                          / (omega * (ss(i + 1, j, k) + two * ss(i, j, k) + ss(i - 1, j, k)) &
                                             + oneminomega * (abs(ss(i + 1, j, k) - ss(i, j, k)) &
                                                              + abs(ss(i, j, k) - ss(i - 1, j, k))) + plim))
 
                    dss(i, j, k, 2) = abs((ss(i, j + 1, k) - two * ss(i, j, k) + ss(i, j - 1, k)) &
                                          / (omega * (ss(i, j + 1, k) + two * ss(i, j, k) + ss(i, j - 1, k)) &
                                             + oneminomega * (abs(ss(i, j + 1, k) - ss(i, j, k)) &
                                                              + abs(ss(i, j, k) - ss(i, j - 1, k))) + plim))
 
                    dss(i, j, k, 3) = abs((ss(i, j, k + 1) - two * ss(i, j, k) + ss(i, j, k - 1)) &
                                          / (omega * (ss(i, j, k + 1) + two * ss(i, j, k) + ss(i, j, k - 1)) &
                                             + oneminomega * (abs(ss(i, j, k + 1) - ss(i, j, k)) &
                                                              + abs(ss(i, j, k) - ss(i, j, k - 1))) + plim))
                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) == normalflux) ppor = one
 
                    dis2 = fis2 * ppor * min(dpmax, max(dss(i, j, k, 1), dss(i + 1, j, k, 1))) &
                           + 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.
                    drk = zero
                    kavg = zero
 
                    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))
                    end if
 
                    ! Compute the average value of gamma and compute some
                    ! expressions in which it occurs.
 
                    gammaavg = half * (gamma(i + 1, j, k) + gamma(i, j, k))
                    gm1 = gammaavg - one
                    ovgm1 = one / gm1
                    gm53 = gammaavg - five * third
 
                    ! Compute the average state at the interface.
 
                    uavg = half * (w(i + 1, j, k, ivx) + w(i, j, k, ivx))
                    vavg = half * (w(i + 1, j, k, ivy) + w(i, j, k, ivy))
                    wavg = half * (w(i + 1, j, k, ivz) + w(i, j, k, ivz))
                    a2avg = half * (gamma(i + 1, j, k) * p(i + 1, j, k) / w(i + 1, j, k, irho) &
                                    + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
 
                    area = sqrt(si(i, j, k, 1)**2 + si(i, j, k, 2)**2 + si(i, j, k, 3)**2)
                    tmp = one / max(1.e-25_realtype, area)
                    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.
 
                    sface = sfacei(i, j, k) * tmp
 
                    ! Compute the absolute values of the three eigenvalues
                    ! and make sure they don't become zero by cutting them
                    ! off to a certain minimum.
 
                    lam1 = abs(unavg - sface + aavg)
                    lam2 = abs(unavg - sface - aavg)
                    lam3 = abs(unavg - sface)
 
                    rrad = lam3 + aavg
 
                    ! Multiply the eigenvalues by the area to obtain
                    ! the correct values for the dissipation term.
 
                    lam1 = max(lam1, epsacoustic * rrad) * area
                    lam2 = max(lam2, epsacoustic * rrad) * area
                    lam3 = max(lam3, epsshear * rrad) * 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) == normalflux) ppor = one
 
                    dis2 = fis2 * ppor * min(dpmax, max(dss(i, j, k, 2), dss(i, j + 1, k, 2))) &
                           + 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.
                    drk = zero
                    kavg = zero
 
                    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))
                    end if
 
                    ! Compute the average value of gamma and compute some
                    ! expressions in which it occurs.
 
                    gammaavg = half * (gamma(i, j + 1, k) + gamma(i, j, k))
                    gm1 = gammaavg - one
                    ovgm1 = one / gm1
                    gm53 = gammaavg - five * third
 
                    ! Compute the average state at the interface.
 
                    uavg = half * (w(i, j + 1, k, ivx) + w(i, j, k, ivx))
                    vavg = half * (w(i, j + 1, k, ivy) + w(i, j, k, ivy))
                    wavg = half * (w(i, j + 1, k, ivz) + w(i, j, k, ivz))
                    a2avg = half * (gamma(i, j + 1, k) * p(i, j + 1, k) / w(i, j + 1, k, irho) &
                                    + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
 
                    area = sqrt(sj(i, j, k, 1)**2 + sj(i, j, k, 2)**2 + sj(i, j, k, 3)**2)
                    tmp = one / max(1.e-25_realtype, area)
                    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.
 
                    sface = sfacej(i, j, k) * tmp
 
                    ! Compute the absolute values of the three eigenvalues
                    ! and make sure they don't become zero by cutting them
                    ! off to a certain minimum.
 
                    lam1 = abs(unavg - sface + aavg)
                    lam2 = abs(unavg - sface - aavg)
                    lam3 = abs(unavg - sface)
 
                    rrad = lam3 + aavg
 
                    ! Multiply the eigenvalues by the area to obtain
                    ! the correct values for the dissipation term.
 
                    lam1 = max(lam1, epsacoustic * rrad) * area
                    lam2 = max(lam2, epsacoustic * rrad) * area
                    lam3 = max(lam3, epsshear * rrad) * 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) == normalflux) ppor = one
 
                    dis2 = fis2 * ppor * min(dpmax, max(dss(i, j, k, 3), dss(i, j, k + 1, 3))) &
                           + 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.
                    drk = zero
                    kavg = zero
 
                    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))
                    end if
 
                    ! Compute the average value of gamma and compute some
                    ! expressions in which it occurs.
 
                    gammaavg = half * (gamma(i, j, k + 1) + gamma(i, j, k))
                    gm1 = gammaavg - one
                    ovgm1 = one / gm1
                    gm53 = gammaavg - five * third
 
                    ! Compute the average state at the interface.
 
                    uavg = half * (w(i, j, k + 1, ivx) + w(i, j, k, ivx))
                    vavg = half * (w(i, j, k + 1, ivy) + w(i, j, k, ivy))
                    wavg = half * (w(i, j, k + 1, ivz) + w(i, j, k, ivz))
                    a2avg = half * (gamma(i, j, k + 1) * p(i, j, k + 1) / w(i, j, k + 1, irho) &
                                    + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
 
                    area = sqrt(sk(i, j, k, 1)**2 + sk(i, j, k, 2)**2 + sk(i, j, k, 3)**2)
                    tmp = one / max(1.e-25_realtype, area)
                    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.
 
                    sface = sfacek(i, j, k) * tmp
 
                    ! Compute the absolute values of the three eigenvalues
                    ! and make sure they don't become zero by cutting them
                    ! off to a certain minimum.
 
                    lam1 = abs(unavg - sface + aavg)
                    lam2 = abs(unavg - sface - aavg)
                    lam3 = abs(unavg - sface)
 
                    rrad = lam3 + aavg
 
                    ! Multiply the eigenvalues by the area to obtain
                    ! the correct values for the dissipation term.
 
                    lam1 = max(lam1, epsacoustic * rrad) * area
                    lam2 = max(lam2, epsacoustic * rrad) * area
                    lam3 = max(lam3, epsshear * rrad) * 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 subroutine invisciddissfluxmatrixapprox
 
    subroutine computespeedofsoundsquared
        ! ---------------------------------------------
        !           Compute the speed of sound squared
        ! ---------------------------------------------
        use constants
        use utils, only: getcorrectfork
        implicit none
 
        ! Variables for speed of sound
        logical :: correctForK
        real(kind=realtype) :: pp
        real(kind=realtype), parameter :: twothird = two * third
        integer(kind=intType) :: i, j, k
 
        ! Determine if we need to correct for K
        correctfork = getcorrectfork()
 
        if (correctfork) then
            do k = 1, ke
                do j = 1, je
                    do i = singlehalostart, ie
                        pp = p(i, j, k) - twothird * w(i, j, k, irho) * w(i, j, k, itu1)
                        aa(i, j, k) = gamma(i, j, k) * pp / w(i, j, k, irho)
                    end do
                end do
            end do
        else
            do k = 1, ke
                do j = 1, je
                    do i = singlehalostart, ie
                        aa(i, j, k) = gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho)
                    end do
                end do
            end do
        end if
    end subroutine computespeedofsoundsquared
 
    subroutine allnodalgradients
 
        ! ---------------------------------------------
        !           Compute nodal gradients
        ! ---------------------------------------------
        use constants
        implicit none
 
        ! Variables for nodal gradients
        real(kind=realtype) :: a2, ovol, ubar, vbar, wbar, sx, sy, sz
        integer(kind=intType) :: i, j, k
 
        ! Zero just the required part of the nodal gradients since the
        ! first value may be useful.
        ux(nodestart:, :, :) = zero
        uy(nodestart:, :, :) = zero
        uz(nodestart:, :, :) = zero
 
        vx(nodestart:, :, :) = zero
        vy(nodestart:, :, :) = zero
        vz(nodestart:, :, :) = zero
 
        wx(nodestart:, :, :) = zero
        wy(nodestart:, :, :) = zero
        wz(nodestart:, :, :) = zero
 
        qx(nodestart:, :, :) = zero
        qy(nodestart:, :, :) = zero
        qz(nodestart:, :, :) = zero
 
        ! First part. Contribution in the k-direction.
        ! The contribution is scattered to both the left and right node
        ! in k-direction.
 
        do k = 1, ke
            do j = 1, jl
                do i = nodestart, il
 
                    ! Compute 8 times the average normal for this part of
                    ! the control volume. The factor 8 is taken care of later
                    ! on when the division by the volume takes place.
 
                    sx = sk(i, j, k - 1, 1) + sk(i + 1, j, k - 1, 1) &
                         + sk(i, j + 1, k - 1, 1) + sk(i + 1, j + 1, k - 1, 1) &
                         + sk(i, j, k, 1) + sk(i + 1, j, k, 1) &
                         + sk(i, j + 1, k, 1) + sk(i + 1, j + 1, k, 1)
                    sy = sk(i, j, k - 1, 2) + sk(i + 1, j, k - 1, 2) &
                         + sk(i, j + 1, k - 1, 2) + sk(i + 1, j + 1, k - 1, 2) &
                         + sk(i, j, k, 2) + sk(i + 1, j, k, 2) &
                         + sk(i, j + 1, k, 2) + sk(i + 1, j + 1, k, 2)
                    sz = sk(i, j, k - 1, 3) + sk(i + 1, j, k - 1, 3) &
                         + sk(i, j + 1, k - 1, 3) + sk(i + 1, j + 1, k - 1, 3) &
                         + sk(i, j, k, 3) + sk(i + 1, j, k, 3) &
                         + sk(i, j + 1, k, 3) + sk(i + 1, j + 1, k, 3)
 
                    ! Compute the average velocities and speed of sound squared
                    ! for this integration point. Node that these variables are
                    ! stored in w(ivx), w(ivy), w(ivz) and p.
 
                    ubar = fourth * (w(i, j, k, ivx) + w(i + 1, j, k, ivx) &
                                     + w(i, j + 1, k, ivx) + w(i + 1, j + 1, k, ivx))
                    vbar = fourth * (w(i, j, k, ivy) + w(i + 1, j, k, ivy) &
                                     + w(i, j + 1, k, ivy) + w(i + 1, j + 1, k, ivy))
                    wbar = fourth * (w(i, j, k, ivz) + w(i + 1, j, k, ivz) &
                                     + w(i, j + 1, k, ivz) + w(i + 1, j + 1, k, ivz))
 
                    a2 = fourth * (aa(i, j, k) + aa(i + 1, j, k) + aa(i, j + 1, k) + aa(i + 1, j + 1, k))
 
                    ! Add the contributions to the surface integral to the node
                    ! j-1 and substract it from the node j. For the heat flux it
                    ! is reversed, because the negative of the gradient of the
                    ! speed of sound must be computed.
 
                    if (k > 1) then
                        ux(i, j, k - 1) = ux(i, j, k - 1) + ubar * sx
                        uy(i, j, k - 1) = uy(i, j, k - 1) + ubar * sy
                        uz(i, j, k - 1) = uz(i, j, k - 1) + ubar * sz
 
                        vx(i, j, k - 1) = vx(i, j, k - 1) + vbar * sx
                        vy(i, j, k - 1) = vy(i, j, k - 1) + vbar * sy
                        vz(i, j, k - 1) = vz(i, j, k - 1) + vbar * sz
 
                        wx(i, j, k - 1) = wx(i, j, k - 1) + wbar * sx
                        wy(i, j, k - 1) = wy(i, j, k - 1) + wbar * sy
                        wz(i, j, k - 1) = wz(i, j, k - 1) + wbar * sz
 
                        qx(i, j, k - 1) = qx(i, j, k - 1) - a2 * sx
                        qy(i, j, k - 1) = qy(i, j, k - 1) - a2 * sy
                        qz(i, j, k - 1) = qz(i, j, k - 1) - a2 * sz
                    end if
 
                    if (k < ke) then
                        ux(i, j, k) = ux(i, j, k) - ubar * sx
                        uy(i, j, k) = uy(i, j, k) - ubar * sy
                        uz(i, j, k) = uz(i, j, k) - ubar * sz
 
                        vx(i, j, k) = vx(i, j, k) - vbar * sx
                        vy(i, j, k) = vy(i, j, k) - vbar * sy
                        vz(i, j, k) = vz(i, j, k) - vbar * sz
 
                        wx(i, j, k) = wx(i, j, k) - wbar * sx
                        wy(i, j, k) = wy(i, j, k) - wbar * sy
                        wz(i, j, k) = wz(i, j, k) - wbar * sz
 
                        qx(i, j, k) = qx(i, j, k) + a2 * sx
                        qy(i, j, k) = qy(i, j, k) + a2 * sy
                        qz(i, j, k) = qz(i, j, k) + a2 * sz
                    end if
                end do
            end do
        end do
 
        ! Second part. Contribution in the j-direction.
        ! The contribution is scattered to both the left and right node
        ! in j-direction.
 
        do k = 1, kl
            do j = 1, je
                do i = nodestart, il
 
                    ! Compute 8 times the average normal for this part of
                    ! the control volume. The factor 8 is taken care of later
                    ! on when the division by the volume takes place.
 
                    sx = sj(i, j - 1, k, 1) + sj(i + 1, j - 1, k, 1) &
                         + sj(i, j - 1, k + 1, 1) + sj(i + 1, j - 1, k + 1, 1) &
                         + sj(i, j, k, 1) + sj(i + 1, j, k, 1) &
                         + sj(i, j, k + 1, 1) + sj(i + 1, j, k + 1, 1)
                    sy = sj(i, j - 1, k, 2) + sj(i + 1, j - 1, k, 2) &
                         + sj(i, j - 1, k + 1, 2) + sj(i + 1, j - 1, k + 1, 2) &
                         + sj(i, j, k, 2) + sj(i + 1, j, k, 2) &
                         + sj(i, j, k + 1, 2) + sj(i + 1, j, k + 1, 2)
                    sz = sj(i, j - 1, k, 3) + sj(i + 1, j - 1, k, 3) &
                         + sj(i, j - 1, k + 1, 3) + sj(i + 1, j - 1, k + 1, 3) &
                         + sj(i, j, k, 3) + sj(i + 1, j, k, 3) &
                         + sj(i, j, k + 1, 3) + sj(i + 1, j, k + 1, 3)
 
                    ! Compute the average velocities and speed of sound squared
                    ! for this integration point. Node that these variables are
                    ! stored in w(ivx), w(ivy), w(ivz) and p.
 
                    ubar = fourth * (w(i, j, k, ivx) + w(i + 1, j, k, ivx) &
                                     + w(i, j, k + 1, ivx) + w(i + 1, j, k + 1, ivx))
                    vbar = fourth * (w(i, j, k, ivy) + w(i + 1, j, k, ivy) &
                                     + w(i, j, k + 1, ivy) + w(i + 1, j, k + 1, ivy))
                    wbar = fourth * (w(i, j, k, ivz) + w(i + 1, j, k, ivz) &
                                     + w(i, j, k + 1, ivz) + w(i + 1, j, k + 1, ivz))
 
                    a2 = fourth * (aa(i, j, k) + aa(i + 1, j, k) + aa(i, j, k + 1) + aa(i + 1, j, k + 1))
 
                    ! Add the contributions to the surface integral to the node
                    ! j-1 and substract it from the node j. For the heat flux it
                    ! is reversed, because the negative of the gradient of the
                    ! speed of sound must be computed.
 
                    if (j > 1) then
                        ux(i, j - 1, k) = ux(i, j - 1, k) + ubar * sx
                        uy(i, j - 1, k) = uy(i, j - 1, k) + ubar * sy
                        uz(i, j - 1, k) = uz(i, j - 1, k) + ubar * sz
 
                        vx(i, j - 1, k) = vx(i, j - 1, k) + vbar * sx
                        vy(i, j - 1, k) = vy(i, j - 1, k) + vbar * sy
                        vz(i, j - 1, k) = vz(i, j - 1, k) + vbar * sz
 
                        wx(i, j - 1, k) = wx(i, j - 1, k) + wbar * sx
                        wy(i, j - 1, k) = wy(i, j - 1, k) + wbar * sy
                        wz(i, j - 1, k) = wz(i, j - 1, k) + wbar * sz
 
                        qx(i, j - 1, k) = qx(i, j - 1, k) - a2 * sx
                        qy(i, j - 1, k) = qy(i, j - 1, k) - a2 * sy
                        qz(i, j - 1, k) = qz(i, j - 1, k) - a2 * sz
                    end if
 
                    if (j < je) then
                        ux(i, j, k) = ux(i, j, k) - ubar * sx
                        uy(i, j, k) = uy(i, j, k) - ubar * sy
                        uz(i, j, k) = uz(i, j, k) - ubar * sz
 
                        vx(i, j, k) = vx(i, j, k) - vbar * sx
                        vy(i, j, k) = vy(i, j, k) - vbar * sy
                        vz(i, j, k) = vz(i, j, k) - vbar * sz
 
                        wx(i, j, k) = wx(i, j, k) - wbar * sx
                        wy(i, j, k) = wy(i, j, k) - wbar * sy
                        wz(i, j, k) = wz(i, j, k) - wbar * sz
 
                        qx(i, j, k) = qx(i, j, k) + a2 * sx
                        qy(i, j, k) = qy(i, j, k) + a2 * sy
                        qz(i, j, k) = qz(i, j, k) + a2 * sz
                    end if
                end do
            end do
        end do
        !
        ! Third part. Contribution in the i-direction.
        ! The contribution is scattered to both the left and right node
        ! in i-direction.
        !
        do k = 1, kl
            do j = 1, jl
                do i = nodestart, ie
 
                    ! Compute 8 times the average normal for this part of
                    ! the control volume. The factor 8 is taken care of later
                    ! on when the division by the volume takes place.
 
                    sx = si(i - 1, j, k, 1) + si(i - 1, j + 1, k, 1) &
                         + si(i - 1, j, k + 1, 1) + si(i - 1, j + 1, k + 1, 1) &
                         + si(i, j, k, 1) + si(i, j + 1, k, 1) &
                         + si(i, j, k + 1, 1) + si(i, j + 1, k + 1, 1)
                    sy = si(i - 1, j, k, 2) + si(i - 1, j + 1, k, 2) &
                         + si(i - 1, j, k + 1, 2) + si(i - 1, j + 1, k + 1, 2) &
                         + si(i, j, k, 2) + si(i, j + 1, k, 2) &
                         + si(i, j, k + 1, 2) + si(i, j + 1, k + 1, 2)
                    sz = si(i - 1, j, k, 3) + si(i - 1, j + 1, k, 3) &
                         + si(i - 1, j, k + 1, 3) + si(i - 1, j + 1, k + 1, 3) &
                         + si(i, j, k, 3) + si(i, j + 1, k, 3) &
                         + si(i, j, k + 1, 3) + si(i, j + 1, k + 1, 3)
 
                    ! Compute the average velocities and speed of sound squared
                    ! for this integration point. Node that these variables are
                    ! stored in w(ivx), w(ivy), w(ivz) and p.
 
                    ubar = fourth * (w(i, j, k, ivx) + w(i, j + 1, k, ivx) &
                                     + w(i, j, k + 1, ivx) + w(i, j + 1, k + 1, ivx))
                    vbar = fourth * (w(i, j, k, ivy) + w(i, j + 1, k, ivy) &
                                     + w(i, j, k + 1, ivy) + w(i, j + 1, k + 1, ivy))
                    wbar = fourth * (w(i, j, k, ivz) + w(i, j + 1, k, ivz) &
                                     + w(i, j, k + 1, ivz) + w(i, j + 1, k + 1, ivz))
 
                    a2 = fourth * (aa(i, j, k) + aa(i, j + 1, k) + aa(i, j, k + 1) + aa(i, j + 1, k + 1))
 
                    ! Add the contributions to the surface integral to the node
                    ! j-1 and substract it from the node j. For the heat flux it
                    ! is reversed, because the negative of the gradient of the
                    ! speed of sound must be computed.
 
                    if (i > nodestart) then
                        ux(i - 1, j, k) = ux(i - 1, j, k) + ubar * sx
                        uy(i - 1, j, k) = uy(i - 1, j, k) + ubar * sy
                        uz(i - 1, j, k) = uz(i - 1, j, k) + ubar * sz
 
                        vx(i - 1, j, k) = vx(i - 1, j, k) + vbar * sx
                        vy(i - 1, j, k) = vy(i - 1, j, k) + vbar * sy
                        vz(i - 1, j, k) = vz(i - 1, j, k) + vbar * sz
 
                        wx(i - 1, j, k) = wx(i - 1, j, k) + wbar * sx
                        wy(i - 1, j, k) = wy(i - 1, j, k) + wbar * sy
                        wz(i - 1, j, k) = wz(i - 1, j, k) + wbar * sz
 
                        qx(i - 1, j, k) = qx(i - 1, j, k) - a2 * sx
                        qy(i - 1, j, k) = qy(i - 1, j, k) - a2 * sy
                        qz(i - 1, j, k) = qz(i - 1, j, k) - a2 * sz
                    end if
 
                    if (i < ie) then
                        ux(i, j, k) = ux(i, j, k) - ubar * sx
                        uy(i, j, k) = uy(i, j, k) - ubar * sy
                        uz(i, j, k) = uz(i, j, k) - ubar * sz
 
                        vx(i, j, k) = vx(i, j, k) - vbar * sx
                        vy(i, j, k) = vy(i, j, k) - vbar * sy
                        vz(i, j, k) = vz(i, j, k) - vbar * sz
 
                        wx(i, j, k) = wx(i, j, k) - wbar * sx
                        wy(i, j, k) = wy(i, j, k) - wbar * sy
                        wz(i, j, k) = wz(i, j, k) - wbar * sz
 
                        qx(i, j, k) = qx(i, j, k) + a2 * sx
                        qy(i, j, k) = qy(i, j, k) + a2 * sy
                        qz(i, j, k) = qz(i, j, k) + a2 * sz
                    end if
                end do
            end do
        end do
 
        ! Divide by 8 times the volume to obtain the correct gradients.
 
        do k = 1, kl
            do j = 1, jl
                do i = nodestart, il
 
                    ! Compute the inverse of 8 times the volume for this node.
 
                    ovol = one / (vol(i, j, k) + vol(i, j, k + 1) &
                                  + vol(i + 1, j, k) + vol(i + 1, j, k + 1) &
                                  + vol(i, j + 1, k) + vol(i, j + 1, k + 1) &
                                  + vol(i + 1, j + 1, k) + vol(i + 1, j + 1, k + 1))
 
                    ! Compute the correct velocity gradients and "unit" heat
                    ! fluxes. The velocity gradients are stored in ux, etc.
 
                    ux(i, j, k) = ux(i, j, k) * ovol
                    uy(i, j, k) = uy(i, j, k) * ovol
                    uz(i, j, k) = uz(i, j, k) * ovol
 
                    vx(i, j, k) = vx(i, j, k) * ovol
                    vy(i, j, k) = vy(i, j, k) * ovol
                    vz(i, j, k) = vz(i, j, k) * ovol
 
                    wx(i, j, k) = wx(i, j, k) * ovol
                    wy(i, j, k) = wy(i, j, k) * ovol
                    wz(i, j, k) = wz(i, j, k) * ovol
 
                    qx(i, j, k) = qx(i, j, k) * ovol
                    qy(i, j, k) = qy(i, j, k) * ovol
                    qz(i, j, k) = qz(i, j, k) * ovol
                end do
            end do
        end do
    end subroutine allnodalgradients
 
    subroutine viscousflux(storeWallTensor)
        ! ---------------------------------------------
        !                   Viscous Flux
        ! ---------------------------------------------
 
        use constants
        use inputphysics, only: useqcr, prandtl, prandtlturb
        use flowvarrefstate, only: eddymodel
        use iteration, only: rfil
        use blockpointers, only: bil => il, bjl => jl, bkl => kl, &
                                 visciminpointer, viscimaxpointer, viscsubface, &
                                 viscjminpointer, viscjmaxpointer, &
                                 visckminpointer, visckmaxpointer
        implicit none
 
        ! Input
        logical, intent(in), optional :: storeWallTensor
 
        ! Variables for viscous flux
        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
        real(kind=realtype) :: corr, ssx, ssy, ssz, fracdiv, snrm
        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) :: ubar, vbar, wbar
        real(kind=realtype) :: exx, eyy, ezz
        real(kind=realtype) :: exy, exz, eyz
        real(kind=realtype) :: wxx, wyy, wzz
        real(kind=realtype) :: wxy, wxz, wyz, wyx, wzx, wzy
        real(kind=realtype) :: den, ccr1
        real(kind=realtype) :: fmx, fmy, fmz, frhoe, fact
        integer(kind=intType) :: i, j, k, io, jo, ko
        real(kind=realtype), parameter :: xminn = 1.e-10_realtype
        real(kind=realtype), parameter :: twothird = two * third
        real(kind=realtype), dimension(9, 2:max(il, jl), 2:max(jl, kl), 2) :: tmpstore
 
        logical :: storeWall
 
        storewall = .false.
        if (present(storewalltensor)) then
            storewall = storewalltensor
        end if
 
        ! Set QCR parameters
        ccr1 = 0.3_realtype
        rfilv = rfil
 
        ! The diagonals of the vorticity tensor components are always zero
        wxx = zero
        wyy = zero
        wzz = zero
        !
        !         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) == 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))
                    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.
 
                    snrm = one / sqrt(ssx * ssx + ssy * ssy + ssz * ssz)
                    ssx = snrm * ssx
                    ssy = snrm * ssy
                    ssz = snrm * 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)) * snrm
                    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)) * snrm
                    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)) * snrm
                    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)) * snrm
                    q_x = q_x - corr * ssx
                    q_y = q_y - corr * ssy
                    q_z = q_z - corr * ssz
 
                    ! Compute the stress tensor and the heat flux vector.
                    ! We remove the viscosity from the stress tensor (tau)
                    ! to define tauS since we still need to separate between
                    ! laminar and turbulent stress for QCR.
                    ! Therefore, laminar tau = mue*tauS, turbulent
                    ! tau = mue*tauS, and total tau = mut*tauS.
 
                    fracdiv = twothird * (u_x + v_y + w_z)
 
                    tauxxs = two * u_x - fracdiv
                    tauyys = two * v_y - fracdiv
                    tauzzs = two * w_z - fracdiv
 
                    tauxys = u_y + v_x
                    tauxzs = u_z + w_x
                    tauyzs = v_z + w_y
 
                    q_x = heatcoef * q_x
                    q_y = heatcoef * q_y
                    q_z = heatcoef * q_z
 
                    ! Add QCR corrections if necessary
                    if (useqcr) then
 
                        ! In the QCR formulation, we add an extra term to the turbulent stress tensor:
                        !
                        ! tau_ij,QCR = tau_ij - e_ij
                        !
                        ! where, according to TMR website (http://turbmodels.larc.nasa.gov/spalart.html):
                        !
                        ! e_ij = Ccr1*(O_ik*tau_jk + O_jk*tau_ik)
                        !
                        ! We are computing O_ik as follows:
                        !
                        ! O_ik = 2*W_ik/den
                        !
                        ! Remember that the tau_ij in e_ij should use only the eddy viscosity!
 
                        ! Compute denominator
                        den = sqrt(u_x * u_x + u_y * u_y + u_z * u_z + &
                                   v_x * v_x + v_y * v_y + v_z * v_z + &
                                   w_x * w_x + w_y * w_y + w_z * w_z)
 
                        ! Denominator should be limited to avoid division by zero in regions with
                        ! no gradients
                        den = max(den, xminn)
 
                        ! 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
 
                    ! Temporarily store the shear stress and heat flux, even
                    ! if we won't need it. This can still vectorize
 
                    if (k == 1) then
                        tmpstore(1, i, j, 1) = tauxx
                        tmpstore(2, i, j, 1) = tauyy
                        tmpstore(3, i, j, 1) = tauzz
                        tmpstore(4, i, j, 1) = tauxy
                        tmpstore(5, i, j, 1) = tauxz
                        tmpstore(6, i, j, 1) = tauyz
 
                        tmpstore(7, i, j, 1) = q_x
                        tmpstore(8, i, j, 1) = q_y
                        tmpstore(9, i, j, 1) = q_z
                    end if
 
                    if (k == kl) then
                        tmpstore(1, i, j, 2) = tauxx
                        tmpstore(2, i, j, 2) = tauyy
                        tmpstore(3, i, j, 2) = tauzz
                        tmpstore(4, i, j, 2) = tauxy
                        tmpstore(5, i, j, 2) = tauxz
                        tmpstore(6, i, j, 2) = tauyz
 
                        tmpstore(7, i, j, 2) = q_x
                        tmpstore(8, i, j, 2) = q_y
                        tmpstore(9, i, j, 2) = q_z
                    end if
 
                end do
            end do
        end do
 
        ! Save into the subface if necessary
        if (storewall) then
 
            origkmin: if (kk - 1 == 1) then
                do j = 2, jl
                    do i = 2, il
                        io = i + ii - 2
                        jo = j + jj - 2
 
                        if (visckminpointer(io, jo) > 0) then
                            viscsubface(visckminpointer(io, jo))%tau(io, jo, :) = tmpstore(1:6, i, j, 1)
                            viscsubface(visckminpointer(io, jo))%q(io, jo, :) = tmpstore(7:9, i, j, 1)
                        end if
                    end do
                end do
            end if origkmin
 
            origkmax: if (kk + nz - 1 == bkl) then
                do j = 2, jl
                    do i = 2, il
                        io = i + ii - 2
                        jo = j + jj - 2
                        if (visckmaxpointer(io, jo) > 0) then
                            viscsubface(visckmaxpointer(io, jo))%tau(io, jo, :) = tmpstore(1:6, i, j, 2)
                            viscsubface(visckmaxpointer(io, jo))%q(io, jo, :) = tmpstore(7:9, i, j, 2)
                        end if
                    end do
                end do
            end if origkmax
        end if
        !
        !         Viscous fluxes in the j-direction.
        !
        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) == 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))
                    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.
 
                    snrm = one / sqrt(ssx * ssx + ssy * ssy + ssz * ssz)
                    ssx = snrm * ssx
                    ssy = snrm * ssy
                    ssz = snrm * 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)) * snrm
                    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)) * snrm
                    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)) * snrm
                    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)) * snrm
                    q_x = q_x - corr * ssx
                    q_y = q_y - corr * ssy
                    q_z = q_z - corr * ssz
 
                    ! Compute the stress tensor and the heat flux vector.
                    ! We remove the viscosity from the stress tensor (tau)
                    ! to define tauS since we still need to separate between
                    ! laminar and turbulent stress for QCR.
                    ! Therefore, laminar tau = mue*tauS, turbulent
                    ! tau = mue*tauS, and total tau = mut*tauS.
 
                    fracdiv = twothird * (u_x + v_y + w_z)
 
                    tauxxs = two * u_x - fracdiv
                    tauyys = two * v_y - fracdiv
                    tauzzs = two * w_z - fracdiv
 
                    tauxys = u_y + v_x
                    tauxzs = u_z + w_x
                    tauyzs = v_z + w_y
 
                    q_x = heatcoef * q_x
                    q_y = heatcoef * q_y
                    q_z = heatcoef * q_z
 
                    ! Add QCR corrections if necessary
                    if (useqcr) then
 
                        ! In the QCR formulation, we add an extra term to the turbulent stress tensor:
                        !
                        ! tau_ij,QCR = tau_ij - e_ij
                        !
                        ! where, according to TMR website (http://turbmodels.larc.nasa.gov/spalart.html):
                        !
                        ! e_ij = Ccr1*(O_ik*tau_jk + O_jk*tau_ik)
                        !
                        ! We are computing O_ik as follows:
                        !
                        ! O_ik = 2*W_ik/den
                        !
                        ! Remember that the tau_ij in e_ij should use only the eddy viscosity!
 
                        ! Compute denominator
                        den = sqrt(u_x * u_x + u_y * u_y + u_z * u_z + &
                                   v_x * v_x + v_y * v_y + v_z * v_z + &
                                   w_x * w_x + w_y * w_y + w_z * w_z)
 
                        ! Denominator should be limited to avoid division by zero in regions with
                        ! no gradients
                        den = max(den, xminn)
 
                        ! 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
 
                    ! Temporarily store the shear stress and heat flux, even
                    ! if we won't need it. This can still vectorize
 
                    if (j == 1) then
                        tmpstore(1, i, k, 1) = tauxx
                        tmpstore(2, i, k, 1) = tauyy
                        tmpstore(3, i, k, 1) = tauzz
                        tmpstore(4, i, k, 1) = tauxy
                        tmpstore(5, i, k, 1) = tauxz
                        tmpstore(6, i, k, 1) = tauyz
 
                        tmpstore(7, i, k, 1) = q_x
                        tmpstore(8, i, k, 1) = q_y
                        tmpstore(9, i, k, 1) = q_z
                    end if
 
                    if (j == jl) then
                        tmpstore(1, i, k, 2) = tauxx
                        tmpstore(2, i, k, 2) = tauyy
                        tmpstore(3, i, k, 2) = tauzz
                        tmpstore(4, i, k, 2) = tauxy
                        tmpstore(5, i, k, 2) = tauxz
                        tmpstore(6, i, k, 2) = tauyz
 
                        tmpstore(7, i, k, 2) = q_x
                        tmpstore(8, i, k, 2) = q_y
                        tmpstore(9, i, k, 2) = q_z
                    end if
                end do
            end do
        end do
        ! Save into the subface if necessary
        if (storewall) then
            origjmin: if (jj - 1 == 1) then
                do k = 2, kl
                    do i = 2, il
                        io = i + ii - 2
                        ko = k + kk - 2
 
                        if (viscjminpointer(io, ko) > 0) then
                            viscsubface(viscjminpointer(io, ko))%tau(io, ko, :) = tmpstore(1:6, i, k, 1)
                            viscsubface(viscjminpointer(io, ko))%q(io, ko, :) = tmpstore(7:9, i, k, 1)
                        end if
                    end do
                end do
            end if origjmin
 
            origjmax: if (jj + ny - 1 == bjl) then
                do k = 2, kl
                    do i = 2, il
                        io = i + ii - 2
                        ko = k + kk - 2
                        if (viscjmaxpointer(io, ko) > 0) then
                            viscsubface(viscjmaxpointer(io, ko))%tau(io, ko, :) = tmpstore(1:6, i, k, 2)
                            viscsubface(viscjmaxpointer(io, ko))%q(io, ko, :) = tmpstore(7:9, i, k, 2)
                        end if
                    end do
                end do
            end if origjmax
        end if
        !
        !         Viscous fluxes in the i-direction.
        !
        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) == 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))
                    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.
 
                    snrm = one / sqrt(ssx * ssx + ssy * ssy + ssz * ssz)
                    ssx = snrm * ssx
                    ssy = snrm * ssy
                    ssz = snrm * 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)) * snrm
                    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)) * snrm
                    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)) * snrm
                    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)) * snrm
                    q_x = q_x - corr * ssx
                    q_y = q_y - corr * ssy
                    q_z = q_z - corr * ssz
 
                    ! Compute the stress tensor and the heat flux vector.
                    ! We remove the viscosity from the stress tensor (tau)
                    ! to define tauS since we still need to separate between
                    ! laminar and turbulent stress for QCR.
                    ! Therefore, laminar tau = mue*tauS, turbulent
                    ! tau = mue*tauS, and total tau = mut*tauS.
 
                    fracdiv = twothird * (u_x + v_y + w_z)
 
                    tauxxs = two * u_x - fracdiv
                    tauyys = two * v_y - fracdiv
                    tauzzs = two * w_z - fracdiv
 
                    tauxys = u_y + v_x
                    tauxzs = u_z + w_x
                    tauyzs = v_z + w_y
 
                    q_x = heatcoef * q_x
                    q_y = heatcoef * q_y
                    q_z = heatcoef * q_z
 
                    ! Add QCR corrections if necessary
                    if (useqcr) then
 
                        ! In the QCR formulation, we add an extra term to the turbulent stress tensor:
                        !
                        ! tau_ij,QCR = tau_ij - e_ij
                        !
                        ! where, according to TMR website (http://turbmodels.larc.nasa.gov/spalart.html):
                        !
                        ! e_ij = Ccr1*(O_ik*tau_jk + O_jk*tau_ik)
                        !
                        ! We are computing O_ik as follows:
                        !
                        ! O_ik = 2*W_ik/den
                        !
                        ! Remember that the tau_ij in e_ij should use only the eddy viscosity!
 
                        ! Compute denominator
                        den = sqrt(u_x * u_x + u_y * u_y + u_z * u_z + &
                                   v_x * v_x + v_y * v_y + v_z * v_z + &
                                   w_x * w_x + w_y * w_y + w_z * w_z)
 
                        ! Denominator should be limited to avoid division by zero in regions with
                        ! no gradients
                        den = max(den, xminn)
 
                        ! 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 + 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
 
                    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
 
                    ! Temporarily store the shear stress and heat flux, even
                    ! if we won't need it. This can still vectorize
 
                    if (i == 1) then
                        tmpstore(1, j, k, 1) = tauxx
                        tmpstore(2, j, k, 1) = tauyy
                        tmpstore(3, j, k, 1) = tauzz
                        tmpstore(4, j, k, 1) = tauxy
                        tmpstore(5, j, k, 1) = tauxz
                        tmpstore(6, j, k, 1) = tauyz
 
                        tmpstore(7, j, k, 1) = q_x
                        tmpstore(8, j, k, 1) = q_y
                        tmpstore(9, j, k, 1) = q_z
                    end if
 
                    if (i == il) then
                        tmpstore(1, j, k, 2) = tauxx
                        tmpstore(2, j, k, 2) = tauyy
                        tmpstore(3, j, k, 2) = tauzz
                        tmpstore(4, j, k, 2) = tauxy
                        tmpstore(5, j, k, 2) = tauxz
                        tmpstore(6, j, k, 2) = tauyz
 
                        tmpstore(7, j, k, 2) = q_x
                        tmpstore(8, j, k, 2) = q_y
                        tmpstore(9, j, k, 2) = q_z
                    end if
                end do
            end do
        end do
        ! Save into the subface if necessary
        if (storewall) then
            origimin: if (ii - 1 == 1) then
                do k = 2, kl
                    do j = 2, jl
                        jo = j + jj - 2
                        ko = k + kk - 2
 
                        if (visciminpointer(jo, ko) > 0) then
                            viscsubface(visciminpointer(jo, ko))%tau(jo, ko, :) = tmpstore(1:6, j, k, 1)
                            viscsubface(visciminpointer(jo, ko))%q(jo, ko, :) = tmpstore(7:9, j, k, 1)
                        end if
                    end do
                end do
            end if origimin
 
            origimax: if (ii + nx - 1 == bil) then
                do k = 2, kl
                    do j = 2, jl
                        jo = j + jj - 2
                        ko = k + kk - 2
                        if (viscimaxpointer(jo, ko) > 0) then
                            viscsubface(viscimaxpointer(jo, ko))%tau(jo, ko, :) = tmpstore(1:6, j, k, 2)
                            viscsubface(viscimaxpointer(jo, ko))%q(jo, ko, :) = tmpstore(7:9, j, k, 2)
                        end if
                    end do
                end do
            end if origimax
        end if
    end subroutine viscousflux
 
    subroutine viscousfluxapprox
 
        use constants
        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) == 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))
                    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 + 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
 
                    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
 
                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) == 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))
                    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) == 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))
                    mue = por * (rev(i, j, k) + rev(i, j, k + 1))
                    mut = mul + mue
 
                    gm1 = half * (gamma(i, j, k) + gamma(i, j, k + 1)) - one
                    factlamheat = one / (prandtl * gm1)
                    factturbheat = one / (prandtlturb * gm1)
 
                    heatcoef = mul * factlamheat + mue * factturbheat
 
                    ! Compute the stress tensor and the heat flux vector.
 
                    fracdiv = twothird * (u_x + v_y + w_z)
 
                    tauxx = mut * (two * u_x - fracdiv)
                    tauyy = mut * (two * v_y - fracdiv)
                    tauzz = mut * (two * w_z - fracdiv)
 
                    tauxy = mut * (u_y + v_x)
                    tauxz = mut * (u_z + w_x)
                    tauyz = mut * (v_z + w_y)
 
                    q_x = heatcoef * q_x
                    q_y = heatcoef * q_y
                    q_z = heatcoef * q_z
 
                    ! Compute the average velocities for the face. Remember that
                    ! the velocities are stored and not the momentum.
 
                    ubar = half * (w(i, j, k, ivx) + w(i, j, k + 1, ivx))
                    vbar = half * (w(i, j, k, ivy) + w(i, j, k + 1, ivy))
                    wbar = half * (w(i, j, k, ivz) + w(i, j, k + 1, ivz))
 
                    ! Compute the viscous fluxes for this j-face.
 
                    fmx = tauxx * sk(i, j, k, 1) + tauxy * sk(i, j, k, 2) + tauxz * sk(i, j, k, 3)
                    fmy = tauxy * sk(i, j, k, 1) + tauyy * sk(i, j, k, 2) + tauyz * sk(i, j, k, 3)
                    fmz = tauxz * sk(i, j, k, 1) + tauyz * sk(i, j, k, 2) + tauzz * sk(i, j, k, 3)
                    frhoe = (ubar * tauxx + vbar * tauxy + wbar * tauxz) * sk(i, j, k, 1) &
                            + (ubar * tauxy + vbar * tauyy + wbar * tauyz) * sk(i, j, k, 2) &
                            + (ubar * tauxz + vbar * tauyz + wbar * tauzz) * sk(i, j, k, 3) &
                            - q_x * sk(i, j, k, 1) - q_y * sk(i, j, k, 2) - q_z * sk(i, j, k, 3)
 
                    ! Update the residuals of cell j and j+1.
 
                    fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
                    fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
                    fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
                    fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
 
                    fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) + fmx
                    fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) + fmy
                    fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) + fmz
                    fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) + frhoe
 
                end do
            end do
        end do
    end subroutine viscousfluxapprox
 
    subroutine sumdwandfw
 
        ! ---------------------------------------------
        !                 Sum dw and fw/res scale
        ! ---------------------------------------------
        use constants
        use flowvarrefstate, only: nw, nwf, nt1, nt2
        use inputiteration, only: turbresscale
        implicit none
 
        ! Variables for final summing
        integer(kind=intType) :: nTurb, i, j, k, l
        real(kind=realtype) :: ovol, rblank
 
        nturb = nt2 - nt1 + 1
        do l = 1, nwf
            do k = 2, kl
                do j = 2, jl
                    do i = 2, il
                        rblank = max(real(iblank(i, j, k), realtype), zero)
                        dw(i, j, k, l) = (dw(i, j, k, l) + fw(i, j, k, l)) * rblank
                    end do
                end do
            end do
        end do
    end subroutine sumdwandfw
 
    subroutine resscale
 
        use constants
        use flowvarrefstate, only: nwf, nt1, nt2
        use inputiteration, only: turbresscale
        implicit none
 
        ! Local Variables
        integer(kind=intType) :: i, j, k, ii, nTurb
        real(kind=realtype) :: ovol
 
        ! Divide through by the reference volume
        nturb = nt2 - nt1 + 1
        do k = 2, kl
            do j = 2, jl
                do i = 2, il
 
                    ovol = one / volref(i, j, k)
                    dw(i, j, k, 1:nwf) = dw(i, j, k, 1:nwf) * ovol
                    dw(i, j, k, nt1:nt2) = dw(i, j, k, nt1:nt2) * ovol * turbresscale(1:nturb)
                end do
            end do
        end do
 
    end subroutine resscale
 
end module blockette