ADflow  v1.0
ADflow is a finite volume RANS solver tailored for gradient-based aerodynamic design optimization.
fluxes.F90
Go to the documentation of this file.
1 module fluxes
2 
3 contains
4  subroutine inviscidcentralflux
5  !
6  ! inviscidCentralFlux computes the Euler fluxes using a central
7  ! discretization for a given block. Therefore it is assumed that
8  ! the pointers in block pointer already point to the correct
9  ! block on the correct multigrid level.
10  !
11  use constants
12  use blockpointers, only: nx, il, ie, ny, jl, je, nz, kl, ke, spectralsol, &
13  w, si, sj, sk, dw, pori, porj, pork, &
14  indfamilyi, indfamilyj, indfamilyk, p, sfacei, sfacej, sfacek, nbkglobal, &
15  addgridvelocities, blockismoving, vol, factfamilyi, factfamilyj, factfamilyk
16  use cgnsgrid, only: cgnsdoms, massflowfamilyinv
17  use flowvarrefstate, only: timeref
18  use inputphysics, only: equationmode
19  implicit none
20  !
21  ! Local variables.
22  !
23  integer(kind=intType) :: i, j, k, ind, ii
24  real(kind=realtype) :: qsp, qsm, rqsp, rqsm, porvel, porflux
25  real(kind=realtype) :: pa, fs, sface, vnp, vnm
26  real(kind=realtype) :: wwx, wwy, wwz, rvol
27 
28  continue
29  !$AD CHECKPOINT-START
30  ! Initialize sFace to zero. This value will be used if the
31  ! block is not moving.
32  sface = zero
33  !
34  ! Advective fluxes in the i-direction.
35  !
36 #ifdef TAPENADE_REVERSE
37  !$AD II-LOOP
38  do ii = 0, il * ny * nz - 1
39  i = mod(ii, il) + 1
40  j = mod(ii / il, ny) + 2
41  k = ii / (il * ny) + 2
42 #else
43  do k = 2, kl
44  do j = 2, jl
45  do i = 1, il
46 #endif
47  ! Set the dot product of the grid velocity and the
48  ! normal in i-direction for a moving face.
49 
50  if (addgridvelocities) sface = sfacei(i, j, k)
51 
52  ! Compute the normal velocities of the left and right state.
53 
54  vnp = w(i + 1, j, k, ivx) * si(i, j, k, 1) &
55  + w(i + 1, j, k, ivy) * si(i, j, k, 2) &
56  + w(i + 1, j, k, ivz) * si(i, j, k, 3)
57  vnm = w(i, j, k, ivx) * si(i, j, k, 1) &
58  + w(i, j, k, ivy) * si(i, j, k, 2) &
59  + w(i, j, k, ivz) * si(i, j, k, 3)
60  ! Set the values of the porosities for this face.
61  ! porVel defines the porosity w.r.t. velocity;
62  ! porFlux defines the porosity w.r.t. the entire flux.
63  ! The latter is only zero for a discontinuous block
64  ! boundary that must be treated conservatively.
65  ! The default value of porFlux is 0.5, such that the
66  ! correct central flux is scattered to both cells.
67  ! In case of a boundFlux the normal velocity is set
68  ! to sFace.
69 
70  porvel = one
71  porflux = half
72  if (pori(i, j, k) == noflux) porflux = zero
73  if (pori(i, j, k) == boundflux) then
74  porvel = zero
75  vnp = sface
76  vnm = sface
77  end if
78 
79  ! Incorporate porFlux in porVel.
80 
81  porvel = porvel * porflux
82 
83  ! Compute the normal velocities relative to the grid for
84  ! the face as well as the mass fluxes.
85 
86  qsp = (vnp - sface) * porvel
87  qsm = (vnm - sface) * porvel
88 
89  rqsp = qsp * w(i + 1, j, k, irho)
90  rqsm = qsm * w(i, j, k, irho)
91 
92  ! Compute the sum of the pressure multiplied by porFlux.
93  ! For the default value of porFlux, 0.5, this leads to
94  ! the average pressure.
95 
96  pa = porflux * (p(i + 1, j, k) + p(i, j, k))
97 
98  ! Compute the fluxes and scatter them to the cells
99  ! i,j,k and i+1,j,k. Store the density flux in the
100  ! mass flow of the appropriate sliding mesh interface.
101 
102  fs = rqsp + rqsm
103  dw(i + 1, j, k, irho) = dw(i + 1, j, k, irho) - fs
104  dw(i, j, k, irho) = dw(i, j, k, irho) + fs
105 #ifndef USE_TAPENADE
106  ind = indfamilyi(i, j, k)
107  massflowfamilyinv(ind, spectralsol) = &
108  massflowfamilyinv(ind, spectralsol) &
109  + factfamilyi(i, j, k) * fs
110 #endif
111  fs = rqsp * w(i + 1, j, k, ivx) + rqsm * w(i, j, k, ivx) &
112  + pa * si(i, j, k, 1)
113  dw(i + 1, j, k, imx) = dw(i + 1, j, k, imx) - fs
114  dw(i, j, k, imx) = dw(i, j, k, imx) + fs
115 
116  fs = rqsp * w(i + 1, j, k, ivy) + rqsm * w(i, j, k, ivy) &
117  + pa * si(i, j, k, 2)
118  dw(i + 1, j, k, imy) = dw(i + 1, j, k, imy) - fs
119  dw(i, j, k, imy) = dw(i, j, k, imy) + fs
120 
121  fs = rqsp * w(i + 1, j, k, ivz) + rqsm * w(i, j, k, ivz) &
122  + pa * si(i, j, k, 3)
123  dw(i + 1, j, k, imz) = dw(i + 1, j, k, imz) - fs
124  dw(i, j, k, imz) = dw(i, j, k, imz) + fs
125 
126  fs = qsp * w(i + 1, j, k, irhoe) + qsm * w(i, j, k, irhoe) &
127  + porflux * (vnp * p(i + 1, j, k) + vnm * p(i, j, k))
128  dw(i + 1, j, k, irhoe) = dw(i + 1, j, k, irhoe) - fs
129  dw(i, j, k, irhoe) = dw(i, j, k, irhoe) + fs
130 #ifdef TAPENADE_REVERSE
131  end do
132 #else
133  end do
134  end do
135  end do
136 #endif
137  continue
138  !$AD CHECKPOINT-END
139 
140  !
141  ! Advective fluxes in the j-direction.
142  !
143  continue
144  !$AD CHECKPOINT-START
145  sface = zero
146 #ifdef TAPENADE_REVERSE
147  !$AD II-LOOP
148  do ii = 0, nx * jl * nz - 1
149  i = mod(ii, nx) + 2
150  j = mod(ii / nx, jl) + 1
151  k = ii / (nx * jl) + 2
152 #else
153  do k = 2, kl
154  do j = 1, jl
155  do i = 2, il
156 #endif
157  ! Set the dot product of the grid velocity and the
158  ! normal in j-direction for a moving face.
159 
160  if (addgridvelocities) sface = sfacej(i, j, k)
161 
162  ! Compute the normal velocities of the left and right state.
163 
164  vnp = w(i, j + 1, k, ivx) * sj(i, j, k, 1) &
165  + w(i, j + 1, k, ivy) * sj(i, j, k, 2) &
166  + w(i, j + 1, k, ivz) * sj(i, j, k, 3)
167  vnm = w(i, j, k, ivx) * sj(i, j, k, 1) &
168  + w(i, j, k, ivy) * sj(i, j, k, 2) &
169  + w(i, j, k, ivz) * sj(i, j, k, 3)
170 
171  ! Set the values of the porosities for this face.
172  ! porVel defines the porosity w.r.t. velocity;
173  ! porFlux defines the porosity w.r.t. the entire flux.
174  ! The latter is only zero for a discontinuous block
175  ! boundary that must be treated conservatively.
176  ! The default value of porFlux is 0.5, such that the
177  ! correct central flux is scattered to both cells.
178  ! In case of a boundFlux the normal velocity is set
179  ! to sFace.
180 
181  porvel = one
182  porflux = half
183  if (porj(i, j, k) == noflux) porflux = zero
184  if (porj(i, j, k) == boundflux) then
185  porvel = zero
186  vnp = sface
187  vnm = sface
188  end if
189 
190  ! Incorporate porFlux in porVel.
191 
192  porvel = porvel * porflux
193 
194  ! Compute the normal velocities for the face as well as the
195  ! mass fluxes.
196 
197  qsp = (vnp - sface) * porvel
198  qsm = (vnm - sface) * porvel
199 
200  rqsp = qsp * w(i, j + 1, k, irho)
201  rqsm = qsm * w(i, j, k, irho)
202 
203  ! Compute the sum of the pressure multiplied by porFlux.
204  ! For the default value of porFlux, 0.5, this leads to
205  ! the average pressure.
206 
207  pa = porflux * (p(i, j + 1, k) + p(i, j, k))
208 
209  ! Compute the fluxes and scatter them to the cells
210  ! i,j,k and i,j+1,k. Store the density flux in the
211  ! mass flow of the appropriate sliding mesh interface.
212 
213  fs = rqsp + rqsm
214  dw(i, j + 1, k, irho) = dw(i, j + 1, k, irho) - fs
215  dw(i, j, k, irho) = dw(i, j, k, irho) + fs
216 #ifndef USE_TAPENADE
217  ind = indfamilyj(i, j, k)
218  massflowfamilyinv(ind, spectralsol) = &
219  massflowfamilyinv(ind, spectralsol) &
220  + factfamilyj(i, j, k) * fs
221 #endif
222  fs = rqsp * w(i, j + 1, k, ivx) + rqsm * w(i, j, k, ivx) &
223  + pa * sj(i, j, k, 1)
224  dw(i, j + 1, k, imx) = dw(i, j + 1, k, imx) - fs
225  dw(i, j, k, imx) = dw(i, j, k, imx) + fs
226 
227  fs = rqsp * w(i, j + 1, k, ivy) + rqsm * w(i, j, k, ivy) &
228  + pa * sj(i, j, k, 2)
229  dw(i, j + 1, k, imy) = dw(i, j + 1, k, imy) - fs
230  dw(i, j, k, imy) = dw(i, j, k, imy) + fs
231 
232  fs = rqsp * w(i, j + 1, k, ivz) + rqsm * w(i, j, k, ivz) &
233  + pa * sj(i, j, k, 3)
234  dw(i, j + 1, k, imz) = dw(i, j + 1, k, imz) - fs
235  dw(i, j, k, imz) = dw(i, j, k, imz) + fs
236 
237  fs = qsp * w(i, j + 1, k, irhoe) + qsm * w(i, j, k, irhoe) &
238  + porflux * (vnp * p(i, j + 1, k) + vnm * p(i, j, k))
239  dw(i, j + 1, k, irhoe) = dw(i, j + 1, k, irhoe) - fs
240  dw(i, j, k, irhoe) = dw(i, j, k, irhoe) + fs
241 
242 #ifdef TAPENADE_REVERSE
243  end do
244 #else
245  end do
246  end do
247  end do
248 #endif
249  continue
250  !$AD CHECKPOINT-END
251 
252  !
253  ! Advective fluxes in the k-direction.
254  continue
255  !$AD CHECKPOINT-START
256  sface = zero
257 #ifdef TAPENADE_REVERSE
258  !$AD II-LOOP
259  do ii = 0, nx * ny * kl - 1
260  i = mod(ii, nx) + 2
261  j = mod(ii / nx, ny) + 2
262  k = ii / (nx * ny) + 1
263 #else
264  do k = 1, kl
265  do j = 2, jl
266  do i = 2, il
267 #endif
268  ! Set the dot product of the grid velocity and the
269  ! normal in k-direction for a moving face.
270 
271  if (addgridvelocities) sface = sfacek(i, j, k)
272 
273  ! Compute the normal velocities of the left and right state.
274 
275  vnp = w(i, j, k + 1, ivx) * sk(i, j, k, 1) &
276  + w(i, j, k + 1, ivy) * sk(i, j, k, 2) &
277  + w(i, j, k + 1, ivz) * sk(i, j, k, 3)
278  vnm = w(i, j, k, ivx) * sk(i, j, k, 1) &
279  + w(i, j, k, ivy) * sk(i, j, k, 2) &
280  + w(i, j, k, ivz) * sk(i, j, k, 3)
281 
282  ! Set the values of the porosities for this face.
283  ! porVel defines the porosity w.r.t. velocity;
284  ! porFlux defines the porosity w.r.t. the entire flux.
285  ! The latter is only zero for a discontinuous block
286  ! block boundary that must be treated conservatively.
287  ! The default value of porFlux is 0.5, such that the
288  ! correct central flux is scattered to both cells.
289  ! In case of a boundFlux the normal velocity is set
290  ! to sFace.
291 
292  porvel = one
293  porflux = half
294 
295  if (pork(i, j, k) == noflux) porflux = zero
296  if (pork(i, j, k) == boundflux) then
297  porvel = zero
298  vnp = sface
299  vnm = sface
300  end if
301 
302  ! Incorporate porFlux in porVel.
303 
304  porvel = porvel * porflux
305 
306  ! Compute the normal velocities for the face as well as the
307  ! mass fluxes.
308 
309  qsp = (vnp - sface) * porvel
310  qsm = (vnm - sface) * porvel
311 
312  rqsp = qsp * w(i, j, k + 1, irho)
313  rqsm = qsm * w(i, j, k, irho)
314 
315  ! Compute the sum of the pressure multiplied by porFlux.
316  ! For the default value of porFlux, 0.5, this leads to
317  ! the average pressure.
318 
319  pa = porflux * (p(i, j, k + 1) + p(i, j, k))
320 
321  ! Compute the fluxes and scatter them to the cells
322  ! i,j,k and i,j,k+1. Store the density flux in the
323  ! mass flow of the appropriate sliding mesh interface.
324 
325  fs = rqsp + rqsm
326  dw(i, j, k + 1, irho) = dw(i, j, k + 1, irho) - fs
327  dw(i, j, k, irho) = dw(i, j, k, irho) + fs
328 #ifndef USE_TAPENADE
329  ind = indfamilyk(i, j, k)
330  massflowfamilyinv(ind, spectralsol) = &
331  massflowfamilyinv(ind, spectralsol) &
332  + factfamilyk(i, j, k) * fs
333 #endif
334  fs = rqsp * w(i, j, k + 1, ivx) + rqsm * w(i, j, k, ivx) &
335  + pa * sk(i, j, k, 1)
336  dw(i, j, k + 1, imx) = dw(i, j, k + 1, imx) - fs
337  dw(i, j, k, imx) = dw(i, j, k, imx) + fs
338 
339  fs = rqsp * w(i, j, k + 1, ivy) + rqsm * w(i, j, k, ivy) &
340  + pa * sk(i, j, k, 2)
341  dw(i, j, k + 1, imy) = dw(i, j, k + 1, imy) - fs
342  dw(i, j, k, imy) = dw(i, j, k, imy) + fs
343 
344  fs = rqsp * w(i, j, k + 1, ivz) + rqsm * w(i, j, k, ivz) &
345  + pa * sk(i, j, k, 3)
346  dw(i, j, k + 1, imz) = dw(i, j, k + 1, imz) - fs
347  dw(i, j, k, imz) = dw(i, j, k, imz) + fs
348 
349  fs = qsp * w(i, j, k + 1, irhoe) + qsm * w(i, j, k, irhoe) &
350  + porflux * (vnp * p(i, j, k + 1) + vnm * p(i, j, k))
351  dw(i, j, k + 1, irhoe) = dw(i, j, k + 1, irhoe) - fs
352  dw(i, j, k, irhoe) = dw(i, j, k, irhoe) + fs
353 #ifdef TAPENADE_REVERSE
354  end do
355 #else
356  end do
357  end do
358  end do
359 #endif
360  continue
361  !$AD CHECKPOINT-END
362 
363  ! Add the rotational source terms for a moving block in a
364  ! steady state computation. These source terms account for the
365  ! centrifugal acceleration and the coriolis term. However, as
366  ! the the equations are solved in the inertial frame and not
367  ! in the moving frame, the form is different than what you
368  ! normally find in a text book.
369 
370  continue
371  !$AD CHECKPOINT-START
372  rotation: if (blockismoving .and. equationmode == steady) then
373 
374  ! Compute the three nonDimensional angular velocities.
375 
376  wwx = timeref * cgnsdoms(nbkglobal)%rotRate(1)
377  wwy = timeref * cgnsdoms(nbkglobal)%rotRate(2)
378  wwz = timeref * cgnsdoms(nbkglobal)%rotRate(3)
379 
380  ! Loop over the internal cells of this block to compute the
381  ! rotational terms for the momentum equations.
382  !$AD II-LOOP
383  do ii = 0, nx * ny * nz - 1
384  i = mod(ii, nx) + 2
385  j = mod(ii / nx, ny) + 2
386  k = ii / (nx * ny) + 2
387  rvol = w(i, j, k, irho) * vol(i, j, k)
388 
389  dw(i, j, k, imx) = dw(i, j, k, imx) &
390  + rvol * (wwy * w(i, j, k, ivz) - wwz * w(i, j, k, ivy))
391  dw(i, j, k, imy) = dw(i, j, k, imy) &
392  + rvol * (wwz * w(i, j, k, ivx) - wwx * w(i, j, k, ivz))
393  dw(i, j, k, imz) = dw(i, j, k, imz) &
394  + rvol * (wwx * w(i, j, k, ivy) - wwy * w(i, j, k, ivx))
395  end do
396 
397  end if rotation
398 
399  !$AD CHECKPOINT-END
400  continue
401  end subroutine inviscidcentralflux
402 
403  subroutine invisciddissfluxmatrix
404  !
405  ! inviscidDissFluxMatrix computes the matrix artificial
406  ! dissipation term. Instead of the spectral radius, as used in
407  ! the scalar dissipation scheme, the absolute value of the flux
408  ! jacobian is used. This leads to a less diffusive and
409  ! consequently more accurate scheme. It is assumed that the
410  ! pointers in blockPointers already point to the correct block.
411  !
412  use constants
413  use blockpointers, only: nx, ny, nz, il, jl, kl, ie, je, ke, ib, jb, kb, &
414  w, p, pori, porj, pork, fw, gamma, si, sj, sk, &
415  indfamilyi, indfamilyj, indfamilyk, spectralsol, addgridvelocities, &
416  sfacei, sfacej, sfacek, factfamilyi, factfamilyj, factfamilyk
417  use flowvarrefstate, only: pinfcorr
418  use inputdiscretization, only: vis2, vis4
419  use inputphysics, only: equations
420  use iteration, only: rfil
421  use cgnsgrid, only: massflowfamilydiss
422  use utils, only: getcorrectfork, mydim
423  implicit none
424  !
425  ! Local parameters.
426  !
427  real(kind=realtype), parameter :: dpmax = 0.25_realtype
428  real(kind=realtype), parameter :: epsacoustic = 0.25_realtype
429  real(kind=realtype), parameter :: epsshear = 0.025_realtype
430  real(kind=realtype), parameter :: omega = 0.5_realtype
431  real(kind=realtype), parameter :: oneminomega = one - omega
432  !
433  ! Local variables.
434  !
435  integer(kind=intType) :: i, j, k, ind, ii
436 
437  real(kind=realtype) :: plim, sface
438  real(kind=realtype) :: sfil, fis2, fis4
439  real(kind=realtype) :: gammaavg, gm1, ovgm1, gm53
440  real(kind=realtype) :: ppor, rrad, dis2, dis4
441  real(kind=realtype) :: dp1, dp2, tmp, fs
442  real(kind=realtype) :: ddw1, ddw2, ddw3, ddw4, ddw5, ddw6
443  real(kind=realtype) :: dr, dru, drv, drw, dre, drk, sx, sy, sz
444  real(kind=realtype) :: uavg, vavg, wavg, a2avg, aavg, havg
445  real(kind=realtype) :: alphaavg, unavg, ovaavg, ova2avg
446  real(kind=realtype) :: kavg, lam1, lam2, lam3, area
447  real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
448  real(kind=realtype), dimension(1:ie, 1:je, 1:ke, 3) :: dss
449  logical :: correctForK
450 
451  ! Check if rFil == 0. If so, the dissipative flux needs not to
452  ! be computed.
453 
454  if (abs(rfil) < thresholdreal) return
455 
456  ! Set the value of plim. To be fully consistent this must have
457  ! the dimension of a pressure. Therefore a fraction of pInfCorr
458  ! is used.
459 
460  plim = 0.001_realtype * pinfcorr
461 
462  ! Determine whether or not the total energy must be corrected
463  ! for the presence of the turbulent kinetic energy.
464 
465  correctfork = getcorrectfork()
466 
467  ! Initialize sface to zero. This value will be used if the
468  ! block is not moving.
469 
470  sface = zero
471 
472  ! Set a couple of constants for the scheme.
473 
474  fis2 = rfil * vis2
475  fis4 = rfil * vis4
476  sfil = one - rfil
477 
478  ! Initialize the dissipative residual to a certain times,
479  ! possibly zero, the previously stored value.
480 
481  fw = sfil * fw
482 
483  ! Compute the pressure sensor for each cell, in each direction:
484 #ifdef TAPENADE_REVERSE
485  !$AD II-LOOP
486  do ii = 0, ie * je * ke - 1
487  i = mod(ii, ie) + 1
488  j = mod(ii / ie, je) + 1
489  k = ii / (ie * je) + 1
490 #else
491  do k = 1, ke
492  do j = 1, je
493  do i = 1, ie
494 #endif
495  dss(i, j, k, 1) = abs((p(i + 1, j, k) - two * p(i, j, k) + p(i - 1, j, k)) &
496  / (omega * (p(i + 1, j, k) + two * p(i, j, k) + p(i - 1, j, k)) &
497  + oneminomega * (abs(p(i + 1, j, k) - p(i, j, k)) &
498  + abs(p(i, j, k) - p(i - 1, j, k))) + plim))
499 
500  dss(i, j, k, 2) = abs((p(i, j + 1, k) - two * p(i, j, k) + p(i, j - 1, k)) &
501  / (omega * (p(i, j + 1, k) + two * p(i, j, k) + p(i, j - 1, k)) &
502  + oneminomega * (abs(p(i, j + 1, k) - p(i, j, k)) &
503  + abs(p(i, j, k) - p(i, j - 1, k))) + plim))
504 
505  dss(i, j, k, 3) = abs((p(i, j, k + 1) - two * p(i, j, k) + p(i, j, k - 1)) &
506  / (omega * (p(i, j, k + 1) + two * p(i, j, k) + p(i, j, k - 1)) &
507  + oneminomega * (abs(p(i, j, k + 1) - p(i, j, k)) &
508  + abs(p(i, j, k) - p(i, j, k - 1))) + plim))
509 #ifdef TAPENADE_REVERSE
510  end do
511 #else
512  end do
513  end do
514  end do
515 #endif
516  !
517  ! Dissipative fluxes in the i-direction.
518  !
519 #ifdef TAPENADE_REVERSE
520  !$AD II-LOOP
521  do ii = 0, il * ny * nz - 1
522  i = mod(ii, il) + 1
523  j = mod(ii / il, ny) + 2
524  k = ii / (il * ny) + 2
525 #else
526  do k = 2, kl
527  do j = 2, jl
528  do i = 1, il
529 #endif
530  ! Compute the dissipation coefficients for this face.
531 
532  ppor = zero
533  if (pori(i, j, k) == normalflux) ppor = one
534  dis2 = ppor * fis2 * min(dpmax, max(dss(i, j, k, 1), dss(i + 1, j, k, 1)))
535  dis4 = mydim(ppor * fis4, dis2)
536 
537  ! Construct the vector of the first and third differences
538  ! multiplied by the appropriate constants.
539 
540  ddw1 = w(i + 1, j, k, irho) - w(i, j, k, irho)
541  dr = dis2 * ddw1 &
542  - dis4 * (w(i + 2, j, k, irho) - w(i - 1, j, k, irho) - three * ddw1)
543 
544  ddw2 = w(i + 1, j, k, irho) * w(i + 1, j, k, ivx) &
545  - w(i, j, k, irho) * w(i, j, k, ivx)
546  dru = dis2 * ddw2 &
547  - dis4 * (w(i + 2, j, k, irho) * w(i + 2, j, k, ivx) &
548  - w(i - 1, j, k, irho) * w(i - 1, j, k, ivx) - three * ddw2)
549 
550  ddw3 = w(i + 1, j, k, irho) * w(i + 1, j, k, ivy) &
551  - w(i, j, k, irho) * w(i, j, k, ivy)
552  drv = dis2 * ddw3 &
553  - dis4 * (w(i + 2, j, k, irho) * w(i + 2, j, k, ivy) &
554  - w(i - 1, j, k, irho) * w(i - 1, j, k, ivy) - three * ddw3)
555 
556  ddw4 = w(i + 1, j, k, irho) * w(i + 1, j, k, ivz) &
557  - w(i, j, k, irho) * w(i, j, k, ivz)
558  drw = dis2 * ddw4 &
559  - dis4 * (w(i + 2, j, k, irho) * w(i + 2, j, k, ivz) &
560  - w(i - 1, j, k, irho) * w(i - 1, j, k, ivz) - three * ddw4)
561 
562  ddw5 = w(i + 1, j, k, irhoe) - w(i, j, k, irhoe)
563  dre = dis2 * ddw5 &
564  - dis4 * (w(i + 2, j, k, irhoe) - w(i - 1, j, k, irhoe) - three * ddw5)
565 
566  ! In case a k-equation is present, compute the difference
567  ! of rhok and store the average value of k. If not present,
568  ! set both these values to zero, such that later on no
569  ! decision needs to be made anymore.
570 
571  if (correctfork) then
572  ddw6 = w(i + 1, j, k, irho) * w(i + 1, j, k, itu1) &
573  - w(i, j, k, irho) * w(i, j, k, itu1)
574  drk = dis2 * ddw6 &
575  - dis4 * (w(i + 2, j, k, irho) * w(i + 2, j, k, itu1) &
576  - w(i - 1, j, k, irho) * w(i - 1, j, k, itu1) - three * ddw6)
577 
578  kavg = half * (w(i, j, k, itu1) + w(i + 1, j, k, itu1))
579  else
580  drk = zero
581  kavg = zero
582  end if
583 
584  ! Compute the average value of gamma and compute some
585  ! expressions in which it occurs.
586 
587  gammaavg = half * (gamma(i + 1, j, k) + gamma(i, j, k))
588  gm1 = gammaavg - one
589  ovgm1 = one / gm1
590  gm53 = gammaavg - five * third
591 
592  ! Compute the average state at the interface.
593 
594  uavg = half * (w(i + 1, j, k, ivx) + w(i, j, k, ivx))
595  vavg = half * (w(i + 1, j, k, ivy) + w(i, j, k, ivy))
596  wavg = half * (w(i + 1, j, k, ivz) + w(i, j, k, ivz))
597  a2avg = half * (gamma(i + 1, j, k) * p(i + 1, j, k) / w(i + 1, j, k, irho) &
598  + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
599 
600  area = sqrt(si(i, j, k, 1)**2 + si(i, j, k, 2)**2 + si(i, j, k, 3)**2)
601  tmp = one / max(1.e-25_realtype, area)
602  sx = si(i, j, k, 1) * tmp
603  sy = si(i, j, k, 2) * tmp
604  sz = si(i, j, k, 3) * tmp
605 
606  alphaavg = half * (uavg**2 + vavg**2 + wavg**2)
607  havg = alphaavg + ovgm1 * (a2avg - gm53 * kavg)
608  aavg = sqrt(a2avg)
609  unavg = uavg * sx + vavg * sy + wavg * sz
610  ovaavg = one / aavg
611  ova2avg = one / a2avg
612 
613  ! The mesh velocity if the face is moving. It must be
614  ! divided by the area to obtain a true velocity.
615 
616  if (addgridvelocities) sface = sfacei(i, j, k) * tmp
617 
618  ! Compute the absolute values of the three eigenvalues
619  ! and make sure they don't become zero by cutting them
620  ! off to a certain minimum.
621 
622  lam1 = abs(unavg - sface + aavg)
623  lam2 = abs(unavg - sface - aavg)
624  lam3 = abs(unavg - sface)
625 
626  rrad = lam3 + aavg
627 
628  ! Multiply the eigenvalues by the area to obtain
629  ! the correct values for the dissipation term.
630 
631  lam1 = max(lam1, epsacoustic * rrad) * area
632  lam2 = max(lam2, epsacoustic * rrad) * area
633  lam3 = max(lam3, epsshear * rrad) * area
634 
635  ! Some abbreviations, which occur quite often in the
636  ! dissipation terms.
637 
638  abv1 = half * (lam1 + lam2)
639  abv2 = half * (lam1 - lam2)
640  abv3 = abv1 - lam3
641 
642  abv4 = gm1 * (alphaavg * dr - uavg * dru - vavg * drv &
643  - wavg * drw + dre) - gm53 * drk
644  abv5 = sx * dru + sy * drv + sz * drw - unavg * dr
645 
646  abv6 = abv3 * abv4 * ova2avg + abv2 * abv5 * ovaavg
647  abv7 = abv2 * abv4 * ovaavg + abv3 * abv5
648 
649  ! Compute and scatter the dissipative flux.
650  ! Density.
651 
652  fs = lam3 * dr + abv6
653  fw(i + 1, j, k, irho) = fw(i + 1, j, k, irho) + fs
654  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
655 #ifndef USE_TAPENADE
656  ind = indfamilyi(i, j, k)
657  massflowfamilydiss(ind, spectralsol) = &
658  massflowfamilydiss(ind, spectralsol) &
659  - factfamilyi(i, j, k) * fs
660 #endif
661  ! X-momentum.
662 
663  fs = lam3 * dru + uavg * abv6 + sx * abv7
664  fw(i + 1, j, k, imx) = fw(i + 1, j, k, imx) + fs
665  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
666 
667  ! Y-momentum.
668 
669  fs = lam3 * drv + vavg * abv6 + sy * abv7
670  fw(i + 1, j, k, imy) = fw(i + 1, j, k, imy) + fs
671  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
672 
673  ! Z-momentum.
674 
675  fs = lam3 * drw + wavg * abv6 + sz * abv7
676  fw(i + 1, j, k, imz) = fw(i + 1, j, k, imz) + fs
677  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
678 
679  ! Energy.
680 
681  fs = lam3 * dre + havg * abv6 + unavg * abv7
682  fw(i + 1, j, k, irhoe) = fw(i + 1, j, k, irhoe) + fs
683  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
684 
685 #ifdef TAPENADE_REVERSE
686  end do
687 #else
688  end do
689  end do
690  end do
691 #endif
692  !
693  ! Dissipative fluxes in the j-direction.
694  !
695 #ifdef TAPENADE_REVERSE
696  !$AD II-LOOP
697  do ii = 0, nx * jl * nz - 1
698  i = mod(ii, nx) + 2
699  j = mod(ii / nx, jl) + 1
700  k = ii / (nx * jl) + 2
701 #else
702  do k = 2, kl
703  do j = 1, jl
704  do i = 2, il
705 #endif
706 
707  ! Compute the dissipation coefficients for this face.
708 
709  ppor = zero
710  if (porj(i, j, k) == normalflux) ppor = one
711 
712  dis2 = ppor * fis2 * min(dpmax, max(dss(i, j, k, 2), dss(i, j + 1, k, 2)))
713  dis4 = mydim(ppor * fis4, dis2)
714 
715  ! Construct the vector of the first and third differences
716  ! multiplied by the appropriate constants.
717 
718  ddw1 = w(i, j + 1, k, irho) - w(i, j, k, irho)
719  dr = dis2 * ddw1 &
720  - dis4 * (w(i, j + 2, k, irho) - w(i, j - 1, k, irho) - three * ddw1)
721 
722  ddw2 = w(i, j + 1, k, irho) * w(i, j + 1, k, ivx) &
723  - w(i, j, k, irho) * w(i, j, k, ivx)
724  dru = dis2 * ddw2 &
725  - dis4 * (w(i, j + 2, k, irho) * w(i, j + 2, k, ivx) &
726  - w(i, j - 1, k, irho) * w(i, j - 1, k, ivx) - three * ddw2)
727 
728  ddw3 = w(i, j + 1, k, irho) * w(i, j + 1, k, ivy) &
729  - w(i, j, k, irho) * w(i, j, k, ivy)
730  drv = dis2 * ddw3 &
731  - dis4 * (w(i, j + 2, k, irho) * w(i, j + 2, k, ivy) &
732  - w(i, j - 1, k, irho) * w(i, j - 1, k, ivy) - three * ddw3)
733 
734  ddw4 = w(i, j + 1, k, irho) * w(i, j + 1, k, ivz) &
735  - w(i, j, k, irho) * w(i, j, k, ivz)
736  drw = dis2 * ddw4 &
737  - dis4 * (w(i, j + 2, k, irho) * w(i, j + 2, k, ivz) &
738  - w(i, j - 1, k, irho) * w(i, j - 1, k, ivz) - three * ddw4)
739 
740  ddw5 = w(i, j + 1, k, irhoe) - w(i, j, k, irhoe)
741  dre = dis2 * ddw5 &
742  - dis4 * (w(i, j + 2, k, irhoe) - w(i, j - 1, k, irhoe) - three * ddw5)
743 
744  ! In case a k-equation is present, compute the difference
745  ! of rhok and store the average value of k. If not present,
746  ! set both these values to zero, such that later on no
747  ! decision needs to be made anymore.
748 
749  if (correctfork) then
750  ddw6 = w(i, j + 1, k, irho) * w(i, j + 1, k, itu1) &
751  - w(i, j, k, irho) * w(i, j, k, itu1)
752  drk = dis2 * ddw6 &
753  - dis4 * (w(i, j + 2, k, irho) * w(i, j + 2, k, itu1) &
754  - w(i, j - 1, k, irho) * w(i, j - 1, k, itu1) - three * ddw6)
755 
756  kavg = half * (w(i, j, k, itu1) + w(i, j + 1, k, itu1))
757  else
758  drk = zero
759  kavg = zero
760  end if
761 
762  ! Compute the average value of gamma and compute some
763  ! expressions in which it occurs.
764 
765  gammaavg = half * (gamma(i, j + 1, k) + gamma(i, j, k))
766  gm1 = gammaavg - one
767  ovgm1 = one / gm1
768  gm53 = gammaavg - five * third
769 
770  ! Compute the average state at the interface.
771 
772  uavg = half * (w(i, j + 1, k, ivx) + w(i, j, k, ivx))
773  vavg = half * (w(i, j + 1, k, ivy) + w(i, j, k, ivy))
774  wavg = half * (w(i, j + 1, k, ivz) + w(i, j, k, ivz))
775  a2avg = half * (gamma(i, j + 1, k) * p(i, j + 1, k) / w(i, j + 1, k, irho) &
776  + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
777 
778  area = sqrt(sj(i, j, k, 1)**2 + sj(i, j, k, 2)**2 + sj(i, j, k, 3)**2)
779  tmp = one / max(1.e-25_realtype, area)
780  sx = sj(i, j, k, 1) * tmp
781  sy = sj(i, j, k, 2) * tmp
782  sz = sj(i, j, k, 3) * tmp
783 
784  alphaavg = half * (uavg**2 + vavg**2 + wavg**2)
785  havg = alphaavg + ovgm1 * (a2avg - gm53 * kavg)
786  aavg = sqrt(a2avg)
787  unavg = uavg * sx + vavg * sy + wavg * sz
788  ovaavg = one / aavg
789  ova2avg = one / a2avg
790 
791  ! The mesh velocity if the face is moving. It must be
792  ! divided by the area to obtain a true velocity.
793 
794  if (addgridvelocities) sface = sfacej(i, j, k) * tmp
795 
796  ! Compute the absolute values of the three eigenvalues
797  ! and make sure they don't become zero by cutting them
798  ! off to a certain minimum.
799 
800  lam1 = abs(unavg - sface + aavg)
801  lam2 = abs(unavg - sface - aavg)
802  lam3 = abs(unavg - sface)
803 
804  rrad = lam3 + aavg
805 
806  ! Multiply the eigenvalues by the area to obtain
807  ! the correct values for the dissipation term.
808 
809  lam1 = max(lam1, epsacoustic * rrad) * area
810  lam2 = max(lam2, epsacoustic * rrad) * area
811  lam3 = max(lam3, epsshear * rrad) * area
812 
813  ! Some abbreviations, which occur quite often in the
814  ! dissipation terms.
815 
816  abv1 = half * (lam1 + lam2)
817  abv2 = half * (lam1 - lam2)
818  abv3 = abv1 - lam3
819 
820  abv4 = gm1 * (alphaavg * dr - uavg * dru - vavg * drv &
821  - wavg * drw + dre) - gm53 * drk
822  abv5 = sx * dru + sy * drv + sz * drw - unavg * dr
823 
824  abv6 = abv3 * abv4 * ova2avg + abv2 * abv5 * ovaavg
825  abv7 = abv2 * abv4 * ovaavg + abv3 * abv5
826 
827  ! Compute and scatter the dissipative flux.
828  ! Density.
829 
830  fs = lam3 * dr + abv6
831  fw(i, j + 1, k, irho) = fw(i, j + 1, k, irho) + fs
832  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
833 #ifndef USE_TAPENADE
834  ind = indfamilyj(i, j, k)
835  massflowfamilydiss(ind, spectralsol) = &
836  massflowfamilydiss(ind, spectralsol) &
837  - factfamilyj(i, j, k) * fs
838 #endif
839  ! X-momentum.
840 
841  fs = lam3 * dru + uavg * abv6 + sx * abv7
842  fw(i, j + 1, k, imx) = fw(i, j + 1, k, imx) + fs
843  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
844 
845  ! Y-momentum.
846 
847  fs = lam3 * drv + vavg * abv6 + sy * abv7
848  fw(i, j + 1, k, imy) = fw(i, j + 1, k, imy) + fs
849  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
850 
851  ! Z-momentum.
852 
853  fs = lam3 * drw + wavg * abv6 + sz * abv7
854  fw(i, j + 1, k, imz) = fw(i, j + 1, k, imz) + fs
855  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
856 
857  ! Energy.
858 
859  fs = lam3 * dre + havg * abv6 + unavg * abv7
860  fw(i, j + 1, k, irhoe) = fw(i, j + 1, k, irhoe) + fs
861  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
862 
863 #ifdef TAPENADE_REVERSE
864  end do
865 #else
866  end do
867  end do
868  end do
869 #endif
870  !
871  ! Dissipative fluxes in the k-direction.
872  !
873 #ifdef TAPENADE_REVERSE
874  !$AD II-LOOP
875  do ii = 0, nx * ny * kl - 1
876  i = mod(ii, nx) + 2
877  j = mod(ii / nx, ny) + 2
878  k = ii / (nx * ny) + 1
879 #else
880  do k = 1, kl
881  do j = 2, jl
882  do i = 2, il
883 #endif
884  ! Compute the dissipation coefficients for this face.
885 
886  ppor = zero
887  if (pork(i, j, k) == normalflux) ppor = one
888 
889  dis2 = ppor * fis2 * min(dpmax, max(dss(i, j, k, 3), dss(i, j, k + 1, 3)))
890  dis4 = mydim(ppor * fis4, dis2)
891 
892  ! Construct the vector of the first and third differences
893  ! multiplied by the appropriate constants.
894 
895  ddw1 = w(i, j, k + 1, irho) - w(i, j, k, irho)
896  dr = dis2 * ddw1 &
897  - dis4 * (w(i, j, k + 2, irho) - w(i, j, k - 1, irho) - three * ddw1)
898 
899  ddw2 = w(i, j, k + 1, irho) * w(i, j, k + 1, ivx) &
900  - w(i, j, k, irho) * w(i, j, k, ivx)
901  dru = dis2 * ddw2 &
902  - dis4 * (w(i, j, k + 2, irho) * w(i, j, k + 2, ivx) &
903  - w(i, j, k - 1, irho) * w(i, j, k - 1, ivx) - three * ddw2)
904 
905  ddw3 = w(i, j, k + 1, irho) * w(i, j, k + 1, ivy) &
906  - w(i, j, k, irho) * w(i, j, k, ivy)
907  drv = dis2 * ddw3 &
908  - dis4 * (w(i, j, k + 2, irho) * w(i, j, k + 2, ivy) &
909  - w(i, j, k - 1, irho) * w(i, j, k - 1, ivy) - three * ddw3)
910 
911  ddw4 = w(i, j, k + 1, irho) * w(i, j, k + 1, ivz) &
912  - w(i, j, k, irho) * w(i, j, k, ivz)
913  drw = dis2 * ddw4 &
914  - dis4 * (w(i, j, k + 2, irho) * w(i, j, k + 2, ivz) &
915  - w(i, j, k - 1, irho) * w(i, j, k - 1, ivz) - three * ddw4)
916 
917  ddw5 = w(i, j, k + 1, irhoe) - w(i, j, k, irhoe)
918  dre = dis2 * ddw5 &
919  - dis4 * (w(i, j, k + 2, irhoe) - w(i, j, k - 1, irhoe) - three * ddw5)
920 
921  ! In case a k-equation is present, compute the difference
922  ! of rhok and store the average value of k. If not present,
923  ! set both these values to zero, such that later on no
924  ! decision needs to be made anymore.
925 
926  if (correctfork) then
927  ddw6 = w(i, j, k + 1, irho) * w(i, j, k + 1, itu1) &
928  - w(i, j, k, irho) * w(i, j, k, itu1)
929  drk = dis2 * ddw6 &
930  - dis4 * (w(i, j, k + 2, irho) * w(i, j, k + 2, itu1) &
931  - w(i, j, k - 1, irho) * w(i, j, k - 1, itu1) - three * ddw6)
932 
933  kavg = half * (w(i, j, k + 1, itu1) + w(i, j, k, itu1))
934  else
935  drk = zero
936  kavg = zero
937  end if
938 
939  ! Compute the average value of gamma and compute some
940  ! expressions in which it occurs.
941 
942  gammaavg = half * (gamma(i, j, k + 1) + gamma(i, j, k))
943  gm1 = gammaavg - one
944  ovgm1 = one / gm1
945  gm53 = gammaavg - five * third
946 
947  ! Compute the average state at the interface.
948 
949  uavg = half * (w(i, j, k + 1, ivx) + w(i, j, k, ivx))
950  vavg = half * (w(i, j, k + 1, ivy) + w(i, j, k, ivy))
951  wavg = half * (w(i, j, k + 1, ivz) + w(i, j, k, ivz))
952  a2avg = half * (gamma(i, j, k + 1) * p(i, j, k + 1) / w(i, j, k + 1, irho) &
953  + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
954 
955  area = sqrt(sk(i, j, k, 1)**2 + sk(i, j, k, 2)**2 + sk(i, j, k, 3)**2)
956  tmp = one / max(1.e-25_realtype, area)
957  sx = sk(i, j, k, 1) * tmp
958  sy = sk(i, j, k, 2) * tmp
959  sz = sk(i, j, k, 3) * tmp
960 
961  alphaavg = half * (uavg**2 + vavg**2 + wavg**2)
962  havg = alphaavg + ovgm1 * (a2avg - gm53 * kavg)
963  aavg = sqrt(a2avg)
964  unavg = uavg * sx + vavg * sy + wavg * sz
965  ovaavg = one / aavg
966  ova2avg = one / a2avg
967 
968  ! The mesh velocity if the face is moving. It must be
969  ! divided by the area to obtain a true velocity.
970 
971  if (addgridvelocities) sface = sfacek(i, j, k) * tmp
972 
973  ! Compute the absolute values of the three eigenvalues
974  ! and make sure they don't become zero by cutting them
975  ! off to a certain minimum.
976 
977  lam1 = abs(unavg - sface + aavg)
978  lam2 = abs(unavg - sface - aavg)
979  lam3 = abs(unavg - sface)
980 
981  rrad = lam3 + aavg
982 
983  ! Multiply the eigenvalues by the area to obtain
984  ! the correct values for the dissipation term.
985 
986  lam1 = max(lam1, epsacoustic * rrad) * area
987  lam2 = max(lam2, epsacoustic * rrad) * area
988  lam3 = max(lam3, epsshear * rrad) * area
989 
990  ! Some abbreviations, which occur quite often in the
991  ! dissipation terms.
992 
993  abv1 = half * (lam1 + lam2)
994  abv2 = half * (lam1 - lam2)
995  abv3 = abv1 - lam3
996 
997  abv4 = gm1 * (alphaavg * dr - uavg * dru - vavg * drv &
998  - wavg * drw + dre) - gm53 * drk
999  abv5 = sx * dru + sy * drv + sz * drw - unavg * dr
1000 
1001  abv6 = abv3 * abv4 * ova2avg + abv2 * abv5 * ovaavg
1002  abv7 = abv2 * abv4 * ovaavg + abv3 * abv5
1003 
1004  ! Compute and scatter the dissipative flux.
1005  ! Density.
1006 
1007  fs = lam3 * dr + abv6
1008  fw(i, j, k + 1, irho) = fw(i, j, k + 1, irho) + fs
1009  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
1010 #ifndef USE_TAPENADE
1011  ind = indfamilyk(i, j, k)
1012  massflowfamilydiss(ind, spectralsol) = &
1013  massflowfamilydiss(ind, spectralsol) &
1014  - factfamilyk(i, j, k) * fs
1015 #endif
1016  ! X-momentum.
1017 
1018  fs = lam3 * dru + uavg * abv6 + sx * abv7
1019  fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) + fs
1020  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
1021 
1022  ! Y-momentum.
1023 
1024  fs = lam3 * drv + vavg * abv6 + sy * abv7
1025  fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) + fs
1026  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
1027 
1028  ! Z-momentum.
1029 
1030  fs = lam3 * drw + wavg * abv6 + sz * abv7
1031  fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) + fs
1032  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
1033 
1034  ! Energy.
1035 
1036  fs = lam3 * dre + havg * abv6 + unavg * abv7
1037  fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) + fs
1038  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
1039 
1040 #ifdef TAPENADE_REVERSE
1041  end do
1042 #else
1043  end do
1044  end do
1045  end do
1046 #endif
1047  end subroutine invisciddissfluxmatrix
1048 
1049  subroutine invisciddissfluxscalar
1050  !
1051  ! inviscidDissFluxScalar computes the scalar artificial
1052  ! dissipation, see AIAA paper 81-1259, for a given block.
1053  ! Therefore it is assumed that the pointers in blockPointers
1054  ! already point to the correct block.
1055  !
1056  use constants
1057  use blockpointers, only: nx, ny, nz, il, jl, kl, ie, je, ke, ib, jb, kb, &
1058  w, p, pori, porj, pork, fw, radi, radj, radk, gamma
1059  use flowvarrefstate, only: gammainf, pinfcorr, rhoinf
1060  use inputdiscretization, only: vis2, vis4
1061  use inputiteration, only: usedisscontinuation, disscontmagnitude, disscontmidpoint, disscontsharpness
1062  use inputphysics, only: equations
1063  use iteration, only: rfil, totalr0, totalr
1064  use utils, only: mydim
1065  implicit none
1066  !
1067  ! Local parameter.
1068  !
1069  real(kind=realtype), parameter :: dssmax = 0.25_realtype
1070  !
1071  ! Local variables.
1072  !
1073  integer(kind=intType) :: i, j, k, ind, ii
1074 
1075  real(kind=realtype) :: sslim, rhoi
1076  real(kind=realtype) :: sfil, fis2, fis4
1077  real(kind=realtype) :: ppor, rrad, dis2, dis4
1078  real(kind=realtype) :: ddw1, ddw2, ddw3, ddw4, ddw5, fs
1079  real(kind=realtype), dimension(1:ie, 1:je, 1:ke, 3) :: dss
1080  real(kind=realtype), dimension(0:ib, 0:jb, 0:kb) :: ss
1081 
1082  ! Check if rFil == 0. If so, the dissipative flux needs not to
1083  ! be computed.
1084 
1085  if (abs(rfil) < thresholdreal) return
1086 
1087  ! Determine the variables used to compute the switch.
1088  ! For the inviscid case this is the pressure; for the viscous
1089  ! case it is the entropy.
1090 
1091  select case (equations)
1092  case (eulerequations)
1093 
1094  ! Inviscid case. Pressure switch is based on the pressure.
1095  ! Also set the value of sslim. To be fully consistent this
1096  ! must have the dimension of pressure and it is therefore
1097  ! set to a fraction of the free stream value.
1098 
1099  sslim = 0.001_realtype * pinfcorr
1100 
1101  ! Copy the pressure in ss. Only need the entries used in the
1102  ! discretization, i.e. not including the corner halo's, but we'll
1103  ! just copy all anyway.
1104 
1105  ss = p
1106  !===============================================================
1107 
1108  case (nsequations, ransequations)
1109 
1110  ! Viscous case. Pressure switch is based on the entropy.
1111  ! Also set the value of sslim. To be fully consistent this
1112  ! must have the dimension of entropy and it is therefore
1113  ! set to a fraction of the free stream value.
1114 
1115  sslim = 0.001_realtype * pinfcorr / (rhoinf**gammainf)
1116 
1117  ! Store the entropy in ss. See above.
1118 
1119 #ifdef TAPENADE_REVERSE
1120  !$AD II-LOOP
1121  do ii = 0, (ib + 1) * (jb + 1) * (kb + 1) - 1
1122  i = mod(ii, ib + 1)
1123  j = mod(ii / (ib + 1), jb + 1)
1124  k = ii / ((ib + 1) * (jb + 1))
1125 #else
1126  do k = 0, kb
1127  do j = 0, jb
1128  do i = 0, ib
1129 #endif
1130  ss(i, j, k) = p(i, j, k) / (w(i, j, k, irho)**gamma(i, j, k))
1131 #ifdef TAPENADE_REVERSE
1132  end do
1133 #else
1134  end do
1135  end do
1136  end do
1137 #endif
1138  end select
1139 
1140  ! Compute the pressure sensor for each cell, in each direction:
1141 #ifdef TAPENADE_REVERSE
1142  !$AD II-LOOP
1143  do ii = 0, ie * je * ke - 1
1144  i = mod(ii, ie) + 1
1145  j = mod(ii / ie, je) + 1
1146  k = ii / (ie * je) + 1
1147 #else
1148  do k = 1, ke
1149  do j = 1, je
1150  do i = 1, ie
1151 #endif
1152  dss(i, j, k, 1) = abs((ss(i + 1, j, k) - two * ss(i, j, k) + ss(i - 1, j, k)) &
1153  / (ss(i + 1, j, k) + two * ss(i, j, k) + ss(i - 1, j, k) + sslim))
1154 
1155  dss(i, j, k, 2) = abs((ss(i, j + 1, k) - two * ss(i, j, k) + ss(i, j - 1, k)) &
1156  / (ss(i, j + 1, k) + two * ss(i, j, k) + ss(i, j - 1, k) + sslim))
1157 
1158  dss(i, j, k, 3) = abs((ss(i, j, k + 1) - two * ss(i, j, k) + ss(i, j, k - 1)) &
1159  / (ss(i, j, k + 1) + two * ss(i, j, k) + ss(i, j, k - 1) + sslim))
1160 #ifdef TAPENADE_REVERSE
1161  end do
1162 #else
1163  end do
1164  end do
1165  end do
1166 #endif
1167 
1168  ! Set the dissipation constants for the scheme.
1169  ! rFil and sFil are fractions used by the Runge-Kutta solver to compute residuals at intermediate steps.
1170  ! This means that fis2 and fis4 will be some fraction of vis2 and vis4, respectively.
1171  ! For other solvers, rFil==1, sFil==0, fis2==vis2, and fis4==vis4.
1172 
1173  ! The sigmoid function used for dissipation-based continuation is described in Eq. 28 and Eq. 29 from the paper:
1174  ! "Improving the Performance of a Compressible RANS Solver for Low and High Mach Number Flows" (Seraj2022c).
1175  ! The options documentation also has information on the parameters in this formulation.
1176  if (usedisscontinuation) then
1177  if (totalr == zero .or. totalr0 == zero) then
1178  fis2 = rfil * (vis2 + disscontmagnitude / (1 + exp(-disscontsharpness * disscontmidpoint)))
1179  else
1180  fis2 = rfil * (vis2 + disscontmagnitude / &
1181  (1 + exp(-disscontsharpness * (log10(totalr / totalr0) + disscontmidpoint))))
1182  end if
1183  else
1184  fis2 = rfil * vis2
1185  end if
1186  fis4 = rfil * vis4
1187  sfil = one - rfil
1188 
1189  ! Initialize the dissipative residual to a certain times,
1190  ! possibly zero, the previously stored value. Owned cells
1191  ! only, because the halo values do not matter.
1192 
1193  fw = sfil * fw
1194  !
1195  ! Dissipative fluxes in the i-direction.
1196  !
1197 #ifdef TAPENADE_REVERSE
1198  !$AD II-LOOP
1199  do ii = 0, il * ny * nz - 1
1200  i = mod(ii, il) + 1
1201  j = mod(ii / il, ny) + 2
1202  k = ii / (il * ny) + 2
1203 #else
1204  do k = 2, kl
1205  do j = 2, jl
1206  do i = 1, il
1207 #endif
1208  ! Compute the dissipation coefficients for this face.
1209 
1210  ppor = zero
1211  if (pori(i, j, k) == normalflux) ppor = half
1212  rrad = ppor * (radi(i, j, k) + radi(i + 1, j, k))
1213 
1214  dis2 = fis2 * rrad * min(dssmax, max(dss(i, j, k, 1), dss(i + 1, j, k, 1)))
1215  dis4 = mydim(fis4 * rrad, dis2)
1216 
1217  ! Compute and scatter the dissipative flux.
1218  ! Density. Store it in the mass flow of the
1219  ! appropriate sliding mesh interface.
1220 
1221  ddw1 = w(i + 1, j, k, irho) - w(i, j, k, irho)
1222  fs = dis2 * ddw1 &
1223  - dis4 * (w(i + 2, j, k, irho) - w(i - 1, j, k, irho) - three * ddw1)
1224 
1225  fw(i + 1, j, k, irho) = fw(i + 1, j, k, irho) + fs
1226  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
1227 
1228  ! X-momentum.
1229 
1230  ddw2 = w(i + 1, j, k, ivx) * w(i + 1, j, k, irho) - w(i, j, k, ivx) * w(i, j, k, irho)
1231  fs = dis2 * ddw2 &
1232  - dis4 * (w(i + 2, j, k, ivx) * w(i + 2, j, k, irho) - &
1233  w(i - 1, j, k, ivx) * w(i - 1, j, k, irho) - three * ddw2)
1234 
1235  fw(i + 1, j, k, imx) = fw(i + 1, j, k, imx) + fs
1236  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
1237 
1238  ! Y-momentum.
1239 
1240  ddw3 = w(i + 1, j, k, ivy) * w(i + 1, j, k, irho) - w(i, j, k, ivy) * w(i, j, k, irho)
1241  fs = dis2 * ddw3 &
1242  - dis4 * (w(i + 2, j, k, ivy) * w(i + 2, j, k, irho) - &
1243  w(i - 1, j, k, ivy) * w(i - 1, j, k, irho) - three * ddw3)
1244 
1245  fw(i + 1, j, k, imy) = fw(i + 1, j, k, imy) + fs
1246  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
1247 
1248  ! Z-momentum.
1249 
1250  ddw4 = w(i + 1, j, k, ivz) * w(i + 1, j, k, irho) - w(i, j, k, ivz) * w(i, j, k, irho)
1251  fs = dis2 * ddw4 &
1252  - dis4 * (w(i + 2, j, k, ivz) * w(i + 2, j, k, irho) - &
1253  w(i - 1, j, k, ivz) * w(i - 1, j, k, irho) - three * ddw4)
1254 
1255  fw(i + 1, j, k, imz) = fw(i + 1, j, k, imz) + fs
1256  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
1257 
1258  ! Energy.
1259 
1260  ddw5 = (w(i + 1, j, k, irhoe) + p(i + 1, j, k)) - (w(i, j, k, irhoe) + p(i, j, k))
1261  fs = dis2 * ddw5 &
1262  - dis4 * ((w(i + 2, j, k, irhoe) + p(i + 2, j, k)) - &
1263  (w(i - 1, j, k, irhoe) + p(i - 1, j, k)) - three * ddw5)
1264 
1265  fw(i + 1, j, k, irhoe) = fw(i + 1, j, k, irhoe) + fs
1266  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
1267 #ifdef TAPENADE_REVERSE
1268  end do
1269 #else
1270  end do
1271  end do
1272  end do
1273 #endif
1274 
1275  !
1276  ! Dissipative fluxes in the j-direction.
1277  !
1278 #ifdef TAPENADE_REVERSE
1279  !$AD II-LOOP
1280  do ii = 0, nx * jl * nz - 1
1281  i = mod(ii, nx) + 2
1282  j = mod(ii / nx, jl) + 1
1283  k = ii / (nx * jl) + 2
1284 #else
1285  do k = 2, kl
1286  do j = 1, jl
1287  do i = 2, il
1288 #endif
1289  ! Compute the dissipation coefficients for this face.
1290 
1291  ppor = zero
1292  if (porj(i, j, k) == normalflux) ppor = half
1293  rrad = ppor * (radj(i, j, k) + radj(i, j + 1, k))
1294 
1295  dis2 = fis2 * rrad * min(dssmax, max(dss(i, j, k, 2), dss(i, j + 1, k, 2)))
1296  dis4 = mydim(fis4 * rrad, dis2)
1297 
1298  ! Compute and scatter the dissipative flux.
1299  ! Density. Store it in the mass flow of the
1300  ! appropriate sliding mesh interface.
1301 
1302  ddw1 = w(i, j + 1, k, irho) - w(i, j, k, irho)
1303  fs = dis2 * ddw1 &
1304  - dis4 * (w(i, j + 2, k, irho) - w(i, j - 1, k, irho) - three * ddw1)
1305 
1306  fw(i, j + 1, k, irho) = fw(i, j + 1, k, irho) + fs
1307  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
1308 
1309  ! X-momentum.
1310 
1311  ddw2 = w(i, j + 1, k, ivx) * w(i, j + 1, k, irho) - w(i, j, k, ivx) * w(i, j, k, irho)
1312  fs = dis2 * ddw2 &
1313  - dis4 * (w(i, j + 2, k, ivx) * w(i, j + 2, k, irho) - &
1314  w(i, j - 1, k, ivx) * w(i, j - 1, k, irho) - three * ddw2)
1315 
1316  fw(i, j + 1, k, imx) = fw(i, j + 1, k, imx) + fs
1317  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
1318 
1319  ! Y-momentum.
1320 
1321  ddw3 = w(i, j + 1, k, ivy) * w(i, j + 1, k, irho) - w(i, j, k, ivy) * w(i, j, k, irho)
1322  fs = dis2 * ddw3 &
1323  - dis4 * (w(i, j + 2, k, ivy) * w(i, j + 2, k, irho) - &
1324  w(i, j - 1, k, ivy) * w(i, j - 1, k, irho) - three * ddw3)
1325 
1326  fw(i, j + 1, k, imy) = fw(i, j + 1, k, imy) + fs
1327  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
1328 
1329  ! Z-momentum.
1330 
1331  ddw4 = w(i, j + 1, k, ivz) * w(i, j + 1, k, irho) - w(i, j, k, ivz) * w(i, j, k, irho)
1332  fs = dis2 * ddw4 &
1333  - dis4 * (w(i, j + 2, k, ivz) * w(i, j + 2, k, irho) - &
1334  w(i, j - 1, k, ivz) * w(i, j - 1, k, irho) - three * ddw4)
1335 
1336  fw(i, j + 1, k, imz) = fw(i, j + 1, k, imz) + fs
1337  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
1338 
1339  ! Energy.
1340 
1341  ddw5 = (w(i, j + 1, k, irhoe) + p(i, j + 1, k)) - (w(i, j, k, irhoe) + p(i, j, k))
1342  fs = dis2 * ddw5 &
1343  - dis4 * ((w(i, j + 2, k, irhoe) + p(i, j + 2, k)) - &
1344  (w(i, j - 1, k, irhoe) + p(i, j - 1, k)) - three * ddw5)
1345 
1346  fw(i, j + 1, k, irhoe) = fw(i, j + 1, k, irhoe) + fs
1347  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
1348 #ifdef TAPENADE_REVERSE
1349  end do
1350 #else
1351  end do
1352  end do
1353  end do
1354 #endif
1355  !
1356  ! Dissipative fluxes in the k-direction.
1357  !
1358 #ifdef TAPENADE_REVERSE
1359  !$AD II-LOOP
1360  do ii = 0, nx * ny * kl - 1
1361  i = mod(ii, nx) + 2
1362  j = mod(ii / nx, ny) + 2
1363  k = ii / (nx * ny) + 1
1364 #else
1365  do k = 1, kl
1366  do j = 2, jl
1367  do i = 2, il
1368 #endif
1369  ! Compute the dissipation coefficients for this face.
1370 
1371  ppor = zero
1372  if (pork(i, j, k) == normalflux) ppor = half
1373  rrad = ppor * (radk(i, j, k) + radk(i, j, k + 1))
1374 
1375  dis2 = fis2 * rrad * min(dssmax, max(dss(i, j, k, 3), dss(i, j, k + 1, 3)))
1376  dis4 = mydim(fis4 * rrad, dis2)
1377 
1378  ! Compute and scatter the dissipative flux.
1379  ! Density. Store it in the mass flow of the
1380  ! appropriate sliding mesh interface.
1381 
1382  ddw1 = w(i, j, k + 1, irho) - w(i, j, k, irho)
1383  fs = dis2 * ddw1 &
1384  - dis4 * (w(i, j, k + 2, irho) - w(i, j, k - 1, irho) - three * ddw1)
1385 
1386  fw(i, j, k + 1, irho) = fw(i, j, k + 1, irho) + fs
1387  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
1388 
1389  ! X-momentum.
1390 
1391  ddw2 = w(i, j, k + 1, ivx) * w(i, j, k + 1, irho) - w(i, j, k, ivx) * w(i, j, k, irho)
1392  fs = dis2 * ddw2 &
1393  - dis4 * (w(i, j, k + 2, ivx) * w(i, j, k + 2, irho) - &
1394  w(i, j, k - 1, ivx) * w(i, j, k - 1, irho) - three * ddw2)
1395 
1396  fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) + fs
1397  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
1398 
1399  ! Y-momentum.
1400 
1401  ddw3 = w(i, j, k + 1, ivy) * w(i, j, k + 1, irho) - w(i, j, k, ivy) * w(i, j, k, irho)
1402  fs = dis2 * ddw3 &
1403  - dis4 * (w(i, j, k + 2, ivy) * w(i, j, k + 2, irho) - &
1404  w(i, j, k - 1, ivy) * w(i, j, k - 1, irho) - three * ddw3)
1405 
1406  fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) + fs
1407  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
1408 
1409  ! Z-momentum.
1410 
1411  ddw4 = w(i, j, k + 1, ivz) * w(i, j, k + 1, irho) - w(i, j, k, ivz) * w(i, j, k, irho)
1412  fs = dis2 * ddw4 &
1413  - dis4 * (w(i, j, k + 2, ivz) * w(i, j, k + 2, irho) - &
1414  w(i, j, k - 1, ivz) * w(i, j, k - 1, irho) - three * ddw4)
1415 
1416  fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) + fs
1417  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
1418 
1419  ! Energy.
1420 
1421  ddw5 = (w(i, j, k + 1, irhoe) + p(i, j, k + 1)) - (w(i, j, k, irhoe) + p(i, j, k))
1422  fs = dis2 * ddw5 &
1423  - dis4 * ((w(i, j, k + 2, irhoe) + p(i, j, k + 2)) - &
1424  (w(i, j, k - 1, irhoe) + p(i, j, k - 1)) - three * ddw5)
1425 
1426  fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) + fs
1427  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
1428 
1429 #ifdef TAPENADE_REVERSE
1430  end do
1431 #else
1432  end do
1433  end do
1434  end do
1435 #endif
1436  end subroutine invisciddissfluxscalar
1437 
1438  subroutine inviscidupwindflux(fineGrid)
1439  !
1440  ! inviscidUpwindFlux computes the artificial dissipation part of
1441  ! the Euler fluxes by means of an approximate solution of the 1D
1442  ! Riemann problem on the face. For first order schemes,
1443  ! fineGrid == .false., the states in the cells are assumed to
1444  ! be constant; for the second order schemes on the fine grid a
1445  ! nonlinear reconstruction of the left and right state is done
1446  ! for which several options exist.
1447  ! It is assumed that the pointers in blockPointers already
1448  ! point to the correct block.
1449  !
1450  use constants
1451  use blockpointers, only: il, jl, kl, ie, je, ke, ib, jb, kb, w, p, &
1452  pori, porj, pork, fw, gamma, si, sj, sk, &
1453  indfamilyi, indfamilyj, indfamilyk, spectralsol, addgridvelocities, &
1454  sfacei, sfacej, sfacek, rotmatrixi, rotmatrixj, rotmatrixk, &
1455  factfamilyi, factfamilyj, factfamilyk
1456  use flowvarrefstate, only: kpresent, nw, nwf, rgas, tref
1457  use inputdiscretization, only: limiter, lumpeddiss, precond, riemann, &
1458  riemanncoarse, orderturb, kappacoef
1459  use inputphysics, only: equations
1460  use iteration, only: rfil, currentlevel, groundlevel
1461  use cgnsgrid, only: massflowfamilydiss
1462  use utils, only: getcorrectfork, terminate
1463  use flowutils, only: etot
1464  implicit none
1465  !
1466  ! Subroutine arguments.
1467  !
1468  logical, intent(in) :: fineGrid
1469  !
1470  ! Local variables.
1471  !
1472  integer(kind=porType) :: por
1473 
1474  integer(kind=intType) :: nwInt
1475  integer(kind=intType) :: i, j, k, ind
1476  integer(kind=intType) :: limUsed, riemannUsed
1477 
1478  real(kind=realtype) :: sx, sy, sz, omk, opk, sfil, gammaface
1479  real(kind=realtype) :: factminmod, sface
1480 
1481  real(kind=realtype), dimension(nw) :: left, right
1482  real(kind=realtype), dimension(nw) :: du1, du2, du3
1483  real(kind=realtype), dimension(nwf) :: flux
1484 
1485  logical :: firstOrderK, correctForK, rotationalPeriodic
1486  !
1487  ! Check if rFil == 0. If so, the dissipative flux needs not to
1488  ! be computed.
1489 
1490  if (abs(rfil) < thresholdreal) return
1491 
1492  ! Check if the formulation for rotational periodic problems
1493  ! must be used.
1494 
1495  if (associated(rotmatrixi)) then
1496  rotationalperiodic = .true.
1497  else
1498  rotationalperiodic = .false.
1499  end if
1500 
1501  ! Initialize the dissipative residual to a certain times,
1502  ! possibly zero, the previously stored value. Owned cells
1503  ! only, because the halo values do not matter.
1504 
1505  sfil = one - rfil
1506 
1507  do k = 2, kl
1508  do j = 2, jl
1509  do i = 2, il
1510  fw(i, j, k, irho) = sfil * fw(i, j, k, irho)
1511  fw(i, j, k, imx) = sfil * fw(i, j, k, imx)
1512  fw(i, j, k, imy) = sfil * fw(i, j, k, imy)
1513  fw(i, j, k, imz) = sfil * fw(i, j, k, imz)
1514  fw(i, j, k, irhoe) = sfil * fw(i, j, k, irhoe)
1515  end do
1516  end do
1517  end do
1518 
1519  ! Determine whether or not the total energy must be corrected
1520  ! for the presence of the turbulent kinetic energy.
1521  correctfork = getcorrectfork()
1522 
1523  ! Compute the factor used in the minmod limiter.
1524 
1525  factminmod = (three - kappacoef) &
1526  / max(1.e-10_realtype, one - kappacoef)
1527 
1528  ! Determine the limiter scheme to be used. On the fine grid the
1529  ! user specified scheme is used; on the coarse grid a first order
1530  ! scheme is computed.
1531 
1532  limused = firstorder
1533  if (finegrid) limused = limiter
1534 
1535  ! Lumped diss is true for doing approx PC
1536  if (lumpeddiss) then
1537  limused = firstorder
1538  end if
1539 
1540  ! Determine the riemann solver which must be used.
1541 
1542  riemannused = riemanncoarse
1543  if (finegrid) riemannused = riemann
1544 
1545  ! Store 1-kappa and 1+kappa a bit easier and multiply it by 0.25.
1546 
1547  omk = fourth * (one - kappacoef)
1548  opk = fourth * (one + kappacoef)
1549 
1550  ! Initialize sFace to zero. This value will be used if the
1551  ! block is not moving.
1552 
1553  sface = zero
1554 
1555  ! Set the number of variables to be interpolated depending
1556  ! whether or not a k-equation is present. If a k-equation is
1557  ! present also set the logical firstOrderK. This indicates
1558  ! whether or not only a first order approximation is to be used
1559  ! for the turbulent kinetic energy.
1560 
1561  if (correctfork) then
1562  if (orderturb == firstorder) then
1563  nwint = nwf
1564  firstorderk = .true.
1565  else
1566  nwint = itu1
1567  firstorderk = .false.
1568  end if
1569  else
1570  nwint = nwf
1571  firstorderk = .false.
1572  end if
1573  !
1574  ! Flux computation. A distinction is made between first and
1575  ! second order schemes to avoid the overhead for the first order
1576  ! scheme.
1577  !
1578  ordertest: if (limused == firstorder) then
1579  !
1580  ! First order reconstruction. The states in the cells are
1581  ! constant. The left and right states are constructed easily.
1582  !
1583  ! Fluxes in the i-direction.
1584 
1585  do k = 2, kl
1586  do j = 2, jl
1587  do i = 1, il
1588 
1589  ! Store the normal vector, the porosity and the
1590  ! mesh velocity if present.
1591 
1592  sx = si(i, j, k, 1); sy = si(i, j, k, 2); sz = si(i, j, k, 3)
1593  por = pori(i, j, k)
1594  if (addgridvelocities) sface = sfacei(i, j, k)
1595 
1596  ! Determine the left and right state.
1597 
1598  left(irho) = w(i, j, k, irho)
1599  left(ivx) = w(i, j, k, ivx)
1600  left(ivy) = w(i, j, k, ivy)
1601  left(ivz) = w(i, j, k, ivz)
1602  left(irhoe) = p(i, j, k)
1603  if (correctfork) left(itu1) = w(i, j, k, itu1)
1604 
1605  right(irho) = w(i + 1, j, k, irho)
1606  right(ivx) = w(i + 1, j, k, ivx)
1607  right(ivy) = w(i + 1, j, k, ivy)
1608  right(ivz) = w(i + 1, j, k, ivz)
1609  right(irhoe) = p(i + 1, j, k)
1610  if (correctfork) right(itu1) = w(i + 1, j, k, itu1)
1611 
1612  ! Compute the value of gamma on the face. Take an
1613  ! arithmetic average of the two states.
1614 
1615  gammaface = half * (gamma(i, j, k) + gamma(i + 1, j, k))
1616 
1617  ! Compute the dissipative flux across the interface.
1618 
1619  call riemannflux(left, right, flux)
1620 
1621  ! And scatter it to the left and right.
1622 
1623  fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
1624  fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
1625  fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
1626  fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
1627  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
1628 
1629  fw(i + 1, j, k, irho) = fw(i + 1, j, k, irho) - flux(irho)
1630  fw(i + 1, j, k, imx) = fw(i + 1, j, k, imx) - flux(imx)
1631  fw(i + 1, j, k, imy) = fw(i + 1, j, k, imy) - flux(imy)
1632  fw(i + 1, j, k, imz) = fw(i + 1, j, k, imz) - flux(imz)
1633  fw(i + 1, j, k, irhoe) = fw(i + 1, j, k, irhoe) - flux(irhoe)
1634 
1635  ! Store the density flux in the mass flow of the
1636  ! appropriate sliding mesh interface.
1637 #ifndef USE_TAPENADE
1638  ind = indfamilyi(i, j, k)
1639  massflowfamilydiss(ind, spectralsol) = &
1640  massflowfamilydiss(ind, spectralsol) &
1641  + factfamilyi(i, j, k) * flux(irho)
1642 #endif
1643  end do
1644  end do
1645  end do
1646 
1647  ! Fluxes in j-direction.
1648 
1649  do k = 2, kl
1650  do j = 1, jl
1651  do i = 2, il
1652 
1653  ! Store the normal vector, the porosity and the
1654  ! mesh velocity if present.
1655 
1656  sx = sj(i, j, k, 1); sy = sj(i, j, k, 2); sz = sj(i, j, k, 3)
1657  por = porj(i, j, k)
1658  if (addgridvelocities) sface = sfacej(i, j, k)
1659 
1660  ! Determine the left and right state.
1661 
1662  left(irho) = w(i, j, k, irho)
1663  left(ivx) = w(i, j, k, ivx)
1664  left(ivy) = w(i, j, k, ivy)
1665  left(ivz) = w(i, j, k, ivz)
1666  left(irhoe) = p(i, j, k)
1667  if (correctfork) left(itu1) = w(i, j, k, itu1)
1668 
1669  right(irho) = w(i, j + 1, k, irho)
1670  right(ivx) = w(i, j + 1, k, ivx)
1671  right(ivy) = w(i, j + 1, k, ivy)
1672  right(ivz) = w(i, j + 1, k, ivz)
1673  right(irhoe) = p(i, j + 1, k)
1674  if (correctfork) right(itu1) = w(i, j + 1, k, itu1)
1675 
1676  ! Compute the value of gamma on the face. Take an
1677  ! arithmetic average of the two states.
1678 
1679  gammaface = half * (gamma(i, j, k) + gamma(i, j + 1, k))
1680 
1681  ! Compute the dissipative flux across the interface.
1682 
1683  call riemannflux(left, right, flux)
1684 
1685  ! And scatter it to the left and right.
1686 
1687  fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
1688  fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
1689  fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
1690  fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
1691  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
1692 
1693  fw(i, j + 1, k, irho) = fw(i, j + 1, k, irho) - flux(irho)
1694  fw(i, j + 1, k, imx) = fw(i, j + 1, k, imx) - flux(imx)
1695  fw(i, j + 1, k, imy) = fw(i, j + 1, k, imy) - flux(imy)
1696  fw(i, j + 1, k, imz) = fw(i, j + 1, k, imz) - flux(imz)
1697  fw(i, j + 1, k, irhoe) = fw(i, j + 1, k, irhoe) - flux(irhoe)
1698 
1699  ! Store the density flux in the mass flow of the
1700  ! appropriate sliding mesh interface.
1701 #ifndef USE_TAPENADE
1702  ind = indfamilyj(i, j, k)
1703  massflowfamilydiss(ind, spectralsol) = &
1704  massflowfamilydiss(ind, spectralsol) &
1705  + factfamilyj(i, j, k) * flux(irho)
1706 #endif
1707  end do
1708  end do
1709  end do
1710 
1711  ! Fluxes in k-direction.
1712 
1713  do k = 1, kl
1714  do j = 2, jl
1715  do i = 2, il
1716 
1717  ! Store the normal vector, the porosity and the
1718  ! mesh velocity if present.
1719 
1720  sx = sk(i, j, k, 1); sy = sk(i, j, k, 2); sz = sk(i, j, k, 3)
1721  por = pork(i, j, k)
1722  if (addgridvelocities) sface = sfacek(i, j, k)
1723 
1724  ! Determine the left and right state.
1725 
1726  left(irho) = w(i, j, k, irho)
1727  left(ivx) = w(i, j, k, ivx)
1728  left(ivy) = w(i, j, k, ivy)
1729  left(ivz) = w(i, j, k, ivz)
1730  left(irhoe) = p(i, j, k)
1731  if (correctfork) left(itu1) = w(i, j, k, itu1)
1732 
1733  right(irho) = w(i, j, k + 1, irho)
1734  right(ivx) = w(i, j, k + 1, ivx)
1735  right(ivy) = w(i, j, k + 1, ivy)
1736  right(ivz) = w(i, j, k + 1, ivz)
1737  right(irhoe) = p(i, j, k + 1)
1738  if (correctfork) right(itu1) = w(i, j, k + 1, itu1)
1739 
1740  ! Compute the value of gamma on the face. Take an
1741  ! arithmetic average of the two states.
1742 
1743  gammaface = half * (gamma(i, j, k) + gamma(i, j, k + 1))
1744 
1745  ! Compute the dissipative flux across the interface.
1746 
1747  call riemannflux(left, right, flux)
1748 
1749  ! And scatter it the left and right.
1750 
1751  fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
1752  fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
1753  fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
1754  fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
1755  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
1756 
1757  fw(i, j, k + 1, irho) = fw(i, j, k + 1, irho) - flux(irho)
1758  fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) - flux(imx)
1759  fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) - flux(imy)
1760  fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) - flux(imz)
1761  fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) - flux(irhoe)
1762 
1763  ! Store the density flux in the mass flow of the
1764  ! appropriate sliding mesh interface.
1765 #ifndef USE_TAPENADE
1766  ind = indfamilyk(i, j, k)
1767  massflowfamilydiss(ind, spectralsol) = &
1768  massflowfamilydiss(ind, spectralsol) &
1769  + factfamilyk(i, j, k) * flux(irho)
1770 #endif
1771  end do
1772  end do
1773  end do
1774 
1775  ! ==================================================================
1776 
1777  else ordertest
1778 
1779  ! ==================================================================
1780  !
1781  ! Second order reconstruction of the left and right state.
1782  ! The three differences used in the, possibly nonlinear,
1783  ! interpolation are constructed here; the actual left and
1784  ! right states, or at least the differences from the first
1785  ! order interpolation, are computed in the subroutine
1786  ! leftRightState.
1787  !
1788  ! Fluxes in the i-direction.
1789 
1790  do k = 2, kl
1791  do j = 2, jl
1792  do i = 1, il
1793 
1794  ! Store the three differences used in the interpolation
1795  ! in du1, du2, du3.
1796 
1797  du1(irho) = w(i, j, k, irho) - w(i - 1, j, k, irho)
1798  du2(irho) = w(i + 1, j, k, irho) - w(i, j, k, irho)
1799  du3(irho) = w(i + 2, j, k, irho) - w(i + 1, j, k, irho)
1800 
1801  du1(ivx) = w(i, j, k, ivx) - w(i - 1, j, k, ivx)
1802  du2(ivx) = w(i + 1, j, k, ivx) - w(i, j, k, ivx)
1803  du3(ivx) = w(i + 2, j, k, ivx) - w(i + 1, j, k, ivx)
1804 
1805  du1(ivy) = w(i, j, k, ivy) - w(i - 1, j, k, ivy)
1806  du2(ivy) = w(i + 1, j, k, ivy) - w(i, j, k, ivy)
1807  du3(ivy) = w(i + 2, j, k, ivy) - w(i + 1, j, k, ivy)
1808 
1809  du1(ivz) = w(i, j, k, ivz) - w(i - 1, j, k, ivz)
1810  du2(ivz) = w(i + 1, j, k, ivz) - w(i, j, k, ivz)
1811  du3(ivz) = w(i + 2, j, k, ivz) - w(i + 1, j, k, ivz)
1812 
1813  du1(irhoe) = p(i, j, k) - p(i - 1, j, k)
1814  du2(irhoe) = p(i + 1, j, k) - p(i, j, k)
1815  du3(irhoe) = p(i + 2, j, k) - p(i + 1, j, k)
1816 
1817  if (correctfork) then
1818  du1(itu1) = w(i, j, k, itu1) - w(i - 1, j, k, itu1)
1819  du2(itu1) = w(i + 1, j, k, itu1) - w(i, j, k, itu1)
1820  du3(itu1) = w(i + 2, j, k, itu1) - w(i + 1, j, k, itu1)
1821  end if
1822 
1823  ! Compute the differences from the first order scheme.
1824 
1825  call leftrightstate(du1, du2, du3, rotmatrixi, &
1826  left, right)
1827 
1828  ! Add the first order part to the currently stored
1829  ! differences, such that the correct state vector
1830  ! is stored.
1831 
1832  left(irho) = left(irho) + w(i, j, k, irho)
1833  left(ivx) = left(ivx) + w(i, j, k, ivx)
1834  left(ivy) = left(ivy) + w(i, j, k, ivy)
1835  left(ivz) = left(ivz) + w(i, j, k, ivz)
1836  left(irhoe) = left(irhoe) + p(i, j, k)
1837 
1838  right(irho) = right(irho) + w(i + 1, j, k, irho)
1839  right(ivx) = right(ivx) + w(i + 1, j, k, ivx)
1840  right(ivy) = right(ivy) + w(i + 1, j, k, ivy)
1841  right(ivz) = right(ivz) + w(i + 1, j, k, ivz)
1842  right(irhoe) = right(irhoe) + p(i + 1, j, k)
1843 
1844  if (correctfork) then
1845  left(itu1) = left(itu1) + w(i, j, k, itu1)
1846  right(itu1) = right(itu1) + w(i + 1, j, k, itu1)
1847  end if
1848 
1849  ! Store the normal vector, the porosity and the
1850  ! mesh velocity if present.
1851 
1852  sx = si(i, j, k, 1); sy = si(i, j, k, 2); sz = si(i, j, k, 3)
1853  por = pori(i, j, k)
1854  if (addgridvelocities) sface = sfacei(i, j, k)
1855 
1856  ! Compute the value of gamma on the face. Take an
1857  ! arithmetic average of the two states.
1858 
1859  gammaface = half * (gamma(i, j, k) + gamma(i + 1, j, k))
1860 
1861  ! Compute the dissipative flux across the interface.
1862 
1863  call riemannflux(left, right, flux)
1864 
1865  ! And scatter it to the left and right.
1866 
1867  fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
1868  fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
1869  fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
1870  fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
1871  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
1872 
1873  fw(i + 1, j, k, irho) = fw(i + 1, j, k, irho) - flux(irho)
1874  fw(i + 1, j, k, imx) = fw(i + 1, j, k, imx) - flux(imx)
1875  fw(i + 1, j, k, imy) = fw(i + 1, j, k, imy) - flux(imy)
1876  fw(i + 1, j, k, imz) = fw(i + 1, j, k, imz) - flux(imz)
1877  fw(i + 1, j, k, irhoe) = fw(i + 1, j, k, irhoe) - flux(irhoe)
1878 
1879  ! Store the density flux in the mass flow of the
1880  ! appropriate sliding mesh interface.
1881 #ifndef USE_TAPENADE
1882  ind = indfamilyi(i, j, k)
1883  massflowfamilydiss(ind, spectralsol) = &
1884  massflowfamilydiss(ind, spectralsol) &
1885  + factfamilyi(i, j, k) * flux(irho)
1886 #endif
1887  end do
1888  end do
1889  end do
1890 
1891  ! Fluxes in the j-direction.
1892 
1893  do k = 2, kl
1894  do j = 1, jl
1895  do i = 2, il
1896 
1897  ! Store the three differences used in the interpolation
1898  ! in du1, du2, du3.
1899 
1900  du1(irho) = w(i, j, k, irho) - w(i, j - 1, k, irho)
1901  du2(irho) = w(i, j + 1, k, irho) - w(i, j, k, irho)
1902  du3(irho) = w(i, j + 2, k, irho) - w(i, j + 1, k, irho)
1903 
1904  du1(ivx) = w(i, j, k, ivx) - w(i, j - 1, k, ivx)
1905  du2(ivx) = w(i, j + 1, k, ivx) - w(i, j, k, ivx)
1906  du3(ivx) = w(i, j + 2, k, ivx) - w(i, j + 1, k, ivx)
1907 
1908  du1(ivy) = w(i, j, k, ivy) - w(i, j - 1, k, ivy)
1909  du2(ivy) = w(i, j + 1, k, ivy) - w(i, j, k, ivy)
1910  du3(ivy) = w(i, j + 2, k, ivy) - w(i, j + 1, k, ivy)
1911 
1912  du1(ivz) = w(i, j, k, ivz) - w(i, j - 1, k, ivz)
1913  du2(ivz) = w(i, j + 1, k, ivz) - w(i, j, k, ivz)
1914  du3(ivz) = w(i, j + 2, k, ivz) - w(i, j + 1, k, ivz)
1915 
1916  du1(irhoe) = p(i, j, k) - p(i, j - 1, k)
1917  du2(irhoe) = p(i, j + 1, k) - p(i, j, k)
1918  du3(irhoe) = p(i, j + 2, k) - p(i, j + 1, k)
1919 
1920  if (correctfork) then
1921  du1(itu1) = w(i, j, k, itu1) - w(i, j - 1, k, itu1)
1922  du2(itu1) = w(i, j + 1, k, itu1) - w(i, j, k, itu1)
1923  du3(itu1) = w(i, j + 2, k, itu1) - w(i, j + 1, k, itu1)
1924  end if
1925 
1926  ! Compute the differences from the first order scheme.
1927 
1928  call leftrightstate(du1, du2, du3, rotmatrixj, &
1929  left, right)
1930 
1931  ! Add the first order part to the currently stored
1932  ! differences, such that the correct state vector
1933  ! is stored.
1934 
1935  left(irho) = left(irho) + w(i, j, k, irho)
1936  left(ivx) = left(ivx) + w(i, j, k, ivx)
1937  left(ivy) = left(ivy) + w(i, j, k, ivy)
1938  left(ivz) = left(ivz) + w(i, j, k, ivz)
1939  left(irhoe) = left(irhoe) + p(i, j, k)
1940 
1941  right(irho) = right(irho) + w(i, j + 1, k, irho)
1942  right(ivx) = right(ivx) + w(i, j + 1, k, ivx)
1943  right(ivy) = right(ivy) + w(i, j + 1, k, ivy)
1944  right(ivz) = right(ivz) + w(i, j + 1, k, ivz)
1945  right(irhoe) = right(irhoe) + p(i, j + 1, k)
1946 
1947  if (correctfork) then
1948  left(itu1) = left(itu1) + w(i, j, k, itu1)
1949  right(itu1) = right(itu1) + w(i, j + 1, k, itu1)
1950  end if
1951 
1952  ! Store the normal vector, the porosity and the
1953  ! mesh velocity if present.
1954 
1955  sx = sj(i, j, k, 1); sy = sj(i, j, k, 2); sz = sj(i, j, k, 3)
1956  por = porj(i, j, k)
1957  if (addgridvelocities) sface = sfacej(i, j, k)
1958 
1959  ! Compute the value of gamma on the face. Take an
1960  ! arithmetic average of the two states.
1961 
1962  gammaface = half * (gamma(i, j, k) + gamma(i, j + 1, k))
1963 
1964  ! Compute the dissipative flux across the interface.
1965 
1966  call riemannflux(left, right, flux)
1967 
1968  ! And scatter it to the left and right.
1969 
1970  fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
1971  fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
1972  fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
1973  fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
1974  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
1975 
1976  fw(i, j + 1, k, irho) = fw(i, j + 1, k, irho) - flux(irho)
1977  fw(i, j + 1, k, imx) = fw(i, j + 1, k, imx) - flux(imx)
1978  fw(i, j + 1, k, imy) = fw(i, j + 1, k, imy) - flux(imy)
1979  fw(i, j + 1, k, imz) = fw(i, j + 1, k, imz) - flux(imz)
1980  fw(i, j + 1, k, irhoe) = fw(i, j + 1, k, irhoe) - flux(irhoe)
1981 
1982  ! Store the density flux in the mass flow of the
1983  ! appropriate sliding mesh interface.
1984 #ifndef USE_TAPENADE
1985  ind = indfamilyj(i, j, k)
1986  massflowfamilydiss(ind, spectralsol) = &
1987  massflowfamilydiss(ind, spectralsol) &
1988  + factfamilyj(i, j, k) * flux(irho)
1989 #endif
1990  end do
1991  end do
1992  end do
1993 
1994  ! Fluxes in the k-direction.
1995 
1996  do k = 1, kl
1997  do j = 2, jl
1998  do i = 2, il
1999 
2000  ! Store the three differences used in the interpolation
2001  ! in du1, du2, du3.
2002 
2003  du1(irho) = w(i, j, k, irho) - w(i, j, k - 1, irho)
2004  du2(irho) = w(i, j, k + 1, irho) - w(i, j, k, irho)
2005  du3(irho) = w(i, j, k + 2, irho) - w(i, j, k + 1, irho)
2006 
2007  du1(ivx) = w(i, j, k, ivx) - w(i, j, k - 1, ivx)
2008  du2(ivx) = w(i, j, k + 1, ivx) - w(i, j, k, ivx)
2009  du3(ivx) = w(i, j, k + 2, ivx) - w(i, j, k + 1, ivx)
2010 
2011  du1(ivy) = w(i, j, k, ivy) - w(i, j, k - 1, ivy)
2012  du2(ivy) = w(i, j, k + 1, ivy) - w(i, j, k, ivy)
2013  du3(ivy) = w(i, j, k + 2, ivy) - w(i, j, k + 1, ivy)
2014 
2015  du1(ivz) = w(i, j, k, ivz) - w(i, j, k - 1, ivz)
2016  du2(ivz) = w(i, j, k + 1, ivz) - w(i, j, k, ivz)
2017  du3(ivz) = w(i, j, k + 2, ivz) - w(i, j, k + 1, ivz)
2018 
2019  du1(irhoe) = p(i, j, k) - p(i, j, k - 1)
2020  du2(irhoe) = p(i, j, k + 1) - p(i, j, k)
2021  du3(irhoe) = p(i, j, k + 2) - p(i, j, k + 1)
2022 
2023  if (correctfork) then
2024  du1(itu1) = w(i, j, k, itu1) - w(i, j, k - 1, itu1)
2025  du2(itu1) = w(i, j, k + 1, itu1) - w(i, j, k, itu1)
2026  du3(itu1) = w(i, j, k + 2, itu1) - w(i, j, k + 1, itu1)
2027  end if
2028 
2029  ! Compute the differences from the first order scheme.
2030 
2031  call leftrightstate(du1, du2, du3, rotmatrixk, &
2032  left, right)
2033 
2034  ! Add the first order part to the currently stored
2035  ! differences, such that the correct state vector
2036  ! is stored.
2037 
2038  left(irho) = left(irho) + w(i, j, k, irho)
2039  left(ivx) = left(ivx) + w(i, j, k, ivx)
2040  left(ivy) = left(ivy) + w(i, j, k, ivy)
2041  left(ivz) = left(ivz) + w(i, j, k, ivz)
2042  left(irhoe) = left(irhoe) + p(i, j, k)
2043 
2044  right(irho) = right(irho) + w(i, j, k + 1, irho)
2045  right(ivx) = right(ivx) + w(i, j, k + 1, ivx)
2046  right(ivy) = right(ivy) + w(i, j, k + 1, ivy)
2047  right(ivz) = right(ivz) + w(i, j, k + 1, ivz)
2048  right(irhoe) = right(irhoe) + p(i, j, k + 1)
2049 
2050  if (correctfork) then
2051  left(itu1) = left(itu1) + w(i, j, k, itu1)
2052  right(itu1) = right(itu1) + w(i, j, k + 1, itu1)
2053  end if
2054 
2055  ! Store the normal vector, the porosity and the
2056  ! mesh velocity if present.
2057 
2058  sx = sk(i, j, k, 1); sy = sk(i, j, k, 2); sz = sk(i, j, k, 3)
2059  por = pork(i, j, k)
2060  if (addgridvelocities) sface = sfacek(i, j, k)
2061 
2062  ! Compute the value of gamma on the face. Take an
2063  ! arithmetic average of the two states.
2064 
2065  gammaface = half * (gamma(i, j, k) + gamma(i, j, k + 1))
2066 
2067  ! Compute the dissipative flux across the interface.
2068 
2069  call riemannflux(left, right, flux)
2070 
2071  ! And scatter it to the left and right.
2072 
2073  fw(i, j, k, irho) = fw(i, j, k, irho) + flux(irho)
2074  fw(i, j, k, imx) = fw(i, j, k, imx) + flux(imx)
2075  fw(i, j, k, imy) = fw(i, j, k, imy) + flux(imy)
2076  fw(i, j, k, imz) = fw(i, j, k, imz) + flux(imz)
2077  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) + flux(irhoe)
2078 
2079  fw(i, j, k + 1, irho) = fw(i, j, k + 1, irho) - flux(irho)
2080  fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) - flux(imx)
2081  fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) - flux(imy)
2082  fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) - flux(imz)
2083  fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) - flux(irhoe)
2084 
2085  ! Store the density flux in the mass flow of the
2086  ! appropriate sliding mesh interface.
2087 #ifndef USE_TAPENADE
2088  ind = indfamilyk(i, j, k)
2089  massflowfamilydiss(ind, spectralsol) = &
2090  massflowfamilydiss(ind, spectralsol) &
2091  + factfamilyk(i, j, k) * flux(irho)
2092 #endif
2093  end do
2094  end do
2095  end do
2096 
2097  end if ordertest
2098 
2099  ! ==================================================================
2100 
2101  contains
2102 
2103  subroutine leftrightstate(du1, du2, du3, rotMatrix, left, right)
2104  !
2105  ! leftRightState computes the differences in the left and
2106  ! right state compared to the first order interpolation. For a
2107  ! monotonic second order discretization the interpolations
2108  ! need to be nonlinear. The linear second order scheme can be
2109  ! stable (depending on the value of kappa), but it will have
2110  ! oscillations near discontinuities.
2111  !
2112  implicit none
2113  !
2114  ! Local parameter.
2115  !
2116  real(kind=realtype), parameter :: epslim = 1.e-10_realtype
2117  !
2118  ! Subroutine arguments.
2119  !
2120  real(kind=realtype), dimension(:), intent(inout) :: du1, du2, du3
2121  real(kind=realtype), dimension(:), intent(out) :: left, right
2122 
2123  real(kind=realtype), dimension(:, :, :, :, :), pointer :: rotmatrix
2124  !
2125  ! Local variables.
2126  !
2127  integer(kind=intType) :: l
2128 
2129  real(kind=realtype) :: rl1, rl2, rr1, rr2, tmp, dvx, dvy, dvz
2130 
2131  real(kind=realtype), dimension(3, 3) :: rot
2132 
2133  ! Check if the velocity components should be transformed to
2134  ! the cylindrical frame.
2135 
2136  if (rotationalperiodic) then
2137 
2138  ! Store the rotation matrix a bit easier. Note that the i,j,k
2139  ! come from the main subroutine.
2140 
2141  rot(1, 1) = rotmatrix(i, j, k, 1, 1)
2142  rot(1, 2) = rotmatrix(i, j, k, 1, 2)
2143  rot(1, 3) = rotmatrix(i, j, k, 1, 3)
2144 
2145  rot(2, 1) = rotmatrix(i, j, k, 2, 1)
2146  rot(2, 2) = rotmatrix(i, j, k, 2, 2)
2147  rot(2, 3) = rotmatrix(i, j, k, 2, 3)
2148 
2149  rot(3, 1) = rotmatrix(i, j, k, 3, 1)
2150  rot(3, 2) = rotmatrix(i, j, k, 3, 2)
2151  rot(3, 3) = rotmatrix(i, j, k, 3, 3)
2152 
2153  ! Apply the transformation to the velocity components
2154  ! of du1, du2 and du3.
2155 
2156  dvx = du1(ivx); dvy = du1(ivy); dvz = du1(ivz)
2157  du1(ivx) = rot(1, 1) * dvx + rot(1, 2) * dvy + rot(1, 3) * dvz
2158  du1(ivy) = rot(2, 1) * dvx + rot(2, 2) * dvy + rot(2, 3) * dvz
2159  du1(ivz) = rot(3, 1) * dvx + rot(3, 2) * dvy + rot(3, 3) * dvz
2160 
2161  dvx = du2(ivx); dvy = du2(ivy); dvz = du2(ivz)
2162  du2(ivx) = rot(1, 1) * dvx + rot(1, 2) * dvy + rot(1, 3) * dvz
2163  du2(ivy) = rot(2, 1) * dvx + rot(2, 2) * dvy + rot(2, 3) * dvz
2164  du2(ivz) = rot(3, 1) * dvx + rot(3, 2) * dvy + rot(3, 3) * dvz
2165 
2166  dvx = du3(ivx); dvy = du3(ivy); dvz = du3(ivz)
2167  du3(ivx) = rot(1, 1) * dvx + rot(1, 2) * dvy + rot(1, 3) * dvz
2168  du3(ivy) = rot(2, 1) * dvx + rot(2, 2) * dvy + rot(2, 3) * dvz
2169  du3(ivz) = rot(3, 1) * dvx + rot(3, 2) * dvy + rot(3, 3) * dvz
2170 
2171  end if
2172 
2173  ! Determine the limiter used.
2174 
2175  select case (limused)
2176 
2177  case (nolimiter)
2178 
2179  ! Linear interpolation; no limiter.
2180  ! Loop over the number of variables to be interpolated.
2181 
2182  do l = 1, nwint
2183  left(l) = omk * du1(l) + opk * du2(l)
2184  right(l) = -omk * du3(l) - opk * du2(l)
2185  end do
2186 
2187  ! ==============================================================
2188 
2189  case (vanalbeda)
2190 
2191  ! Nonlinear interpolation using the van albeda limiter.
2192  ! Loop over the number of variables to be interpolated.
2193 
2194  do l = 1, nwint
2195 
2196  ! Compute the limiter argument rl1, rl2, rr1 and rr2.
2197  ! Note the cut off to 0.0.
2198 
2199  tmp = one / sign(max(abs(du2(l)), epslim), du2(l))
2200  rl1 = max(zero, &
2201  du2(l) / sign(max(abs(du1(l)), epslim), du1(l)))
2202  rl2 = max(zero, du1(l) * tmp)
2203 
2204  rr1 = max(zero, du3(l) * tmp)
2205  rr2 = max(zero, &
2206  du2(l) / sign(max(abs(du3(l)), epslim), du3(l)))
2207 
2208  ! Compute the corresponding limiter values.
2209 
2210  rl1 = rl1 * (rl1 + one) / (rl1 * rl1 + one)
2211  rl2 = rl2 * (rl2 + one) / (rl2 * rl2 + one)
2212  rr1 = rr1 * (rr1 + one) / (rr1 * rr1 + one)
2213  rr2 = rr2 * (rr2 + one) / (rr2 * rr2 + one)
2214 
2215  ! Compute the nonlinear corrections to the first order
2216  ! scheme.
2217 
2218  left(l) = omk * rl1 * du1(l) + opk * rl2 * du2(l)
2219  right(l) = -opk * rr1 * du2(l) - omk * rr2 * du3(l)
2220 
2221  end do
2222 
2223  ! ==============================================================
2224 
2225  case (minmod)
2226 
2227  ! Nonlinear interpolation using the minmod limiter.
2228  ! Loop over the number of variables to be interpolated.
2229 
2230  do l = 1, nwint
2231 
2232  ! Compute the limiter argument rl1, rl2, rr1 and rr2.
2233  ! Note the cut off to 0.0.
2234 
2235  tmp = one / sign(max(abs(du2(l)), epslim), du2(l))
2236  rl1 = max(zero, &
2237  du2(l) / sign(max(abs(du1(l)), epslim), du1(l)))
2238  rl2 = max(zero, du1(l) * tmp)
2239 
2240  rr1 = max(zero, du3(l) * tmp)
2241  rr2 = max(zero, &
2242  du2(l) / sign(max(abs(du3(l)), epslim), du3(l)))
2243 
2244  ! Compute the corresponding limiter values.
2245 
2246  rl1 = min(one, factminmod * rl1)
2247  rl2 = min(one, factminmod * rl2)
2248  rr1 = min(one, factminmod * rr1)
2249  rr2 = min(one, factminmod * rr2)
2250 
2251  ! Compute the nonlinear corrections to the first order
2252  ! scheme.
2253 
2254  left(l) = omk * rl1 * du1(l) + opk * rl2 * du2(l)
2255  right(l) = -opk * rr1 * du2(l) - omk * rr2 * du3(l)
2256 
2257  end do
2258 
2259  end select
2260 
2261  ! In case only a first order scheme must be used for the
2262  ! turbulent transport equations, set the correction for the
2263  ! turbulent kinetic energy to 0.
2264 
2265  if (firstorderk) then
2266  left(itu1) = zero
2267  right(itu1) = zero
2268  end if
2269 
2270  ! For rotational periodic problems transform the velocity
2271  ! differences back to Cartesian again. Note that now the
2272  ! transpose of the rotation matrix must be used.
2273 
2274  if (rotationalperiodic) then
2275 
2276  ! Left state.
2277 
2278  dvx = left(ivx); dvy = left(ivy); dvz = left(ivz)
2279  left(ivx) = rot(1, 1) * dvx + rot(2, 1) * dvy + rot(3, 1) * dvz
2280  left(ivy) = rot(1, 2) * dvx + rot(2, 2) * dvy + rot(3, 2) * dvz
2281  left(ivz) = rot(1, 3) * dvx + rot(2, 3) * dvy + rot(3, 3) * dvz
2282 
2283  ! Right state.
2284 
2285  dvx = right(ivx); dvy = right(ivy); dvz = right(ivz)
2286  right(ivx) = rot(1, 1) * dvx + rot(2, 1) * dvy + rot(3, 1) * dvz
2287  right(ivy) = rot(1, 2) * dvx + rot(2, 2) * dvy + rot(3, 2) * dvz
2288  right(ivz) = rot(1, 3) * dvx + rot(2, 3) * dvy + rot(3, 3) * dvz
2289 
2290  end if
2291 
2292  end subroutine leftrightstate
2293 
2294  ! ================================================================
2295 
2296  subroutine riemannflux(left, right, flux)
2297  !
2298  ! riemannFlux computes the flux for the given face and left
2299  ! and right states.
2300  !
2301  implicit none
2302  !
2303  ! Subroutine arguments.
2304  !
2305  real(kind=realtype), dimension(*), intent(in) :: left, right
2306  real(kind=realtype), dimension(*), intent(out) :: flux
2307  !
2308  ! Local variables.
2309  !
2310  real(kind=realtype) :: porflux, rface
2311  real(kind=realtype) :: etl, etr, z1l, z1r, tmp
2312  real(kind=realtype) :: dr, dru, drv, drw, dre, drk
2313  real(kind=realtype) :: ravg, uavg, vavg, wavg, havg, kavg
2314  real(kind=realtype) :: alphaavg, a2avg, aavg, unavg
2315  real(kind=realtype) :: ovaavg, ova2avg, area, eta
2316  real(kind=realtype) :: gm1, gm53
2317  real(kind=realtype) :: lam1, lam2, lam3
2318  real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
2319  real(kind=realtype), dimension(2) :: ktmp
2320 
2321  ! Set the porosity for the flux. The default value, 0.5*rFil, is
2322  ! a scaling factor where an rFil != 1 is taken into account.
2323 
2324  porflux = half * rfil
2325  if (por == noflux .or. por == boundflux) porflux = zero
2326 
2327  ! Abbreviate some expressions in which gamma occurs.
2328 
2329  gm1 = gammaface - one
2330  gm53 = gammaface - five * third
2331 
2332  ! Determine which riemann solver must be solved.
2333 
2334  select case (riemannused)
2335 
2336  case (roe)
2337 
2338  ! Determine the preconditioner used.
2339 
2340  select case (precond)
2341 
2342  case (noprecond)
2343 
2344  ! No preconditioner used. Use the Roe scheme of the
2345  ! standard equations.
2346 
2347  ! Compute the square root of the left and right densities
2348  ! and the inverse of the sum.
2349 
2350  z1l = sqrt(left(irho))
2351  z1r = sqrt(right(irho))
2352  tmp = one / (z1l + z1r)
2353 
2354  ! Compute some variables depending whether or not a
2355  ! k-equation is present.
2356 
2357  if (correctfork) then
2358 
2359  ! Store the left and right kinetic energy in ktmp,
2360  ! which is needed to compute the total energy.
2361 
2362  ktmp(1) = left(itu1)
2363  ktmp(2) = right(itu1)
2364 
2365  ! Store the difference of the turbulent kinetic energy
2366  ! per unit volume, i.e. the conserved variable.
2367 
2368  drk = right(irho) * right(itu1) - left(irho) * left(itu1)
2369 
2370  ! Compute the average turbulent energy per unit mass
2371  ! using Roe averages.
2372 
2373  kavg = tmp * (z1l * left(itu1) + z1r * right(itu1))
2374 
2375  else
2376 
2377  ! Set the difference of the turbulent kinetic energy
2378  ! per unit volume and the averaged kinetic energy per
2379  ! unit mass to zero.
2380 
2381  drk = 0.0
2382  kavg = 0.0
2383 
2384  end if
2385 
2386  ! Compute the total energy of the left and right state.
2387  call etot(left(irho), left(ivx), left(ivy), left(ivz), &
2388  left(irhoe), ktmp(1), etl, correctfork)
2389 
2390  call etot(right(irho), right(ivx), right(ivy), right(ivz), &
2391  right(irhoe), ktmp(2), etr, correctfork)
2392 
2393  ! Compute the difference of the conservative mean
2394  ! flow variables.
2395 
2396  dr = right(irho) - left(irho)
2397  dru = right(irho) * right(ivx) - left(irho) * left(ivx)
2398  drv = right(irho) * right(ivy) - left(irho) * left(ivy)
2399  drw = right(irho) * right(ivz) - left(irho) * left(ivz)
2400  dre = etr - etl
2401 
2402  ! Compute the Roe average variables, which can be
2403  ! computed directly from the average Roe vector.
2404 
2405  ravg = fourth * (z1r + z1l)**2
2406  uavg = tmp * (z1l * left(ivx) + z1r * right(ivx))
2407  vavg = tmp * (z1l * left(ivy) + z1r * right(ivy))
2408  wavg = tmp * (z1l * left(ivz) + z1r * right(ivz))
2409  havg = tmp * ((etl + left(irhoe)) / z1l &
2410  + (etr + right(irhoe)) / z1r)
2411 
2412  ! Compute the unit vector and store the area of the
2413  ! normal. Also compute the unit normal velocity of the face.
2414 
2415  area = sqrt(sx**2 + sy**2 + sz**2)
2416  tmp = one / max(1.e-25_realtype, area)
2417  sx = sx * tmp
2418  sy = sy * tmp
2419  sz = sz * tmp
2420  rface = sface * tmp
2421 
2422  ! Compute some dependent variables at the Roe
2423  ! average state.
2424 
2425  alphaavg = half * (uavg**2 + vavg**2 + wavg**2)
2426  a2avg = abs(gm1 * (havg - alphaavg) - gm53 * kavg)
2427  aavg = sqrt(a2avg)
2428  unavg = uavg * sx + vavg * sy + wavg * sz
2429 
2430  ovaavg = one / aavg
2431  ova2avg = one / a2avg
2432 
2433  ! Set for a boundary the normal velocity to rFace, the
2434  ! normal velocity of the boundary.
2435 
2436  if (por == boundflux) unavg = rface
2437 
2438  ! Compute the coefficient eta for the entropy correction.
2439  ! At the moment a 1D entropy correction is used, which
2440  ! removes expansion shocks. Although it also reduces the
2441  ! carbuncle phenomenon, it does not remove it completely.
2442  ! In other to do that a multi-dimensional entropy fix is
2443  ! needed, see Sanders et. al, JCP, vol. 145, 1998,
2444  ! pp. 511 - 537. Although relatively easy to implement,
2445  ! an efficient implementation requires the storage of
2446  ! all the left and right states, which is rather
2447  ! expensive in terms of memory.
2448 
2449  eta = half * (abs((left(ivx) - right(ivx)) * sx &
2450  + (left(ivy) - right(ivy)) * sy &
2451  + (left(ivz) - right(ivz)) * sz) &
2452  + abs(sqrt(gammaface * left(irhoe) / left(irho)) &
2453  - sqrt(gammaface * right(irhoe) / right(irho))))
2454 
2455  ! Compute the absolute values of the three eigenvalues.
2456 
2457  lam1 = abs(unavg - rface + aavg)
2458  lam2 = abs(unavg - rface - aavg)
2459  lam3 = abs(unavg - rface)
2460 
2461  ! Apply the entropy correction to the eigenvalues.
2462 
2463  tmp = two * eta
2464  if (lam1 < tmp) lam1 = eta + fourth * lam1 * lam1 / eta
2465  if (lam2 < tmp) lam2 = eta + fourth * lam2 * lam2 / eta
2466  if (lam3 < tmp) lam3 = eta + fourth * lam3 * lam3 / eta
2467 
2468  ! Multiply the eigenvalues by the area to obtain
2469  ! the correct values for the dissipation term.
2470 
2471  lam1 = lam1 * area
2472  lam2 = lam2 * area
2473  lam3 = lam3 * area
2474 
2475  ! Some abbreviations, which occur quite often in the
2476  ! dissipation terms.
2477 
2478  abv1 = half * (lam1 + lam2)
2479  abv2 = half * (lam1 - lam2)
2480  abv3 = abv1 - lam3
2481 
2482  abv4 = gm1 * (alphaavg * dr - uavg * dru - vavg * drv &
2483  - wavg * drw + dre) - gm53 * drk
2484  abv5 = sx * dru + sy * drv + sz * drw - unavg * dr
2485 
2486  abv6 = abv3 * abv4 * ova2avg + abv2 * abv5 * ovaavg
2487  abv7 = abv2 * abv4 * ovaavg + abv3 * abv5
2488 
2489  ! Compute the dissipation term, -|a| (wr - wl), which is
2490  ! multiplied by porFlux. Note that porFlux is either
2491  ! 0.0 or 0.5*rFil.
2492 
2493  flux(irho) = -porflux * (lam3 * dr + abv6)
2494  flux(imx) = -porflux * (lam3 * dru + uavg * abv6 &
2495  + sx * abv7)
2496  flux(imy) = -porflux * (lam3 * drv + vavg * abv6 &
2497  + sy * abv7)
2498  flux(imz) = -porflux * (lam3 * drw + wavg * abv6 &
2499  + sz * abv7)
2500  flux(irhoe) = -porflux * (lam3 * dre + havg * abv6 &
2501  + unavg * abv7)
2502 
2503  ! tmp = max(lam1,lam2,lam3)
2504 
2505  ! flux(irho) = -porFlux*(tmp*dr)
2506  ! flux(imx) = -porFlux*(tmp*dru)
2507  ! flux(imy) = -porFlux*(tmp*drv)
2508  ! flux(imz) = -porFlux*(tmp*drw)
2509  ! flux(irhoE) = -porFlux*(tmp*drE)
2510 
2511  case (turkel)
2512  call terminate( &
2513  "riemannFlux", &
2514  "Turkel preconditioner not implemented yet")
2515 
2516  case (choimerkle)
2517  call terminate("riemannFlux", &
2518  "choi merkle preconditioner not implemented yet")
2519 
2520  end select
2521 
2522  case (vanleer)
2523  call terminate("riemannFlux", "van leer fvs not implemented yet")
2524 
2525  case (ausmdv)
2526  call terminate("riemannFlux", "ausmdv fvs not implemented yet")
2527 
2528  end select
2529 
2530  end subroutine riemannflux
2531 
2532  end subroutine inviscidupwindflux
2533 
2534  subroutine viscousflux
2535  !
2536  ! viscousFlux computes the viscous fluxes using a central
2537  ! difference scheme for a block.
2538  ! It is assumed that the pointers in block pointer already point
2539  ! to the correct block.
2540  !
2541  use constants
2542  use blockpointers
2543  use flowvarrefstate
2544  use inputphysics
2545  use iteration
2546 #ifndef USE_TAPENADE
2547  use solverutils, only: utauwf
2548 #endif
2549  implicit none
2550  !
2551  ! Local parameter.
2552  !
2553  real(kind=realtype), parameter :: twothird = two * third
2554  real(kind=realtype), parameter :: xminn = 1.e-14_realtype
2555  !
2556  ! Local variables.
2557  !
2558  integer(kind=intType) :: i, j, k, ii
2559 
2560  real(kind=realtype) :: rfilv, por, mul, mue, mut, heatcoef
2561  real(kind=realtype) :: gm1, factlamheat, factturbheat
2562  real(kind=realtype) :: u_x, u_y, u_z, v_x, v_y, v_z, w_x, w_y, w_z
2563  real(kind=realtype) :: q_x, q_y, q_z, ubar, vbar, wbar
2564  real(kind=realtype) :: corr, ssx, ssy, ssz, ss, fracdiv
2565  real(kind=realtype) :: tauxx, tauyy, tauzz
2566  real(kind=realtype) :: tauxy, tauxz, tauyz
2567  real(kind=realtype) :: tauxxs, tauyys, tauzzs
2568  real(kind=realtype) :: tauxys, tauxzs, tauyzs
2569  real(kind=realtype) :: exx, eyy, ezz
2570  real(kind=realtype) :: exy, exz, eyz
2571  real(kind=realtype) :: wxy, wxz, wyz, wyx, wzx, wzy
2572  real(kind=realtype) :: den, ccr1, fact
2573  real(kind=realtype) :: fmx, fmy, fmz, frhoe
2574  logical :: correctForK, storeWallTensor
2575 
2576  ! Set QCR parameters
2577  ccr1 = 0.3_realtype
2578 
2579  ! Set rFilv to rFil to indicate that this is the viscous part.
2580  ! If rFilv == 0 the viscous residuals need not to be computed
2581  ! and a return can be made.
2582 
2583  rfilv = rfil
2584 
2585  if (abs(rfilv) < thresholdreal) return
2586 
2587  ! Determine whether or not the wall stress tensor and wall heat
2588  ! flux must be stored for viscous walls.
2589 
2590  storewalltensor = .false.
2591  if (wallfunctions) then
2592  storewalltensor = .true.
2593  else if (rkstage == 0 .and. currentlevel == groundlevel) then
2594  storewalltensor = .true.
2595  end if
2596 
2597  !
2598  ! viscous fluxes in the k-direction.
2599  !
2600  continue
2601  !$AD CHECKPOINT-START
2602  mue = zero
2603 #ifdef TAPENADE_REVERSE
2604  !$AD II-LOOP
2605  do ii = 0, nx * ny * kl - 1
2606  i = mod(ii, nx) + 2
2607  j = mod(ii / nx, ny) + 2
2608  k = ii / (nx * ny) + 1
2609 #else
2610  do k = 1, kl
2611  do j = 2, jl
2612  do i = 2, il
2613 #endif
2614 
2615  ! Set the value of the porosity. If not zero, it is set
2616  ! to average the eddy-viscosity and to take the factor
2617  ! rFilv into account.
2618 
2619  por = half * rfilv
2620  if (pork(i, j, k) == noflux) por = zero
2621 
2622  ! Compute the laminar and (if present) the eddy viscosities
2623  ! multiplied by the porosity. Compute the factor in front of
2624  ! the gradients of the speed of sound squared for the heat
2625  ! flux.
2626 
2627  mul = por * (rlv(i, j, k) + rlv(i, j, k + 1))
2628  if (eddymodel) mue = por * (rev(i, j, k) + rev(i, j, k + 1))
2629  mut = mul + mue
2630 
2631  gm1 = half * (gamma(i, j, k) + gamma(i, j, k + 1)) - one
2632  factlamheat = one / (prandtl * gm1)
2633  factturbheat = one / (prandtlturb * gm1)
2634 
2635  heatcoef = mul * factlamheat + mue * factturbheat
2636 
2637  ! Compute the gradients at the face by averaging the four
2638  ! nodal values.
2639 
2640  u_x = fourth * (ux(i - 1, j - 1, k) + ux(i, j - 1, k) &
2641  + ux(i - 1, j, k) + ux(i, j, k))
2642  u_y = fourth * (uy(i - 1, j - 1, k) + uy(i, j - 1, k) &
2643  + uy(i - 1, j, k) + uy(i, j, k))
2644  u_z = fourth * (uz(i - 1, j - 1, k) + uz(i, j - 1, k) &
2645  + uz(i - 1, j, k) + uz(i, j, k))
2646 
2647  v_x = fourth * (vx(i - 1, j - 1, k) + vx(i, j - 1, k) &
2648  + vx(i - 1, j, k) + vx(i, j, k))
2649  v_y = fourth * (vy(i - 1, j - 1, k) + vy(i, j - 1, k) &
2650  + vy(i - 1, j, k) + vy(i, j, k))
2651  v_z = fourth * (vz(i - 1, j - 1, k) + vz(i, j - 1, k) &
2652  + vz(i - 1, j, k) + vz(i, j, k))
2653 
2654  w_x = fourth * (wx(i - 1, j - 1, k) + wx(i, j - 1, k) &
2655  + wx(i - 1, j, k) + wx(i, j, k))
2656  w_y = fourth * (wy(i - 1, j - 1, k) + wy(i, j - 1, k) &
2657  + wy(i - 1, j, k) + wy(i, j, k))
2658  w_z = fourth * (wz(i - 1, j - 1, k) + wz(i, j - 1, k) &
2659  + wz(i - 1, j, k) + wz(i, j, k))
2660 
2661  q_x = fourth * (qx(i - 1, j - 1, k) + qx(i, j - 1, k) &
2662  + qx(i - 1, j, k) + qx(i, j, k))
2663  q_y = fourth * (qy(i - 1, j - 1, k) + qy(i, j - 1, k) &
2664  + qy(i - 1, j, k) + qy(i, j, k))
2665  q_z = fourth * (qz(i - 1, j - 1, k) + qz(i, j - 1, k) &
2666  + qz(i - 1, j, k) + qz(i, j, k))
2667 
2668  ! The gradients in the normal direction are corrected, such
2669  ! that no averaging takes places here.
2670  ! First determine the vector in the direction from the
2671  ! cell center k to cell center k+1.
2672 
2673  ssx = eighth * (x(i - 1, j - 1, k + 1, 1) - x(i - 1, j - 1, k - 1, 1) &
2674  + x(i - 1, j, k + 1, 1) - x(i - 1, j, k - 1, 1) &
2675  + x(i, j - 1, k + 1, 1) - x(i, j - 1, k - 1, 1) &
2676  + x(i, j, k + 1, 1) - x(i, j, k - 1, 1))
2677  ssy = eighth * (x(i - 1, j - 1, k + 1, 2) - x(i - 1, j - 1, k - 1, 2) &
2678  + x(i - 1, j, k + 1, 2) - x(i - 1, j, k - 1, 2) &
2679  + x(i, j - 1, k + 1, 2) - x(i, j - 1, k - 1, 2) &
2680  + x(i, j, k + 1, 2) - x(i, j, k - 1, 2))
2681  ssz = eighth * (x(i - 1, j - 1, k + 1, 3) - x(i - 1, j - 1, k - 1, 3) &
2682  + x(i - 1, j, k + 1, 3) - x(i - 1, j, k - 1, 3) &
2683  + x(i, j - 1, k + 1, 3) - x(i, j - 1, k - 1, 3) &
2684  + x(i, j, k + 1, 3) - x(i, j, k - 1, 3))
2685 
2686  ! Determine the length of this vector and create the
2687  ! unit normal.
2688 
2689  ss = one / sqrt(ssx * ssx + ssy * ssy + ssz * ssz)
2690  ssx = ss * ssx
2691  ssy = ss * ssy
2692  ssz = ss * ssz
2693 
2694  ! Correct the gradients.
2695 
2696  corr = u_x * ssx + u_y * ssy + u_z * ssz &
2697  - (w(i, j, k + 1, ivx) - w(i, j, k, ivx)) * ss
2698  u_x = u_x - corr * ssx
2699  u_y = u_y - corr * ssy
2700  u_z = u_z - corr * ssz
2701 
2702  corr = v_x * ssx + v_y * ssy + v_z * ssz &
2703  - (w(i, j, k + 1, ivy) - w(i, j, k, ivy)) * ss
2704  v_x = v_x - corr * ssx
2705  v_y = v_y - corr * ssy
2706  v_z = v_z - corr * ssz
2707 
2708  corr = w_x * ssx + w_y * ssy + w_z * ssz &
2709  - (w(i, j, k + 1, ivz) - w(i, j, k, ivz)) * ss
2710  w_x = w_x - corr * ssx
2711  w_y = w_y - corr * ssy
2712  w_z = w_z - corr * ssz
2713 
2714  corr = q_x * ssx + q_y * ssy + q_z * ssz &
2715  + (aa(i, j, k + 1) - aa(i, j, k)) * ss
2716  q_x = q_x - corr * ssx
2717  q_y = q_y - corr * ssy
2718  q_z = q_z - corr * ssz
2719 
2720  ! Compute the stress tensor and the heat flux vector.
2721  ! We remove the viscosity from the stress tensor (tau)
2722  ! to define tauS since we still need to separate between
2723  ! laminar and turbulent stress for QCR.
2724  ! Therefore, laminar tau = mue*tauS, turbulent
2725  ! tau = mue*tauS, and total tau = mut*tauS.
2726 
2727  fracdiv = twothird * (u_x + v_y + w_z)
2728 
2729  tauxxs = two * u_x - fracdiv
2730  tauyys = two * v_y - fracdiv
2731  tauzzs = two * w_z - fracdiv
2732 
2733  tauxys = u_y + v_x
2734  tauxzs = u_z + w_x
2735  tauyzs = v_z + w_y
2736 
2737  q_x = heatcoef * q_x
2738  q_y = heatcoef * q_y
2739  q_z = heatcoef * q_z
2740 
2741  ! Add QCR corrections if necessary
2742  if (useqcr) then
2743 
2744  ! In the QCR formulation, we add an extra term to the turbulent stress tensor:
2745  !
2746  ! tau_ij,QCR = tau_ij - e_ij
2747  !
2748  ! where, according to TMR website (http://turbmodels.larc.nasa.gov/spalart.html):
2749  !
2750  ! e_ij = Ccr1*(O_ik*tau_jk + O_jk*tau_ik)
2751  !
2752  ! We are computing O_ik as follows:
2753  !
2754  ! O_ik = 2*W_ik/den
2755  !
2756  ! Remember that the tau_ij in e_ij should use only the eddy viscosity!
2757 
2758  ! Compute denominator
2759  den = sqrt(u_x * u_x + u_y * u_y + u_z * u_z + &
2760  v_x * v_x + v_y * v_y + v_z * v_z + &
2761  w_x * w_x + w_y * w_y + w_z * w_z)
2762 
2763  ! Denominator should be limited to avoid division by zero in regions with
2764  ! no gradients
2765  den = max(den, xminn)
2766 
2767  ! Compute factor that will multiply all tensor components.
2768  ! Here we add the eddy viscosity that should multiply the stress tensor (tau)
2769  ! components as well.
2770  fact = mue * ccr1 / den
2771 
2772  ! Compute off-diagonal terms of vorticity tensor (we will ommit the 1/2)
2773  ! The diagonals of the vorticity tensor components are always zero
2774  wxy = u_y - v_x
2775  wxz = u_z - w_x
2776  wyz = v_z - w_y
2777  wyx = -wxy
2778  wzx = -wxz
2779  wzy = -wyz
2780 
2781  ! Compute the extra terms of the Boussinesq relation
2782  exx = fact * (wxy * tauxys + wxz * tauxzs) * two
2783  eyy = fact * (wyx * tauxys + wyz * tauyzs) * two
2784  ezz = fact * (wzx * tauxzs + wzy * tauyzs) * two
2785 
2786  exy = fact * (wxy * tauyys + wxz * tauyzs + &
2787  wyx * tauxxs + wyz * tauxzs)
2788  exz = fact * (wxy * tauyzs + wxz * tauzzs + &
2789  wzx * tauxxs + wzy * tauxys)
2790  eyz = fact * (wyx * tauxzs + wyz * tauzzs + &
2791  wzx * tauxys + wzy * tauyys)
2792 
2793  ! Apply the total viscosity to the stress tensor and add extra terms
2794  tauxx = mut * tauxxs - exx
2795  tauyy = mut * tauyys - eyy
2796  tauzz = mut * tauzzs - ezz
2797  tauxy = mut * tauxys - exy
2798  tauxz = mut * tauxzs - exz
2799  tauyz = mut * tauyzs - eyz
2800 
2801  else
2802 
2803  ! Just apply the total viscosity to the stress tensor
2804  tauxx = mut * tauxxs
2805  tauyy = mut * tauyys
2806  tauzz = mut * tauzzs
2807  tauxy = mut * tauxys
2808  tauxz = mut * tauxzs
2809  tauyz = mut * tauyzs
2810 
2811  end if
2812 
2813  ! Compute the average velocities for the face. Remember that
2814  ! the velocities are stored and not the momentum.
2815 
2816  ubar = half * (w(i, j, k, ivx) + w(i, j, k + 1, ivx))
2817  vbar = half * (w(i, j, k, ivy) + w(i, j, k + 1, ivy))
2818  wbar = half * (w(i, j, k, ivz) + w(i, j, k + 1, ivz))
2819 
2820  ! Compute the viscous fluxes for this k-face.
2821 
2822  fmx = tauxx * sk(i, j, k, 1) + tauxy * sk(i, j, k, 2) &
2823  + tauxz * sk(i, j, k, 3)
2824  fmy = tauxy * sk(i, j, k, 1) + tauyy * sk(i, j, k, 2) &
2825  + tauyz * sk(i, j, k, 3)
2826  fmz = tauxz * sk(i, j, k, 1) + tauyz * sk(i, j, k, 2) &
2827  + tauzz * sk(i, j, k, 3)
2828  frhoe = (ubar * tauxx + vbar * tauxy + wbar * tauxz) * sk(i, j, k, 1)
2829  frhoe = frhoe + (ubar * tauxy + vbar * tauyy + wbar * tauyz) * sk(i, j, k, 2)
2830  frhoe = frhoe + (ubar * tauxz + vbar * tauyz + wbar * tauzz) * sk(i, j, k, 3)
2831  frhoe = frhoe - q_x * sk(i, j, k, 1) - q_y * sk(i, j, k, 2) - q_z * sk(i, j, k, 3)
2832 
2833  ! Update the residuals of cell k and k+1.
2834 
2835  fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
2836  fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
2837  fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
2838  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
2839 
2840  fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) + fmx
2841  fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) + fmy
2842  fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) + fmz
2843  fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) + frhoe
2844 
2845  ! Store the stress tensor and the heat flux vector if this
2846  ! face is part of a viscous subface. Both the cases k == 1
2847  ! and k == kl must be tested.
2848 
2849  if (k == 1 .and. storewalltensor .and. &
2850  visckminpointer(i, j) > 0) then
2851  ! We need to index viscSubface with viscKminPointer(i,j)
2852  ! since Tapenade does not like temporary indexes
2853 
2854  viscsubface(visckminpointer(i, j))%tau(i, j, 1) = tauxx
2855  viscsubface(visckminpointer(i, j))%tau(i, j, 2) = tauyy
2856  viscsubface(visckminpointer(i, j))%tau(i, j, 3) = tauzz
2857  viscsubface(visckminpointer(i, j))%tau(i, j, 4) = tauxy
2858  viscsubface(visckminpointer(i, j))%tau(i, j, 5) = tauxz
2859  viscsubface(visckminpointer(i, j))%tau(i, j, 6) = tauyz
2860 
2861  viscsubface(visckminpointer(i, j))%q(i, j, 1) = q_x
2862  viscsubface(visckminpointer(i, j))%q(i, j, 2) = q_y
2863  viscsubface(visckminpointer(i, j))%q(i, j, 3) = q_z
2864  end if
2865 
2866  ! And the k == kl case.
2867  if (k == kl .and. storewalltensor .and. &
2868  visckmaxpointer(i, j) > 0) then
2869  viscsubface(visckmaxpointer(i, j))%tau(i, j, 1) = tauxx
2870  viscsubface(visckmaxpointer(i, j))%tau(i, j, 2) = tauyy
2871  viscsubface(visckmaxpointer(i, j))%tau(i, j, 3) = tauzz
2872  viscsubface(visckmaxpointer(i, j))%tau(i, j, 4) = tauxy
2873  viscsubface(visckmaxpointer(i, j))%tau(i, j, 5) = tauxz
2874  viscsubface(visckmaxpointer(i, j))%tau(i, j, 6) = tauyz
2875 
2876  viscsubface(visckmaxpointer(i, j))%q(i, j, 1) = q_x
2877  viscsubface(visckmaxpointer(i, j))%q(i, j, 2) = q_y
2878  viscsubface(visckmaxpointer(i, j))%q(i, j, 3) = q_z
2879  end if
2880 #ifdef TAPENADE_REVERSE
2881  end do
2882 #else
2883  end do
2884  end do
2885  end do
2886 #endif
2887  continue
2888  !$AD CHECKPOINT-END
2889 
2890  !
2891  ! Viscous fluxes in the j-direction.
2892  !
2893  continue
2894  !$AD CHECKPOINT-START
2895  mue = zero
2896 #ifdef TAPENADE_REVERSE
2897  !$AD II-LOOP
2898  do ii = 0, nx * jl * nz - 1
2899  i = mod(ii, nx) + 2
2900  j = mod(ii / nx, jl) + 1
2901  k = ii / (nx * jl) + 2
2902 #else
2903  do k = 2, kl
2904  do j = 1, jl
2905  do i = 2, il
2906 #endif
2907 
2908  ! Set the value of the porosity. If not zero, it is set
2909  ! to average the eddy-viscosity and to take the factor
2910  ! rFilv into account.
2911 
2912  por = half * rfilv
2913  if (porj(i, j, k) == noflux) por = zero
2914 
2915  ! Compute the laminar and (if present) the eddy viscosities
2916  ! multiplied by the porosity. Compute the factor in front of
2917  ! the gradients of the speed of sound squared for the heat
2918  ! flux.
2919 
2920  mul = por * (rlv(i, j, k) + rlv(i, j + 1, k))
2921  if (eddymodel) mue = por * (rev(i, j, k) + rev(i, j + 1, k))
2922  mut = mul + mue
2923 
2924  gm1 = half * (gamma(i, j, k) + gamma(i, j + 1, k)) - one
2925  factlamheat = one / (prandtl * gm1)
2926  factturbheat = one / (prandtlturb * gm1)
2927 
2928  heatcoef = mul * factlamheat + mue * factturbheat
2929 
2930  ! Compute the gradients at the face by averaging the four
2931  ! nodal values.
2932 
2933  u_x = fourth * (ux(i - 1, j, k - 1) + ux(i, j, k - 1) &
2934  + ux(i - 1, j, k) + ux(i, j, k))
2935  u_y = fourth * (uy(i - 1, j, k - 1) + uy(i, j, k - 1) &
2936  + uy(i - 1, j, k) + uy(i, j, k))
2937  u_z = fourth * (uz(i - 1, j, k - 1) + uz(i, j, k - 1) &
2938  + uz(i - 1, j, k) + uz(i, j, k))
2939 
2940  v_x = fourth * (vx(i - 1, j, k - 1) + vx(i, j, k - 1) &
2941  + vx(i - 1, j, k) + vx(i, j, k))
2942  v_y = fourth * (vy(i - 1, j, k - 1) + vy(i, j, k - 1) &
2943  + vy(i - 1, j, k) + vy(i, j, k))
2944  v_z = fourth * (vz(i - 1, j, k - 1) + vz(i, j, k - 1) &
2945  + vz(i - 1, j, k) + vz(i, j, k))
2946 
2947  w_x = fourth * (wx(i - 1, j, k - 1) + wx(i, j, k - 1) &
2948  + wx(i - 1, j, k) + wx(i, j, k))
2949  w_y = fourth * (wy(i - 1, j, k - 1) + wy(i, j, k - 1) &
2950  + wy(i - 1, j, k) + wy(i, j, k))
2951  w_z = fourth * (wz(i - 1, j, k - 1) + wz(i, j, k - 1) &
2952  + wz(i - 1, j, k) + wz(i, j, k))
2953 
2954  q_x = fourth * (qx(i - 1, j, k - 1) + qx(i, j, k - 1) &
2955  + qx(i - 1, j, k) + qx(i, j, k))
2956  q_y = fourth * (qy(i - 1, j, k - 1) + qy(i, j, k - 1) &
2957  + qy(i - 1, j, k) + qy(i, j, k))
2958  q_z = fourth * (qz(i - 1, j, k - 1) + qz(i, j, k - 1) &
2959  + qz(i - 1, j, k) + qz(i, j, k))
2960 
2961  ! The gradients in the normal direction are corrected, such
2962  ! that no averaging takes places here.
2963  ! First determine the vector in the direction from the
2964  ! cell center j to cell center j+1.
2965 
2966  ssx = eighth * (x(i - 1, j + 1, k - 1, 1) - x(i - 1, j - 1, k - 1, 1) &
2967  + x(i - 1, j + 1, k, 1) - x(i - 1, j - 1, k, 1) &
2968  + x(i, j + 1, k - 1, 1) - x(i, j - 1, k - 1, 1) &
2969  + x(i, j + 1, k, 1) - x(i, j - 1, k, 1))
2970  ssy = eighth * (x(i - 1, j + 1, k - 1, 2) - x(i - 1, j - 1, k - 1, 2) &
2971  + x(i - 1, j + 1, k, 2) - x(i - 1, j - 1, k, 2) &
2972  + x(i, j + 1, k - 1, 2) - x(i, j - 1, k - 1, 2) &
2973  + x(i, j + 1, k, 2) - x(i, j - 1, k, 2))
2974  ssz = eighth * (x(i - 1, j + 1, k - 1, 3) - x(i - 1, j - 1, k - 1, 3) &
2975  + x(i - 1, j + 1, k, 3) - x(i - 1, j - 1, k, 3) &
2976  + x(i, j + 1, k - 1, 3) - x(i, j - 1, k - 1, 3) &
2977  + x(i, j + 1, k, 3) - x(i, j - 1, k, 3))
2978 
2979  ! Determine the length of this vector and create the
2980  ! unit normal.
2981 
2982  ss = one / sqrt(ssx * ssx + ssy * ssy + ssz * ssz)
2983  ssx = ss * ssx
2984  ssy = ss * ssy
2985  ssz = ss * ssz
2986 
2987  ! Correct the gradients.
2988 
2989  corr = u_x * ssx + u_y * ssy + u_z * ssz &
2990  - (w(i, j + 1, k, ivx) - w(i, j, k, ivx)) * ss
2991  u_x = u_x - corr * ssx
2992  u_y = u_y - corr * ssy
2993  u_z = u_z - corr * ssz
2994 
2995  corr = v_x * ssx + v_y * ssy + v_z * ssz &
2996  - (w(i, j + 1, k, ivy) - w(i, j, k, ivy)) * ss
2997  v_x = v_x - corr * ssx
2998  v_y = v_y - corr * ssy
2999  v_z = v_z - corr * ssz
3000 
3001  corr = w_x * ssx + w_y * ssy + w_z * ssz &
3002  - (w(i, j + 1, k, ivz) - w(i, j, k, ivz)) * ss
3003  w_x = w_x - corr * ssx
3004  w_y = w_y - corr * ssy
3005  w_z = w_z - corr * ssz
3006 
3007  corr = q_x * ssx + q_y * ssy + q_z * ssz &
3008  + (aa(i, j + 1, k) - aa(i, j, k)) * ss
3009  q_x = q_x - corr * ssx
3010  q_y = q_y - corr * ssy
3011  q_z = q_z - corr * ssz
3012 
3013  ! Compute the stress tensor and the heat flux vector.
3014  ! We remove the viscosity from the stress tensor (tau)
3015  ! to define tauS since we still need to separate between
3016  ! laminar and turbulent stress for QCR.
3017  ! Therefore, laminar tau = mue*tauS, turbulent
3018  ! tau = mue*tauS, and total tau = mut*tauS.
3019 
3020  fracdiv = twothird * (u_x + v_y + w_z)
3021 
3022  tauxxs = two * u_x - fracdiv
3023  tauyys = two * v_y - fracdiv
3024  tauzzs = two * w_z - fracdiv
3025 
3026  tauxys = u_y + v_x
3027  tauxzs = u_z + w_x
3028  tauyzs = v_z + w_y
3029 
3030  q_x = heatcoef * q_x
3031  q_y = heatcoef * q_y
3032  q_z = heatcoef * q_z
3033 
3034  ! Add QCR corrections if necessary
3035  if (useqcr) then
3036 
3037  ! In the QCR formulation, we add an extra term to the turbulent stress tensor:
3038  !
3039  ! tau_ij,QCR = tau_ij - e_ij
3040  !
3041  ! where, according to TMR website (http://turbmodels.larc.nasa.gov/spalart.html):
3042  !
3043  ! e_ij = Ccr1*(O_ik*tau_jk + O_jk*tau_ik)
3044  !
3045  ! We are computing O_ik as follows:
3046  !
3047  ! O_ik = 2*W_ik/den
3048  !
3049  ! Remember that the tau_ij in e_ij should use only the eddy viscosity!
3050 
3051  ! Compute denominator
3052  den = sqrt(u_x * u_x + u_y * u_y + u_z * u_z + &
3053  v_x * v_x + v_y * v_y + v_z * v_z + &
3054  w_x * w_x + w_y * w_y + w_z * w_z)
3055 
3056  ! Denominator should be limited to avoid division by zero in regions with
3057  ! no gradients
3058  den = max(den, xminn)
3059 
3060  ! Compute factor that will multiply all tensor components.
3061  ! Here we add the eddy viscosity that should multiply the stress tensor (tau)
3062  ! components as well.
3063  fact = mue * ccr1 / den
3064 
3065  ! Compute off-diagonal terms of vorticity tensor (we will ommit the 1/2)
3066  ! The diagonals of the vorticity tensor components are always zero
3067  wxy = u_y - v_x
3068  wxz = u_z - w_x
3069  wyz = v_z - w_y
3070  wyx = -wxy
3071  wzx = -wxz
3072  wzy = -wyz
3073 
3074  ! Compute the extra terms of the Boussinesq relation
3075  exx = fact * (wxy * tauxys + wxz * tauxzs) * two
3076  eyy = fact * (wyx * tauxys + wyz * tauyzs) * two
3077  ezz = fact * (wzx * tauxzs + wzy * tauyzs) * two
3078 
3079  exy = fact * (wxy * tauyys + wxz * tauyzs + &
3080  wyx * tauxxs + wyz * tauxzs)
3081  exz = fact * (wxy * tauyzs + wxz * tauzzs + &
3082  wzx * tauxxs + wzy * tauxys)
3083  eyz = fact * (wyx * tauxzs + wyz * tauzzs + &
3084  wzx * tauxys + wzy * tauyys)
3085 
3086  ! Apply the total viscosity to the stress tensor and add extra terms
3087  tauxx = mut * tauxxs - exx
3088  tauyy = mut * tauyys - eyy
3089  tauzz = mut * tauzzs - ezz
3090  tauxy = mut * tauxys - exy
3091  tauxz = mut * tauxzs - exz
3092  tauyz = mut * tauyzs - eyz
3093 
3094  else
3095 
3096  ! Just apply the total viscosity to the stress tensor
3097  tauxx = mut * tauxxs
3098  tauyy = mut * tauyys
3099  tauzz = mut * tauzzs
3100  tauxy = mut * tauxys
3101  tauxz = mut * tauxzs
3102  tauyz = mut * tauyzs
3103 
3104  end if
3105 
3106  ! Compute the average velocities for the face. Remember that
3107  ! the velocities are stored and not the momentum.
3108 
3109  ubar = half * (w(i, j, k, ivx) + w(i, j + 1, k, ivx))
3110  vbar = half * (w(i, j, k, ivy) + w(i, j + 1, k, ivy))
3111  wbar = half * (w(i, j, k, ivz) + w(i, j + 1, k, ivz))
3112 
3113  ! Compute the viscous fluxes for this j-face.
3114 
3115  fmx = tauxx * sj(i, j, k, 1) + tauxy * sj(i, j, k, 2) &
3116  + tauxz * sj(i, j, k, 3)
3117  fmy = tauxy * sj(i, j, k, 1) + tauyy * sj(i, j, k, 2) &
3118  + tauyz * sj(i, j, k, 3)
3119  fmz = tauxz * sj(i, j, k, 1) + tauyz * sj(i, j, k, 2) &
3120  + tauzz * sj(i, j, k, 3)
3121  frhoe = (ubar * tauxx + vbar * tauxy + wbar * tauxz) * sj(i, j, k, 1) &
3122  + (ubar * tauxy + vbar * tauyy + wbar * tauyz) * sj(i, j, k, 2) &
3123  + (ubar * tauxz + vbar * tauyz + wbar * tauzz) * sj(i, j, k, 3) &
3124  - q_x * sj(i, j, k, 1) - q_y * sj(i, j, k, 2) - q_z * sj(i, j, k, 3)
3125 
3126  ! Update the residuals of cell j and j+1.
3127 
3128  fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
3129  fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
3130  fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
3131  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
3132 
3133  fw(i, j + 1, k, imx) = fw(i, j + 1, k, imx) + fmx
3134  fw(i, j + 1, k, imy) = fw(i, j + 1, k, imy) + fmy
3135  fw(i, j + 1, k, imz) = fw(i, j + 1, k, imz) + fmz
3136  fw(i, j + 1, k, irhoe) = fw(i, j + 1, k, irhoe) + frhoe
3137 
3138  ! Store the stress tensor and the heat flux vector if this
3139  ! face is part of a viscous subface. Both the cases j == 1
3140  ! and j == jl must be tested.
3141 
3142  if (j == 1 .and. storewalltensor .and. &
3143  viscjminpointer(i, k) > 0) then
3144  ! We need to index viscSubface with viscJminPointer(i,k)
3145  ! since Tapenade does not like temporary indexes
3146 
3147  viscsubface(viscjminpointer(i, k))%tau(i, k, 1) = tauxx
3148  viscsubface(viscjminpointer(i, k))%tau(i, k, 2) = tauyy
3149  viscsubface(viscjminpointer(i, k))%tau(i, k, 3) = tauzz
3150  viscsubface(viscjminpointer(i, k))%tau(i, k, 4) = tauxy
3151  viscsubface(viscjminpointer(i, k))%tau(i, k, 5) = tauxz
3152  viscsubface(viscjminpointer(i, k))%tau(i, k, 6) = tauyz
3153 
3154  viscsubface(viscjminpointer(i, k))%q(i, k, 1) = q_x
3155  viscsubface(viscjminpointer(i, k))%q(i, k, 2) = q_y
3156  viscsubface(viscjminpointer(i, k))%q(i, k, 3) = q_z
3157  end if
3158 
3159  ! And the j == jl case.
3160 
3161  if (j == jl .and. storewalltensor .and. &
3162  viscjmaxpointer(i, k) > 0) then
3163  viscsubface(viscjmaxpointer(i, k))%tau(i, k, 1) = tauxx
3164  viscsubface(viscjmaxpointer(i, k))%tau(i, k, 2) = tauyy
3165  viscsubface(viscjmaxpointer(i, k))%tau(i, k, 3) = tauzz
3166  viscsubface(viscjmaxpointer(i, k))%tau(i, k, 4) = tauxy
3167  viscsubface(viscjmaxpointer(i, k))%tau(i, k, 5) = tauxz
3168  viscsubface(viscjmaxpointer(i, k))%tau(i, k, 6) = tauyz
3169 
3170  viscsubface(viscjmaxpointer(i, k))%q(i, k, 1) = q_x
3171  viscsubface(viscjmaxpointer(i, k))%q(i, k, 2) = q_y
3172  viscsubface(viscjmaxpointer(i, k))%q(i, k, 3) = q_z
3173  end if
3174 #ifdef TAPENADE_REVERSE
3175  end do
3176 #else
3177  end do
3178  end do
3179  end do
3180 #endif
3181  continue
3182  !$AD CHECKPOINT-END
3183 
3184  !
3185  ! Viscous fluxes in the i-direction.
3186  !
3187  continue
3188  !$AD CHECKPOINT-START
3189  mue = zero
3190 #ifdef TAPENADE_REVERSE
3191  !$AD II-LOOP
3192  do ii = 0, il * ny * nz - 1
3193  i = mod(ii, il) + 1
3194  j = mod(ii / il, ny) + 2
3195  k = ii / (il * ny) + 2
3196 #else
3197  do k = 2, kl
3198  do j = 2, jl
3199  do i = 1, il
3200 #endif
3201 
3202  ! Set the value of the porosity. If not zero, it is set
3203  ! to average the eddy-viscosity and to take the factor
3204  ! rFilv into account.
3205 
3206  por = half * rfilv
3207  if (pori(i, j, k) == noflux) por = zero
3208 
3209  ! Compute the laminar and (if present) the eddy viscosities
3210  ! multiplied the porosity. Compute the factor in front of
3211  ! the gradients of the speed of sound squared for the heat
3212  ! flux.
3213 
3214  mul = por * (rlv(i, j, k) + rlv(i + 1, j, k))
3215  if (eddymodel) mue = por * (rev(i, j, k) + rev(i + 1, j, k))
3216  mut = mul + mue
3217 
3218  gm1 = half * (gamma(i, j, k) + gamma(i + 1, j, k)) - one
3219  factlamheat = one / (prandtl * gm1)
3220  factturbheat = one / (prandtlturb * gm1)
3221 
3222  heatcoef = mul * factlamheat + mue * factturbheat
3223 
3224  ! Compute the gradients at the face by averaging the four
3225  ! nodal values.
3226 
3227  u_x = fourth * (ux(i, j - 1, k - 1) + ux(i, j, k - 1) &
3228  + ux(i, j - 1, k) + ux(i, j, k))
3229  u_y = fourth * (uy(i, j - 1, k - 1) + uy(i, j, k - 1) &
3230  + uy(i, j - 1, k) + uy(i, j, k))
3231  u_z = fourth * (uz(i, j - 1, k - 1) + uz(i, j, k - 1) &
3232  + uz(i, j - 1, k) + uz(i, j, k))
3233 
3234  v_x = fourth * (vx(i, j - 1, k - 1) + vx(i, j, k - 1) &
3235  + vx(i, j - 1, k) + vx(i, j, k))
3236  v_y = fourth * (vy(i, j - 1, k - 1) + vy(i, j, k - 1) &
3237  + vy(i, j - 1, k) + vy(i, j, k))
3238  v_z = fourth * (vz(i, j - 1, k - 1) + vz(i, j, k - 1) &
3239  + vz(i, j - 1, k) + vz(i, j, k))
3240 
3241  w_x = fourth * (wx(i, j - 1, k - 1) + wx(i, j, k - 1) &
3242  + wx(i, j - 1, k) + wx(i, j, k))
3243  w_y = fourth * (wy(i, j - 1, k - 1) + wy(i, j, k - 1) &
3244  + wy(i, j - 1, k) + wy(i, j, k))
3245  w_z = fourth * (wz(i, j - 1, k - 1) + wz(i, j, k - 1) &
3246  + wz(i, j - 1, k) + wz(i, j, k))
3247 
3248  q_x = fourth * (qx(i, j - 1, k - 1) + qx(i, j, k - 1) &
3249  + qx(i, j - 1, k) + qx(i, j, k))
3250  q_y = fourth * (qy(i, j - 1, k - 1) + qy(i, j, k - 1) &
3251  + qy(i, j - 1, k) + qy(i, j, k))
3252  q_z = fourth * (qz(i, j - 1, k - 1) + qz(i, j, k - 1) &
3253  + qz(i, j - 1, k) + qz(i, j, k))
3254 
3255  ! The gradients in the normal direction are corrected, such
3256  ! that no averaging takes places here.
3257  ! First determine the vector in the direction from the
3258  ! cell center i to cell center i+1.
3259 
3260  ssx = eighth * (x(i + 1, j - 1, k - 1, 1) - x(i - 1, j - 1, k - 1, 1) &
3261  + x(i + 1, j - 1, k, 1) - x(i - 1, j - 1, k, 1) &
3262  + x(i + 1, j, k - 1, 1) - x(i - 1, j, k - 1, 1) &
3263  + x(i + 1, j, k, 1) - x(i - 1, j, k, 1))
3264  ssy = eighth * (x(i + 1, j - 1, k - 1, 2) - x(i - 1, j - 1, k - 1, 2) &
3265  + x(i + 1, j - 1, k, 2) - x(i - 1, j - 1, k, 2) &
3266  + x(i + 1, j, k - 1, 2) - x(i - 1, j, k - 1, 2) &
3267  + x(i + 1, j, k, 2) - x(i - 1, j, k, 2))
3268  ssz = eighth * (x(i + 1, j - 1, k - 1, 3) - x(i - 1, j - 1, k - 1, 3) &
3269  + x(i + 1, j - 1, k, 3) - x(i - 1, j - 1, k, 3) &
3270  + x(i + 1, j, k - 1, 3) - x(i - 1, j, k - 1, 3) &
3271  + x(i + 1, j, k, 3) - x(i - 1, j, k, 3))
3272 
3273  ! Determine the length of this vector and create the
3274  ! unit normal.
3275 
3276  ss = one / sqrt(ssx * ssx + ssy * ssy + ssz * ssz)
3277  ssx = ss * ssx
3278  ssy = ss * ssy
3279  ssz = ss * ssz
3280 
3281  ! Correct the gradients.
3282 
3283  corr = u_x * ssx + u_y * ssy + u_z * ssz &
3284  - (w(i + 1, j, k, ivx) - w(i, j, k, ivx)) * ss
3285  u_x = u_x - corr * ssx
3286  u_y = u_y - corr * ssy
3287  u_z = u_z - corr * ssz
3288 
3289  corr = v_x * ssx + v_y * ssy + v_z * ssz &
3290  - (w(i + 1, j, k, ivy) - w(i, j, k, ivy)) * ss
3291  v_x = v_x - corr * ssx
3292  v_y = v_y - corr * ssy
3293  v_z = v_z - corr * ssz
3294 
3295  corr = w_x * ssx + w_y * ssy + w_z * ssz &
3296  - (w(i + 1, j, k, ivz) - w(i, j, k, ivz)) * ss
3297  w_x = w_x - corr * ssx
3298  w_y = w_y - corr * ssy
3299  w_z = w_z - corr * ssz
3300 
3301  corr = q_x * ssx + q_y * ssy + q_z * ssz &
3302  + (aa(i + 1, j, k) - aa(i, j, k)) * ss
3303  q_x = q_x - corr * ssx
3304  q_y = q_y - corr * ssy
3305  q_z = q_z - corr * ssz
3306 
3307  ! Compute the stress tensor and the heat flux vector.
3308  ! We remove the viscosity from the stress tensor (tau)
3309  ! to define tauS since we still need to separate between
3310  ! laminar and turbulent stress for QCR.
3311  ! Therefore, laminar tau = mue*tauS, turbulent
3312  ! tau = mue*tauS, and total tau = mut*tauS.
3313 
3314  fracdiv = twothird * (u_x + v_y + w_z)
3315 
3316  tauxxs = two * u_x - fracdiv
3317  tauyys = two * v_y - fracdiv
3318  tauzzs = two * w_z - fracdiv
3319 
3320  tauxys = u_y + v_x
3321  tauxzs = u_z + w_x
3322  tauyzs = v_z + w_y
3323 
3324  q_x = heatcoef * q_x
3325  q_y = heatcoef * q_y
3326  q_z = heatcoef * q_z
3327 
3328  ! Add QCR corrections if necessary
3329  if (useqcr) then
3330 
3331  ! In the QCR formulation, we add an extra term to the turbulent stress tensor:
3332  !
3333  ! tau_ij,QCR = tau_ij - e_ij
3334  !
3335  ! where, according to TMR website (http://turbmodels.larc.nasa.gov/spalart.html):
3336  !
3337  ! e_ij = Ccr1*(O_ik*tau_jk + O_jk*tau_ik)
3338  !
3339  ! We are computing O_ik as follows:
3340  !
3341  ! O_ik = 2*W_ik/den
3342  !
3343  ! Remember that the tau_ij in e_ij should use only the eddy viscosity!
3344 
3345  ! Compute denominator
3346  den = sqrt(u_x * u_x + u_y * u_y + u_z * u_z + &
3347  v_x * v_x + v_y * v_y + v_z * v_z + &
3348  w_x * w_x + w_y * w_y + w_z * w_z)
3349 
3350  ! Denominator should be limited to avoid division by zero in regions with
3351  ! no gradients
3352  den = max(den, xminn)
3353 
3354  ! Compute factor that will multiply all tensor components.
3355  ! Here we add the eddy viscosity that should multiply the stress tensor (tau)
3356  ! components as well.
3357  fact = mue * ccr1 / den
3358 
3359  ! Compute off-diagonal terms of vorticity tensor (we will ommit the 1/2)
3360  ! The diagonals of the vorticity tensor components are always zero
3361  wxy = u_y - v_x
3362  wxz = u_z - w_x
3363  wyz = v_z - w_y
3364  wyx = -wxy
3365  wzx = -wxz
3366  wzy = -wyz
3367 
3368  ! Compute the extra terms of the Boussinesq relation
3369  exx = fact * (wxy * tauxys + wxz * tauxzs) * two
3370  eyy = fact * (wyx * tauxys + wyz * tauyzs) * two
3371  ezz = fact * (wzx * tauxzs + wzy * tauyzs) * two
3372 
3373  exy = fact * (wxy * tauyys + wxz * tauyzs + &
3374  wyx * tauxxs + wyz * tauxzs)
3375  exz = fact * (wxy * tauyzs + wxz * tauzzs + &
3376  wzx * tauxxs + wzy * tauxys)
3377  eyz = fact * (wyx * tauxzs + wyz * tauzzs + &
3378  wzx * tauxys + wzy * tauyys)
3379 
3380  ! Apply the total viscosity to the stress tensor and add extra terms
3381  tauxx = mut * tauxxs - exx
3382  tauyy = mut * tauyys - eyy
3383  tauzz = mut * tauzzs - ezz
3384  tauxy = mut * tauxys - exy
3385  tauxz = mut * tauxzs - exz
3386  tauyz = mut * tauyzs - eyz
3387 
3388  else
3389 
3390  ! Just apply the total viscosity to the stress tensor
3391  tauxx = mut * tauxxs
3392  tauyy = mut * tauyys
3393  tauzz = mut * tauzzs
3394  tauxy = mut * tauxys
3395  tauxz = mut * tauxzs
3396  tauyz = mut * tauyzs
3397 
3398  end if
3399 
3400  ! Compute the average velocities for the face. Remember that
3401  ! the velocities are stored and not the momentum.
3402 
3403  ubar = half * (w(i, j, k, ivx) + w(i + 1, j, k, ivx))
3404  vbar = half * (w(i, j, k, ivy) + w(i + 1, j, k, ivy))
3405  wbar = half * (w(i, j, k, ivz) + w(i + 1, j, k, ivz))
3406 
3407  ! Compute the viscous fluxes for this i-face.
3408 
3409  fmx = tauxx * si(i, j, k, 1) + tauxy * si(i, j, k, 2) &
3410  + tauxz * si(i, j, k, 3)
3411  fmy = tauxy * si(i, j, k, 1) + tauyy * si(i, j, k, 2) &
3412  + tauyz * si(i, j, k, 3)
3413  fmz = tauxz * si(i, j, k, 1) + tauyz * si(i, j, k, 2) &
3414  + tauzz * si(i, j, k, 3)
3415  frhoe = (ubar * tauxx + vbar * tauxy + wbar * tauxz) * si(i, j, k, 1) &
3416  + (ubar * tauxy + vbar * tauyy + wbar * tauyz) * si(i, j, k, 2) &
3417  + (ubar * tauxz + vbar * tauyz + wbar * tauzz) * si(i, j, k, 3) &
3418  - q_x * si(i, j, k, 1) - q_y * si(i, j, k, 2) - q_z * si(i, j, k, 3)
3419 
3420  ! Update the residuals of cell i and i+1.
3421 
3422  fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
3423  fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
3424  fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
3425  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
3426 
3427  fw(i + 1, j, k, imx) = fw(i + 1, j, k, imx) + fmx
3428  fw(i + 1, j, k, imy) = fw(i + 1, j, k, imy) + fmy
3429  fw(i + 1, j, k, imz) = fw(i + 1, j, k, imz) + fmz
3430  fw(i + 1, j, k, irhoe) = fw(i + 1, j, k, irhoe) + frhoe
3431 
3432  ! Store the stress tensor and the heat flux vector if this
3433  ! face is part of a viscous subface. Both the cases i == 1
3434  ! and i == il must be tested.
3435 
3436  if (i == 1 .and. storewalltensor .and. &
3437  visciminpointer(j, k) > 0) then
3438  ! We need to index viscSubface with viscIminPointer(j,k)
3439  ! since Tapenade does not like temporary indexes
3440 
3441  viscsubface(visciminpointer(j, k))%tau(j, k, 1) = tauxx
3442  viscsubface(visciminpointer(j, k))%tau(j, k, 2) = tauyy
3443  viscsubface(visciminpointer(j, k))%tau(j, k, 3) = tauzz
3444  viscsubface(visciminpointer(j, k))%tau(j, k, 4) = tauxy
3445  viscsubface(visciminpointer(j, k))%tau(j, k, 5) = tauxz
3446  viscsubface(visciminpointer(j, k))%tau(j, k, 6) = tauyz
3447 
3448  viscsubface(visciminpointer(j, k))%q(j, k, 1) = q_x
3449  viscsubface(visciminpointer(j, k))%q(j, k, 2) = q_y
3450  viscsubface(visciminpointer(j, k))%q(j, k, 3) = q_z
3451  end if
3452 
3453  ! And the i == il case.
3454 
3455  if (i == il .and. storewalltensor .and. &
3456  viscimaxpointer(j, k) > 0) then
3457  ! We need to index viscSubface with viscImaxPointer(j,k)
3458  ! since Tapenade does not like temporary indexes
3459 
3460  viscsubface(viscimaxpointer(j, k))%tau(j, k, 1) = tauxx
3461  viscsubface(viscimaxpointer(j, k))%tau(j, k, 2) = tauyy
3462  viscsubface(viscimaxpointer(j, k))%tau(j, k, 3) = tauzz
3463  viscsubface(viscimaxpointer(j, k))%tau(j, k, 4) = tauxy
3464  viscsubface(viscimaxpointer(j, k))%tau(j, k, 5) = tauxz
3465  viscsubface(viscimaxpointer(j, k))%tau(j, k, 6) = tauyz
3466 
3467  viscsubface(viscimaxpointer(j, k))%q(j, k, 1) = q_x
3468  viscsubface(viscimaxpointer(j, k))%q(j, k, 2) = q_y
3469  viscsubface(viscimaxpointer(j, k))%q(j, k, 3) = q_z
3470  end if
3471 #ifdef TAPENADE_REVERSE
3472  end do
3473 #else
3474  end do
3475  end do
3476  end do
3477 #endif
3478  !$AD CHECKPOINT-END
3479  continue
3480  ! Possibly correct the wall shear stress.
3481  ! Wall function is not ADed
3482 #ifndef USE_TAPENADE
3483  call utauwf(rfilv)
3484 #endif
3485  end subroutine viscousflux
3486 
3487  subroutine viscousfluxapprox
3488  use constants
3489  use blockpointers
3490  use flowvarrefstate
3491  use inputphysics
3492  use iteration
3493  implicit none
3494  !
3495  ! Local parameter.
3496  !
3497  real(kind=realtype), parameter :: twothird = two * third
3498  !
3499  ! Local variables.
3500  !
3501  integer(kind=intType) :: i, j, k
3502  integer(kind=intType) :: ii, jj, kk
3503 
3504  real(kind=realtype) :: rfilv, por, mul, mue, mut, heatcoef
3505  real(kind=realtype) :: gm1, factlamheat, factturbheat
3506  real(kind=realtype) :: u_x, u_y, u_z, v_x, v_y, v_z, w_x, w_y, w_z
3507  real(kind=realtype) :: q_x, q_y, q_z, ubar, vbar, wbar
3508  real(kind=realtype) :: corr, ssx, ssy, ssz, ss, fracdiv
3509  real(kind=realtype) :: tauxx, tauyy, tauzz
3510  real(kind=realtype) :: tauxy, tauxz, tauyz
3511  real(kind=realtype) :: fmx, fmy, fmz, frhoe
3512  real(kind=realtype) :: dd
3513  logical :: correctForK
3514 
3515  mue = zero
3516  rfilv = rfil
3517 
3518  ! Viscous fluxes in the I-direction
3519 
3520  do k = 2, kl
3521  do j = 2, jl
3522  do i = 1, il
3523 
3524  ! Compute the vector from the center of cell i to cell i+1
3525  ssx = eighth * (x(i + 1, j - 1, k - 1, 1) - x(i - 1, j - 1, k - 1, 1) &
3526  + x(i + 1, j - 1, k, 1) - x(i - 1, j - 1, k, 1) &
3527  + x(i + 1, j, k - 1, 1) - x(i - 1, j, k - 1, 1) &
3528  + x(i + 1, j, k, 1) - x(i - 1, j, k, 1))
3529  ssy = eighth * (x(i + 1, j - 1, k - 1, 2) - x(i - 1, j - 1, k - 1, 2) &
3530  + x(i + 1, j - 1, k, 2) - x(i - 1, j - 1, k, 2) &
3531  + x(i + 1, j, k - 1, 2) - x(i - 1, j, k - 1, 2) &
3532  + x(i + 1, j, k, 2) - x(i - 1, j, k, 2))
3533  ssz = eighth * (x(i + 1, j - 1, k - 1, 3) - x(i - 1, j - 1, k - 1, 3) &
3534  + x(i + 1, j - 1, k, 3) - x(i - 1, j - 1, k, 3) &
3535  + x(i + 1, j, k - 1, 3) - x(i - 1, j, k - 1, 3) &
3536  + x(i + 1, j, k, 3) - x(i - 1, j, k, 3))
3537 
3538  ! And determine one/ length of vector squared
3539  ss = one / (ssx * ssx + ssy * ssy + ssz * ssz)
3540  ssx = ss * ssx
3541  ssy = ss * ssy
3542  ssz = ss * ssz
3543 
3544  ! Now compute each gradient
3545  dd = w(i + 1, j, k, ivx) - w(i, j, k, ivx)
3546  u_x = dd * ssx
3547  u_y = dd * ssy
3548  u_z = dd * ssz
3549 
3550  dd = w(i + 1, j, k, ivy) - w(i, j, k, ivy)
3551  v_x = dd * ssx
3552  v_y = dd * ssy
3553  v_z = dd * ssz
3554 
3555  dd = w(i + 1, j, k, ivz) - w(i, j, k, ivz)
3556  w_x = dd * ssx
3557  w_y = dd * ssy
3558  w_z = dd * ssz
3559 
3560  dd = aa(i + 1, j, k) - aa(i, j, k)
3561  q_x = -dd * ssx
3562  q_y = -dd * ssy
3563  q_z = -dd * ssz
3564 
3565  por = half * rfilv
3566  if (pori(i, j, k) == noflux) por = zero
3567 
3568  ! Compute the laminar and (if present) the eddy viscosities
3569  ! multiplied by the porosity. Compute the factor in front of
3570  ! the gradients of the speed of sound squared for the heat
3571  ! flux.
3572 
3573  mul = por * (rlv(i, j, k) + rlv(i + 1, j, k))
3574  if (eddymodel) mue = por * (rev(i, j, k) + rev(i + 1, j, k))
3575  mut = mul + mue
3576 
3577  gm1 = half * (gamma(i, j, k) + gamma(i + 1, j, k)) - one
3578  factlamheat = one / (prandtl * gm1)
3579  factturbheat = one / (prandtlturb * gm1)
3580 
3581  heatcoef = mul * factlamheat + mue * factturbheat
3582 
3583  ! Compute the stress tensor and the heat flux vector.
3584 
3585  fracdiv = twothird * (u_x + v_y + w_z)
3586 
3587  tauxx = mut * (two * u_x - fracdiv)
3588  tauyy = mut * (two * v_y - fracdiv)
3589  tauzz = mut * (two * w_z - fracdiv)
3590 
3591  tauxy = mut * (u_y + v_x)
3592  tauxz = mut * (u_z + w_x)
3593  tauyz = mut * (v_z + w_y)
3594 
3595  q_x = heatcoef * q_x
3596  q_y = heatcoef * q_y
3597  q_z = heatcoef * q_z
3598 
3599  ! Compute the average velocities for the face. Remember that
3600  ! the velocities are stored and not the momentum.
3601 
3602  ubar = half * (w(i, j, k, ivx) + w(i + 1, j, k, ivx))
3603  vbar = half * (w(i, j, k, ivy) + w(i + 1, j, k, ivy))
3604  wbar = half * (w(i, j, k, ivz) + w(i + 1, j, k, ivz))
3605 
3606  ! Compute the viscous fluxes for this i-face.
3607 
3608  fmx = tauxx * si(i, j, k, 1) + tauxy * si(i, j, k, 2) + tauxz * si(i, j, k, 3)
3609  fmy = tauxy * si(i, j, k, 1) + tauyy * si(i, j, k, 2) + tauyz * si(i, j, k, 3)
3610  fmz = tauxz * si(i, j, k, 1) + tauyz * si(i, j, k, 2) + tauzz * si(i, j, k, 3)
3611  frhoe = (ubar * tauxx + vbar * tauxy + wbar * tauxz) * si(i, j, k, 1) &
3612  + (ubar * tauxy + vbar * tauyy + wbar * tauyz) * si(i, j, k, 2) &
3613  + (ubar * tauxz + vbar * tauyz + wbar * tauzz) * si(i, j, k, 3) &
3614  - q_x * si(i, j, k, 1) - q_y * si(i, j, k, 2) - q_z * si(i, j, k, 3)
3615 
3616  ! Update the residuals of cell i and i+1.
3617 
3618  fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
3619  fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
3620  fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
3621  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
3622 
3623  fw(i + 1, j, k, imx) = fw(i + 1, j, k, imx) + fmx
3624  fw(i + 1, j, k, imy) = fw(i + 1, j, k, imy) + fmy
3625  fw(i + 1, j, k, imz) = fw(i + 1, j, k, imz) + fmz
3626  fw(i + 1, j, k, irhoe) = fw(i + 1, j, k, irhoe) + frhoe
3627 
3628  end do
3629  end do
3630  end do
3631 
3632  ! Viscous fluxes in the J-direction
3633 
3634  do k = 2, kl
3635  do j = 1, jl
3636  do i = 2, il
3637 
3638  ! Compute the vector from the center of cell j to cell j+1
3639  ssx = eighth * (x(i - 1, j + 1, k - 1, 1) - x(i - 1, j - 1, k - 1, 1) &
3640  + x(i - 1, j + 1, k, 1) - x(i - 1, j - 1, k, 1) &
3641  + x(i, j + 1, k - 1, 1) - x(i, j - 1, k - 1, 1) &
3642  + x(i, j + 1, k, 1) - x(i, j - 1, k, 1))
3643  ssy = eighth * (x(i - 1, j + 1, k - 1, 2) - x(i - 1, j - 1, k - 1, 2) &
3644  + x(i - 1, j + 1, k, 2) - x(i - 1, j - 1, k, 2) &
3645  + x(i, j + 1, k - 1, 2) - x(i, j - 1, k - 1, 2) &
3646  + x(i, j + 1, k, 2) - x(i, j - 1, k, 2))
3647  ssz = eighth * (x(i - 1, j + 1, k - 1, 3) - x(i - 1, j - 1, k - 1, 3) &
3648  + x(i - 1, j + 1, k, 3) - x(i - 1, j - 1, k, 3) &
3649  + x(i, j + 1, k - 1, 3) - x(i, j - 1, k - 1, 3) &
3650  + x(i, j + 1, k, 3) - x(i, j - 1, k, 3))
3651 
3652  ! And determine one/ length of vector squared
3653  ss = one / (ssx * ssx + ssy * ssy + ssz * ssz)
3654  ssx = ss * ssx
3655  ssy = ss * ssy
3656  ssz = ss * ssz
3657 
3658  ! Now compute each gradient
3659  dd = w(i, j + 1, k, ivx) - w(i, j, k, ivx)
3660  u_x = dd * ssx
3661  u_y = dd * ssy
3662  u_z = dd * ssz
3663 
3664  dd = w(i, j + 1, k, ivy) - w(i, j, k, ivy)
3665  v_x = dd * ssx
3666  v_y = dd * ssy
3667  v_z = dd * ssz
3668 
3669  dd = w(i, j + 1, k, ivz) - w(i, j, k, ivz)
3670  w_x = dd * ssx
3671  w_y = dd * ssy
3672  w_z = dd * ssz
3673 
3674  dd = aa(i, j + 1, k) - aa(i, j, k)
3675  q_x = -dd * ssx
3676  q_y = -dd * ssy
3677  q_z = -dd * ssz
3678 
3679  por = half * rfilv
3680  if (porj(i, j, k) == noflux) por = zero
3681 
3682  ! Compute the laminar and (if present) the eddy viscosities
3683  ! multiplied by the porosity. Compute the factor in front of
3684  ! the gradients of the speed of sound squared for the heat
3685  ! flux.
3686 
3687  mul = por * (rlv(i, j, k) + rlv(i, j + 1, k))
3688  if (eddymodel) mue = por * (rev(i, j, k) + rev(i, j + 1, k))
3689  mut = mul + mue
3690 
3691  gm1 = half * (gamma(i, j, k) + gamma(i, j + 1, k)) - one
3692  factlamheat = one / (prandtl * gm1)
3693  factturbheat = one / (prandtlturb * gm1)
3694 
3695  heatcoef = mul * factlamheat + mue * factturbheat
3696 
3697  ! Compute the stress tensor and the heat flux vector.
3698 
3699  fracdiv = twothird * (u_x + v_y + w_z)
3700 
3701  tauxx = mut * (two * u_x - fracdiv)
3702  tauyy = mut * (two * v_y - fracdiv)
3703  tauzz = mut * (two * w_z - fracdiv)
3704 
3705  tauxy = mut * (u_y + v_x)
3706  tauxz = mut * (u_z + w_x)
3707  tauyz = mut * (v_z + w_y)
3708 
3709  q_x = heatcoef * q_x
3710  q_y = heatcoef * q_y
3711  q_z = heatcoef * q_z
3712 
3713  ! Compute the average velocities for the face. Remember that
3714  ! the velocities are stored and not the momentum.
3715 
3716  ubar = half * (w(i, j, k, ivx) + w(i, j + 1, k, ivx))
3717  vbar = half * (w(i, j, k, ivy) + w(i, j + 1, k, ivy))
3718  wbar = half * (w(i, j, k, ivz) + w(i, j + 1, k, ivz))
3719 
3720  ! Compute the viscous fluxes for this j-face.
3721 
3722  fmx = tauxx * sj(i, j, k, 1) + tauxy * sj(i, j, k, 2) + tauxz * sj(i, j, k, 3)
3723  fmy = tauxy * sj(i, j, k, 1) + tauyy * sj(i, j, k, 2) + tauyz * sj(i, j, k, 3)
3724  fmz = tauxz * sj(i, j, k, 1) + tauyz * sj(i, j, k, 2) + tauzz * sj(i, j, k, 3)
3725  frhoe = (ubar * tauxx + vbar * tauxy + wbar * tauxz) * sj(i, j, k, 1) &
3726  + (ubar * tauxy + vbar * tauyy + wbar * tauyz) * sj(i, j, k, 2) &
3727  + (ubar * tauxz + vbar * tauyz + wbar * tauzz) * sj(i, j, k, 3) &
3728  - q_x * sj(i, j, k, 1) - q_y * sj(i, j, k, 2) - q_z * sj(i, j, k, 3)
3729 
3730  ! Update the residuals of cell j and j+1.
3731 
3732  fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
3733  fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
3734  fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
3735  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
3736 
3737  fw(i, j + 1, k, imx) = fw(i, j + 1, k, imx) + fmx
3738  fw(i, j + 1, k, imy) = fw(i, j + 1, k, imy) + fmy
3739  fw(i, j + 1, k, imz) = fw(i, j + 1, k, imz) + fmz
3740  fw(i, j + 1, k, irhoe) = fw(i, j + 1, k, irhoe) + frhoe
3741 
3742  end do
3743  end do
3744  end do
3745 
3746  ! Viscous fluxes in the K-direction
3747 
3748  do k = 1, kl
3749  do j = 2, jl
3750  do i = 2, il
3751 
3752  ! Compute the vector from the center of cell k to cell k+1
3753  ssx = eighth * (x(i - 1, j - 1, k + 1, 1) - x(i - 1, j - 1, k - 1, 1) &
3754  + x(i - 1, j, k + 1, 1) - x(i - 1, j, k - 1, 1) &
3755  + x(i, j - 1, k + 1, 1) - x(i, j - 1, k - 1, 1) &
3756  + x(i, j, k + 1, 1) - x(i, j, k - 1, 1))
3757  ssy = eighth * (x(i - 1, j - 1, k + 1, 2) - x(i - 1, j - 1, k - 1, 2) &
3758  + x(i - 1, j, k + 1, 2) - x(i - 1, j, k - 1, 2) &
3759  + x(i, j - 1, k + 1, 2) - x(i, j - 1, k - 1, 2) &
3760  + x(i, j, k + 1, 2) - x(i, j, k - 1, 2))
3761  ssz = eighth * (x(i - 1, j - 1, k + 1, 3) - x(i - 1, j - 1, k - 1, 3) &
3762  + x(i - 1, j, k + 1, 3) - x(i - 1, j, k - 1, 3) &
3763  + x(i, j - 1, k + 1, 3) - x(i, j - 1, k - 1, 3) &
3764  + x(i, j, k + 1, 3) - x(i, j, k - 1, 3))
3765  ! And determine one/ length of vector squared
3766  ss = one / (ssx * ssx + ssy * ssy + ssz * ssz)
3767  ssx = ss * ssx
3768  ssy = ss * ssy
3769  ssz = ss * ssz
3770 
3771  ! Now compute each gradient
3772  dd = w(i, j, k + 1, ivx) - w(i, j, k, ivx)
3773  u_x = dd * ssx
3774  u_y = dd * ssy
3775  u_z = dd * ssz
3776 
3777  dd = w(i, j, k + 1, ivy) - w(i, j, k, ivy)
3778  v_x = dd * ssx
3779  v_y = dd * ssy
3780  v_z = dd * ssz
3781 
3782  dd = w(i, j, k + 1, ivz) - w(i, j, k, ivz)
3783  w_x = dd * ssx
3784  w_y = dd * ssy
3785  w_z = dd * ssz
3786 
3787  dd = aa(i, j, k + 1) - aa(i, j, k)
3788  q_x = -dd * ssx
3789  q_y = -dd * ssy
3790  q_z = -dd * ssz
3791 
3792  por = half * rfilv
3793  if (pork(i, j, k) == noflux) por = zero
3794 
3795  ! Compute the laminar and (if present) the eddy viscosities
3796  ! multiplied by the porosity. Compute the factor in front of
3797  ! the gradients of the speed of sound squared for the heat
3798  ! flux.
3799 
3800  mul = por * (rlv(i, j, k) + rlv(i, j, k + 1))
3801  if (eddymodel) mue = por * (rev(i, j, k) + rev(i, j, k + 1))
3802  mut = mul + mue
3803 
3804  gm1 = half * (gamma(i, j, k) + gamma(i, j, k + 1)) - one
3805  factlamheat = one / (prandtl * gm1)
3806  factturbheat = one / (prandtlturb * gm1)
3807 
3808  heatcoef = mul * factlamheat + mue * factturbheat
3809 
3810  ! Compute the stress tensor and the heat flux vector.
3811 
3812  fracdiv = twothird * (u_x + v_y + w_z)
3813 
3814  tauxx = mut * (two * u_x - fracdiv)
3815  tauyy = mut * (two * v_y - fracdiv)
3816  tauzz = mut * (two * w_z - fracdiv)
3817 
3818  tauxy = mut * (u_y + v_x)
3819  tauxz = mut * (u_z + w_x)
3820  tauyz = mut * (v_z + w_y)
3821 
3822  q_x = heatcoef * q_x
3823  q_y = heatcoef * q_y
3824  q_z = heatcoef * q_z
3825 
3826  ! Compute the average velocities for the face. Remember that
3827  ! the velocities are stored and not the momentum.
3828 
3829  ubar = half * (w(i, j, k, ivx) + w(i, j, k + 1, ivx))
3830  vbar = half * (w(i, j, k, ivy) + w(i, j, k + 1, ivy))
3831  wbar = half * (w(i, j, k, ivz) + w(i, j, k + 1, ivz))
3832 
3833  ! Compute the viscous fluxes for this j-face.
3834 
3835  fmx = tauxx * sk(i, j, k, 1) + tauxy * sk(i, j, k, 2) + tauxz * sk(i, j, k, 3)
3836  fmy = tauxy * sk(i, j, k, 1) + tauyy * sk(i, j, k, 2) + tauyz * sk(i, j, k, 3)
3837  fmz = tauxz * sk(i, j, k, 1) + tauyz * sk(i, j, k, 2) + tauzz * sk(i, j, k, 3)
3838  frhoe = (ubar * tauxx + vbar * tauxy + wbar * tauxz) * sk(i, j, k, 1) &
3839  + (ubar * tauxy + vbar * tauyy + wbar * tauyz) * sk(i, j, k, 2) &
3840  + (ubar * tauxz + vbar * tauyz + wbar * tauzz) * sk(i, j, k, 3) &
3841  - q_x * sk(i, j, k, 1) - q_y * sk(i, j, k, 2) - q_z * sk(i, j, k, 3)
3842 
3843  ! Update the residuals of cell j and j+1.
3844 
3845  fw(i, j, k, imx) = fw(i, j, k, imx) - fmx
3846  fw(i, j, k, imy) = fw(i, j, k, imy) - fmy
3847  fw(i, j, k, imz) = fw(i, j, k, imz) - fmz
3848  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - frhoe
3849 
3850  fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) + fmx
3851  fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) + fmy
3852  fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) + fmz
3853  fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) + frhoe
3854 
3855  end do
3856  end do
3857  end do
3858 
3859  end subroutine viscousfluxapprox
3860 
3861  subroutine invisciddissfluxscalarapprox
3862  !
3863  ! inviscidDissFluxScalar computes the scalar artificial
3864  ! dissipation, see AIAA paper 81-1259, for a given block.
3865  ! Therefore it is assumed that the pointers in blockPointers
3866  ! already point to the correct block.
3867  !
3868  use blockpointers
3869  use cgnsgrid
3870  use constants
3871  use flowvarrefstate
3872  use inputdiscretization
3873  use inputiteration, only: usedisscontinuation, disscontmagnitude, disscontmidpoint, disscontsharpness
3874  use inputphysics
3875  use iteration
3876  implicit none
3877  !
3878  ! Local parameter.
3879  !
3880  real(kind=realtype), parameter :: dssmax = 0.25_realtype
3881  !
3882  ! Local variables.
3883  !
3884  integer(kind=intType) :: i, j, k, ind
3885 
3886  real(kind=realtype) :: sslim, rhoi
3887  real(kind=realtype) :: sfil, fis2, fis4
3888  real(kind=realtype) :: ppor, rrad, dis2
3889  real(kind=realtype) :: dss1, dss2, ddw, fs
3890 
3891  ! Check if rFil == 0. If so, the dissipative flux needs not to
3892  ! be computed.
3893 
3894  if (abs(rfil) < thresholdreal) return
3895 
3896  ! Determine the variables used to compute the switch.
3897  ! For the inviscid case this is the pressure; for the viscous
3898  ! case it is the entropy.
3899 
3900  select case (equations)
3901  case (eulerequations)
3902 
3903  ! Inviscid case. Pressure switch is based on the pressure.
3904  ! Also set the value of sslim. To be fully consistent this
3905  ! must have the dimension of pressure and it is therefore
3906  ! set to a fraction of the free stream value.
3907 
3908  sslim = 0.001_realtype * pinfcorr
3909 
3910  !===============================================================
3911 
3912  case (nsequations, ransequations)
3913 
3914  ! Viscous case. Pressure switch is based on the entropy.
3915  ! Also set the value of sslim. To be fully consistent this
3916  ! must have the dimension of entropy and it is therefore
3917  ! set to a fraction of the free stream value.
3918 
3919  sslim = 0.001_realtype * pinfcorr / (rhoinf**gammainf)
3920 
3921  end select
3922 
3923  ! Set the dissipation constants for the scheme.
3924  ! rFil and sFil are fractions used by the Runge-Kutta solver to compute residuals at intermediate steps.
3925  ! This means that fis2 and fis4 will be some fraction of vis2 and vis4, respectively.
3926  ! For other solvers, rFil==1, sFil==0, fis2==vis2, and fis4==vis4.
3927 
3928  ! The sigmoid function used for dissipation-based continuation is described in Eq. 28 and Eq. 29 from the paper:
3929  ! "Improving the Performance of a Compressible RANS Solver for Low and High Mach Number Flows" (Seraj2022c).
3930  ! The options documentation also has information on the parameters in this formulation.
3931  if (usedisscontinuation) then
3932  fis2 = rfil * (vis2 + disscontmagnitude / &
3933  (1 + exp(-disscontsharpness * (log10(totalr / totalr0) + disscontmidpoint))))
3934  else
3935  fis2 = rfil * vis2
3936  end if
3937  fis4 = rfil * vis4
3938  sfil = one - rfil
3939 
3940  ! Replace the total energy by rho times the total enthalpy.
3941  ! In this way the numerical solution is total enthalpy preserving
3942  ! for the steady Euler equations. Also replace the velocities by
3943  ! the momentum. Only done for the entries used in the
3944  ! discretization, i.e. ignore the corner halo's.
3945 
3946  do k = 0, kb
3947  do j = 2, jl
3948  do i = 2, il
3949  w(i, j, k, ivx) = w(i, j, k, irho) * w(i, j, k, ivx)
3950  w(i, j, k, ivy) = w(i, j, k, irho) * w(i, j, k, ivy)
3951  w(i, j, k, ivz) = w(i, j, k, irho) * w(i, j, k, ivz)
3952  w(i, j, k, irhoe) = w(i, j, k, irhoe) + p(i, j, k)
3953  end do
3954  end do
3955  end do
3956 
3957  do k = 2, kl
3958  do j = 2, jl
3959  w(0, j, k, ivx) = w(0, j, k, irho) * w(0, j, k, ivx)
3960  w(0, j, k, ivy) = w(0, j, k, irho) * w(0, j, k, ivy)
3961  w(0, j, k, ivz) = w(0, j, k, irho) * w(0, j, k, ivz)
3962  w(0, j, k, irhoe) = w(0, j, k, irhoe) + p(0, j, k)
3963 
3964  w(1, j, k, ivx) = w(1, j, k, irho) * w(1, j, k, ivx)
3965  w(1, j, k, ivy) = w(1, j, k, irho) * w(1, j, k, ivy)
3966  w(1, j, k, ivz) = w(1, j, k, irho) * w(1, j, k, ivz)
3967  w(1, j, k, irhoe) = w(1, j, k, irhoe) + p(1, j, k)
3968 
3969  w(ie, j, k, ivx) = w(ie, j, k, irho) * w(ie, j, k, ivx)
3970  w(ie, j, k, ivy) = w(ie, j, k, irho) * w(ie, j, k, ivy)
3971  w(ie, j, k, ivz) = w(ie, j, k, irho) * w(ie, j, k, ivz)
3972  w(ie, j, k, irhoe) = w(ie, j, k, irhoe) + p(ie, j, k)
3973 
3974  w(ib, j, k, ivx) = w(ib, j, k, irho) * w(ib, j, k, ivx)
3975  w(ib, j, k, ivy) = w(ib, j, k, irho) * w(ib, j, k, ivy)
3976  w(ib, j, k, ivz) = w(ib, j, k, irho) * w(ib, j, k, ivz)
3977  w(ib, j, k, irhoe) = w(ib, j, k, irhoe) + p(ib, j, k)
3978  end do
3979  end do
3980 
3981  do k = 2, kl
3982  do i = 2, il
3983  w(i, 0, k, ivx) = w(i, 0, k, irho) * w(i, 0, k, ivx)
3984  w(i, 0, k, ivy) = w(i, 0, k, irho) * w(i, 0, k, ivy)
3985  w(i, 0, k, ivz) = w(i, 0, k, irho) * w(i, 0, k, ivz)
3986  w(i, 0, k, irhoe) = w(i, 0, k, irhoe) + p(i, 0, k)
3987 
3988  w(i, 1, k, ivx) = w(i, 1, k, irho) * w(i, 1, k, ivx)
3989  w(i, 1, k, ivy) = w(i, 1, k, irho) * w(i, 1, k, ivy)
3990  w(i, 1, k, ivz) = w(i, 1, k, irho) * w(i, 1, k, ivz)
3991  w(i, 1, k, irhoe) = w(i, 1, k, irhoe) + p(i, 1, k)
3992 
3993  w(i, je, k, ivx) = w(i, je, k, irho) * w(i, je, k, ivx)
3994  w(i, je, k, ivy) = w(i, je, k, irho) * w(i, je, k, ivy)
3995  w(i, je, k, ivz) = w(i, je, k, irho) * w(i, je, k, ivz)
3996  w(i, je, k, irhoe) = w(i, je, k, irhoe) + p(i, je, k)
3997 
3998  w(i, jb, k, ivx) = w(i, jb, k, irho) * w(i, jb, k, ivx)
3999  w(i, jb, k, ivy) = w(i, jb, k, irho) * w(i, jb, k, ivy)
4000  w(i, jb, k, ivz) = w(i, jb, k, irho) * w(i, jb, k, ivz)
4001  w(i, jb, k, irhoe) = w(i, jb, k, irhoe) + p(i, jb, k)
4002  end do
4003  end do
4004 
4005  ! Initialize the dissipative residual to a certain times,
4006  ! possibly zero, the previously stored value. Owned cells
4007  ! only, because the halo values do not matter.
4008 
4009  do k = 2, kl
4010  do j = 2, jl
4011  do i = 2, il
4012  fw(i, j, k, irho) = sfil * fw(i, j, k, irho)
4013  fw(i, j, k, imx) = sfil * fw(i, j, k, imx)
4014  fw(i, j, k, imy) = sfil * fw(i, j, k, imy)
4015  fw(i, j, k, imz) = sfil * fw(i, j, k, imz)
4016  fw(i, j, k, irhoe) = sfil * fw(i, j, k, irhoe)
4017  end do
4018  end do
4019  end do
4020  !
4021  ! Dissipative fluxes in the i-direction.
4022  !
4023  do k = 2, kl
4024  do j = 2, jl
4025 
4026  ! Compute the pressure sensor in the first cell, which
4027  ! is a halo cell.
4028 
4029  dss1 = abs((shocksensor(2, j, k) - two * shocksensor(1, j, k) + shocksensor(0, j, k)) &
4030  / (shocksensor(2, j, k) + two * shocksensor(1, j, k) + shocksensor(0, j, k) + sslim))
4031 
4032  ! Loop in i-direction.
4033 
4034  do i = 1, il
4035 
4036  ! Compute the pressure sensor in the cell to the right
4037  ! of the face.
4038 
4039  dss2 = abs((shocksensor(i + 2, j, k) - two * shocksensor(i + 1, j, k) + shocksensor(i, j, k)) &
4040  / (shocksensor(i + 2, j, k) + two * shocksensor(i + 1, j, k) + &
4041  shocksensor(i, j, k) + sslim))
4042 
4043  ! Compute the dissipation coefficients for this face.
4044 
4045  ppor = zero
4046  if (pori(i, j, k) == normalflux) ppor = half
4047  rrad = ppor * (radi(i, j, k) + radi(i + 1, j, k))
4048 
4049  ! Modification for FD Preconditioner Note: This lumping
4050  ! actually still results in a greater than 3 cell stencil
4051  ! in any direction. Since this seems to work slightly
4052  ! better than the dis2=sigma*fis4*rrad, we will just use
4053  ! a 5-cell stencil for doing the PC
4054 
4055  dis2 = fis2 * rrad * min(dssmax, max(dss1, dss2)) + sigma * fis4 * rrad
4056 
4057  ! Compute and scatter the dissipative flux.
4058  ! Density. Store it in the mass flow of the
4059  ! appropriate sliding mesh interface.
4060 
4061  ddw = w(i + 1, j, k, irho) - w(i, j, k, irho)
4062  fs = dis2 * ddw
4063 
4064  fw(i + 1, j, k, irho) = fw(i + 1, j, k, irho) + fs
4065  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
4066 
4067  ! X-momentum.
4068 
4069  ddw = w(i + 1, j, k, ivx) - w(i, j, k, ivx)
4070  fs = dis2 * ddw
4071 
4072  fw(i + 1, j, k, imx) = fw(i + 1, j, k, imx) + fs
4073  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
4074 
4075  ! Y-momentum.
4076 
4077  ddw = w(i + 1, j, k, ivy) - w(i, j, k, ivy)
4078  fs = dis2 * ddw
4079 
4080  fw(i + 1, j, k, imy) = fw(i + 1, j, k, imy) + fs
4081  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
4082 
4083  ! Z-momentum.
4084 
4085  ddw = w(i + 1, j, k, ivz) - w(i, j, k, ivz)
4086  fs = dis2 * ddw
4087 
4088  fw(i + 1, j, k, imz) = fw(i + 1, j, k, imz) + fs
4089  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
4090 
4091  ! Energy.
4092 
4093  ddw = w(i + 1, j, k, irhoe) - w(i, j, k, irhoe)
4094  fs = dis2 * ddw
4095 
4096  fw(i + 1, j, k, irhoe) = fw(i + 1, j, k, irhoe) + fs
4097  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
4098 
4099  ! Set dss1 to dss2 for the next face.
4100 
4101  dss1 = dss2
4102 
4103  end do
4104  end do
4105  end do
4106  !
4107  ! Dissipative fluxes in the j-direction.
4108  !
4109  do k = 2, kl
4110  do i = 2, il
4111 
4112  ! Compute the pressure sensor in the first cell, which
4113  ! is a halo cell.
4114 
4115  dss1 = abs((shocksensor(i, 2, k) - two * shocksensor(i, 1, k) + shocksensor(i, 0, k)) &
4116  / (shocksensor(i, 2, k) + two * shocksensor(i, 1, k) + shocksensor(i, 0, k) + sslim))
4117 
4118  ! Loop in j-direction.
4119 
4120  do j = 1, jl
4121 
4122  ! Compute the pressure sensor in the cell to the right
4123  ! of the face.
4124 
4125  dss2 = abs((shocksensor(i, j + 2, k) - two * shocksensor(i, j + 1, k) + shocksensor(i, j, k)) &
4126  / (shocksensor(i, j + 2, k) + two * shocksensor(i, j + 1, k) + &
4127  shocksensor(i, j, k) + sslim))
4128 
4129  ! Compute the dissipation coefficients for this face.
4130 
4131  ppor = zero
4132  if (porj(i, j, k) == normalflux) ppor = half
4133  rrad = ppor * (radj(i, j, k) + radj(i, j + 1, k))
4134 
4135  ! Modification for FD Preconditioner
4136  dis2 = fis2 * rrad * min(dssmax, max(dss1, dss2)) + sigma * fis4 * rrad
4137 
4138  ! Compute and scatter the dissipative flux.
4139  ! Density. Store it in the mass flow of the
4140  ! appropriate sliding mesh interface.
4141 
4142  ddw = w(i, j + 1, k, irho) - w(i, j, k, irho)
4143  fs = dis2 * ddw
4144 
4145  fw(i, j + 1, k, irho) = fw(i, j + 1, k, irho) + fs
4146  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
4147 
4148  ! X-momentum.
4149 
4150  ddw = w(i, j + 1, k, ivx) - w(i, j, k, ivx)
4151  fs = dis2 * ddw
4152 
4153  fw(i, j + 1, k, imx) = fw(i, j + 1, k, imx) + fs
4154  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
4155 
4156  ! Y-momentum.
4157 
4158  ddw = w(i, j + 1, k, ivy) - w(i, j, k, ivy)
4159  fs = dis2 * ddw
4160 
4161  fw(i, j + 1, k, imy) = fw(i, j + 1, k, imy) + fs
4162  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
4163 
4164  ! Z-momentum.
4165 
4166  ddw = w(i, j + 1, k, ivz) - w(i, j, k, ivz)
4167  fs = dis2 * ddw
4168 
4169  fw(i, j + 1, k, imz) = fw(i, j + 1, k, imz) + fs
4170  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
4171 
4172  ! Energy.
4173 
4174  ddw = w(i, j + 1, k, irhoe) - w(i, j, k, irhoe)
4175  fs = dis2 * ddw
4176 
4177  fw(i, j + 1, k, irhoe) = fw(i, j + 1, k, irhoe) + fs
4178  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
4179 
4180  ! Set dss1 to dss2 for the next face.
4181 
4182  dss1 = dss2
4183 
4184  end do
4185  end do
4186  end do
4187  !
4188  ! Dissipative fluxes in the k-direction.
4189  !
4190  do j = 2, jl
4191  do i = 2, il
4192 
4193  ! Compute the pressure sensor in the first cell, which
4194  ! is a halo cell.
4195 
4196  dss1 = abs((shocksensor(i, j, 2) - two * shocksensor(i, j, 1) + shocksensor(i, j, 0)) &
4197  / (shocksensor(i, j, 2) + two * shocksensor(i, j, 1) + shocksensor(i, j, 0) + sslim))
4198 
4199  ! Loop in k-direction.
4200 
4201  do k = 1, kl
4202 
4203  ! Compute the pressure sensor in the cell to the right
4204  ! of the face.
4205 
4206  dss2 = abs((shocksensor(i, j, k + 2) - two * shocksensor(i, j, k + 1) + shocksensor(i, j, k)) &
4207  / (shocksensor(i, j, k + 2) + two * shocksensor(i, j, k + 1) + &
4208  shocksensor(i, j, k) + sslim))
4209 
4210  ! Compute the dissipation coefficients for this face.
4211 
4212  ppor = zero
4213  if (pork(i, j, k) == normalflux) ppor = half
4214  rrad = ppor * (radk(i, j, k) + radk(i, j, k + 1))
4215 
4216  ! Modification for FD Preconditioner
4217  dis2 = fis2 * rrad * min(dssmax, max(dss1, dss2)) + sigma * fis4 * rrad
4218 
4219  ! Compute and scatter the dissipative flux.
4220  ! Density. Store it in the mass flow of the
4221  ! appropriate sliding mesh interface.
4222 
4223  ddw = w(i, j, k + 1, irho) - w(i, j, k, irho)
4224  fs = dis2 * ddw
4225 
4226  fw(i, j, k + 1, irho) = fw(i, j, k + 1, irho) + fs
4227  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
4228 
4229  ! X-momentum.
4230 
4231  ddw = w(i, j, k + 1, ivx) - w(i, j, k, ivx)
4232  fs = dis2 * ddw
4233 
4234  fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) + fs
4235  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
4236 
4237  ! Y-momentum.
4238 
4239  ddw = w(i, j, k + 1, ivy) - w(i, j, k, ivy)
4240  fs = dis2 * ddw
4241 
4242  fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) + fs
4243  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
4244 
4245  ! Z-momentum.
4246 
4247  ddw = w(i, j, k + 1, ivz) - w(i, j, k, ivz)
4248  fs = dis2 * ddw
4249 
4250  fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) + fs
4251  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
4252 
4253  ! Energy.
4254 
4255  ddw = w(i, j, k + 1, irhoe) - w(i, j, k, irhoe)
4256  fs = dis2 * ddw
4257 
4258  fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) + fs
4259  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
4260 
4261  ! Set dss1 to dss2 for the next face.
4262 
4263  dss1 = dss2
4264 
4265  end do
4266  end do
4267  end do
4268 
4269  ! Replace rho times the total enthalpy by the total energy and
4270  ! store the velocities again instead of the momentum. Only for
4271  ! those entries that have been altered, i.e. ignore the
4272  ! corner halo's.
4273 
4274  do k = 0, kb
4275  do j = 2, jl
4276  do i = 2, il
4277  rhoi = one / w(i, j, k, irho)
4278  w(i, j, k, ivx) = w(i, j, k, ivx) * rhoi
4279  w(i, j, k, ivy) = w(i, j, k, ivy) * rhoi
4280  w(i, j, k, ivz) = w(i, j, k, ivz) * rhoi
4281  w(i, j, k, irhoe) = w(i, j, k, irhoe) - p(i, j, k)
4282  end do
4283  end do
4284  end do
4285 
4286  do k = 2, kl
4287  do j = 2, jl
4288  rhoi = one / w(0, j, k, irho)
4289  w(0, j, k, ivx) = w(0, j, k, ivx) * rhoi
4290  w(0, j, k, ivy) = w(0, j, k, ivy) * rhoi
4291  w(0, j, k, ivz) = w(0, j, k, ivz) * rhoi
4292  w(0, j, k, irhoe) = w(0, j, k, irhoe) - p(0, j, k)
4293 
4294  rhoi = one / w(1, j, k, irho)
4295  w(1, j, k, ivx) = w(1, j, k, ivx) * rhoi
4296  w(1, j, k, ivy) = w(1, j, k, ivy) * rhoi
4297  w(1, j, k, ivz) = w(1, j, k, ivz) * rhoi
4298  w(1, j, k, irhoe) = w(1, j, k, irhoe) - p(1, j, k)
4299 
4300  rhoi = one / w(ie, j, k, irho)
4301  w(ie, j, k, ivx) = w(ie, j, k, ivx) * rhoi
4302  w(ie, j, k, ivy) = w(ie, j, k, ivy) * rhoi
4303  w(ie, j, k, ivz) = w(ie, j, k, ivz) * rhoi
4304  w(ie, j, k, irhoe) = w(ie, j, k, irhoe) - p(ie, j, k)
4305 
4306  rhoi = one / w(ib, j, k, irho)
4307  w(ib, j, k, ivx) = w(ib, j, k, ivx) * rhoi
4308  w(ib, j, k, ivy) = w(ib, j, k, ivy) * rhoi
4309  w(ib, j, k, ivz) = w(ib, j, k, ivz) * rhoi
4310  w(ib, j, k, irhoe) = w(ib, j, k, irhoe) - p(ib, j, k)
4311  end do
4312  end do
4313 
4314  do k = 2, kl
4315  do i = 2, il
4316  rhoi = one / w(i, 0, k, irho)
4317  w(i, 0, k, ivx) = w(i, 0, k, ivx) * rhoi
4318  w(i, 0, k, ivy) = w(i, 0, k, ivy) * rhoi
4319  w(i, 0, k, ivz) = w(i, 0, k, ivz) * rhoi
4320  w(i, 0, k, irhoe) = w(i, 0, k, irhoe) - p(i, 0, k)
4321 
4322  rhoi = one / w(i, 1, k, irho)
4323  w(i, 1, k, ivx) = w(i, 1, k, ivx) * rhoi
4324  w(i, 1, k, ivy) = w(i, 1, k, ivy) * rhoi
4325  w(i, 1, k, ivz) = w(i, 1, k, ivz) * rhoi
4326  w(i, 1, k, irhoe) = w(i, 1, k, irhoe) - p(i, 1, k)
4327 
4328  rhoi = one / w(i, je, k, irho)
4329  w(i, je, k, ivx) = w(i, je, k, ivx) * rhoi
4330  w(i, je, k, ivy) = w(i, je, k, ivy) * rhoi
4331  w(i, je, k, ivz) = w(i, je, k, ivz) * rhoi
4332  w(i, je, k, irhoe) = w(i, je, k, irhoe) - p(i, je, k)
4333 
4334  rhoi = one / w(i, jb, k, irho)
4335  w(i, jb, k, ivx) = w(i, jb, k, ivx) * rhoi
4336  w(i, jb, k, ivy) = w(i, jb, k, ivy) * rhoi
4337  w(i, jb, k, ivz) = w(i, jb, k, ivz) * rhoi
4338  w(i, jb, k, irhoe) = w(i, jb, k, irhoe) - p(i, jb, k)
4339  end do
4340  end do
4341 
4342  end subroutine invisciddissfluxscalarapprox
4343 
4344  subroutine invisciddissfluxmatrixapprox
4345  !
4346  ! inviscidDissFluxMatrix computes the matrix artificial
4347  ! dissipation term. Instead of the spectral radius, as used in
4348  ! the scalar dissipation scheme, the absolute value of the flux
4349  ! jacobian is used. This leads to a less diffusive and
4350  ! consequently more accurate scheme. It is assumed that the
4351  ! pointers in blockPointers already point to the correct block.
4352  !
4353  use blockpointers
4354  use cgnsgrid
4355  use constants
4356  use flowvarrefstate
4357  use inputdiscretization
4358  use inputphysics
4359  use iteration
4360  use utils, only: getcorrectfork
4361  implicit none
4362  !
4363  ! Local parameters.
4364  !
4365  real(kind=realtype), parameter :: dpmax = 0.25_realtype
4366  real(kind=realtype), parameter :: epsacoustic = 0.25_realtype
4367  real(kind=realtype), parameter :: epsshear = 0.025_realtype
4368  real(kind=realtype), parameter :: omega = 0.5_realtype
4369  real(kind=realtype), parameter :: oneminomega = one - omega
4370  !
4371  ! Local variables.
4372  !
4373  integer(kind=intType) :: i, j, k, ind
4374 
4375  real(kind=realtype) :: plim, sface
4376  real(kind=realtype) :: sfil, fis2, fis4
4377  real(kind=realtype) :: gammaavg, gm1, ovgm1, gm53
4378  real(kind=realtype) :: ppor, rrad, dis2
4379  real(kind=realtype) :: dp1, dp2, ddw, tmp, fs
4380  real(kind=realtype) :: dr, dru, drv, drw, dre, drk, sx, sy, sz
4381  real(kind=realtype) :: uavg, vavg, wavg, a2avg, aavg, havg
4382  real(kind=realtype) :: alphaavg, unavg, ovaavg, ova2avg
4383  real(kind=realtype) :: kavg, lam1, lam2, lam3, area
4384  real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
4385  logical :: correctForK
4386 
4387  ! Check if rFil == 0. If so, the dissipative flux needs not to
4388  ! be computed.
4389 
4390  if (abs(rfil) < thresholdreal) return
4391 
4392  ! Set the value of plim. To be fully consistent this must have
4393  ! the dimension of a pressure. Therefore a fraction of pInfCorr
4394  ! is used.
4395 
4396  plim = 0.001_realtype * pinfcorr
4397 
4398  ! Determine whether or not the total energy must be corrected
4399  ! for the presence of the turbulent kinetic energy.
4400 
4401  correctfork = getcorrectfork()
4402 
4403  ! Initialize sface to zero. This value will be used if the
4404  ! block is not moving.
4405 
4406  sface = zero
4407 
4408  ! Set a couple of constants for the scheme.
4409 
4410  fis2 = rfil * vis2
4411  fis4 = rfil * vis4
4412  sfil = one - rfil
4413 
4414  ! Initialize the dissipative residual to a certain times,
4415  ! possibly zero, the previously stored value. Owned cells
4416  ! only, because the halo values do not matter.
4417 
4418  do k = 2, kl
4419  do j = 2, jl
4420  do i = 2, il
4421  fw(i, j, k, irho) = sfil * fw(i, j, k, irho)
4422  fw(i, j, k, imx) = sfil * fw(i, j, k, imx)
4423  fw(i, j, k, imy) = sfil * fw(i, j, k, imy)
4424  fw(i, j, k, imz) = sfil * fw(i, j, k, imz)
4425  fw(i, j, k, irhoe) = sfil * fw(i, j, k, irhoe)
4426  end do
4427  end do
4428  end do
4429 
4430  !
4431  ! Dissipative fluxes in the i-direction.
4432  !
4433  do k = 2, kl
4434  do j = 2, jl
4435 
4436  ! Compute the pressure sensor in the first cell, which
4437  ! is a halo cell.
4438 
4439  dp1 = abs((shocksensor(2, j, k) - two * shocksensor(1, j, k) + shocksensor(0, j, k)) &
4440  / (omega * (shocksensor(2, j, k) + two * shocksensor(1, j, k) + shocksensor(0, j, k)) &
4441  + oneminomega * (abs(shocksensor(2, j, k) - shocksensor(1, j, k)) &
4442  + abs(shocksensor(1, j, k) - shocksensor(0, j, k))) + plim))
4443 
4444  ! Loop in i-direction.
4445 
4446  do i = 1, il
4447 
4448  ! Compute the pressure sensor in the cell to the right
4449  ! of the face.
4450 
4451  dp2 = abs((shocksensor(i + 2, j, k) - two * shocksensor(i + 1, j, k) + shocksensor(i, j, k)) &
4452  / (omega * (shocksensor(i + 2, j, k) + &
4453  two * shocksensor(i + 1, j, k) + shocksensor(i, j, k)) &
4454  + oneminomega * (abs(shocksensor(i + 2, j, k) - shocksensor(i + 1, j, k)) &
4455  + abs(shocksensor(i + 1, j, k) - shocksensor(i, j, k))) + plim))
4456 
4457  ! Compute the dissipation coefficients for this face.
4458 
4459  ppor = zero
4460  if (pori(i, j, k) == normalflux) ppor = one
4461 
4462  dis2 = fis2 * ppor * min(dpmax, max(dp1, dp2)) + sigma * fis4 * ppor
4463 
4464  ! Construct the vector of the first and third differences
4465  ! multiplied by the appropriate constants.
4466 
4467  ddw = w(i + 1, j, k, irho) - w(i, j, k, irho)
4468  dr = dis2 * ddw
4469 
4470  ddw = w(i + 1, j, k, irho) * w(i + 1, j, k, ivx) &
4471  - w(i, j, k, irho) * w(i, j, k, ivx)
4472  dru = dis2 * ddw
4473 
4474  ddw = w(i + 1, j, k, irho) * w(i + 1, j, k, ivy) &
4475  - w(i, j, k, irho) * w(i, j, k, ivy)
4476  drv = dis2 * ddw
4477 
4478  ddw = w(i + 1, j, k, irho) * w(i + 1, j, k, ivz) &
4479  - w(i, j, k, irho) * w(i, j, k, ivz)
4480  drw = dis2 * ddw
4481 
4482  ddw = w(i + 1, j, k, irhoe) - w(i, j, k, irhoe)
4483  dre = dis2 * ddw
4484 
4485  ! In case a k-equation is present, compute the difference
4486  ! of rhok and store the average value of k. If not present,
4487  ! set both these values to zero, such that later on no
4488  ! decision needs to be made anymore.
4489 
4490  if (correctfork) then
4491  ddw = w(i + 1, j, k, irho) * w(i + 1, j, k, itu1) &
4492  - w(i, j, k, irho) * w(i, j, k, itu1)
4493  drk = dis2 * ddw
4494 
4495  kavg = half * (w(i, j, k, itu1) + w(i + 1, j, k, itu1))
4496  else
4497  drk = zero
4498  kavg = zero
4499  end if
4500 
4501  ! Compute the average value of gamma and compute some
4502  ! expressions in which it occurs.
4503 
4504  gammaavg = half * (gamma(i + 1, j, k) + gamma(i, j, k))
4505  gm1 = gammaavg - one
4506  ovgm1 = one / gm1
4507  gm53 = gammaavg - five * third
4508 
4509  ! Compute the average state at the interface.
4510 
4511  uavg = half * (w(i + 1, j, k, ivx) + w(i, j, k, ivx))
4512  vavg = half * (w(i + 1, j, k, ivy) + w(i, j, k, ivy))
4513  wavg = half * (w(i + 1, j, k, ivz) + w(i, j, k, ivz))
4514  a2avg = half * (gamma(i + 1, j, k) * p(i + 1, j, k) / w(i + 1, j, k, irho) &
4515  + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
4516 
4517  sx = si(i, j, k, 1); sy = si(i, j, k, 2); sz = si(i, j, k, 3)
4518  area = sqrt(sx**2 + sy**2 + sz**2)
4519  tmp = one / max(1.e-25_realtype, area)
4520  sx = sx * tmp
4521  sy = sy * tmp
4522  sz = sz * tmp
4523 
4524  alphaavg = half * (uavg**2 + vavg**2 + wavg**2)
4525  havg = alphaavg + ovgm1 * (a2avg - gm53 * kavg)
4526  aavg = sqrt(a2avg)
4527  unavg = uavg * sx + vavg * sy + wavg * sz
4528  ovaavg = one / aavg
4529  ova2avg = one / a2avg
4530 
4531  ! The mesh velocity if the face is moving. It must be
4532  ! divided by the area to obtain a true velocity.
4533 
4534  if (addgridvelocities) sface = sfacei(i, j, k) * tmp
4535 
4536  ! Compute the absolute values of the three eigenvalues
4537  ! and make sure they don't become zero by cutting them
4538  ! off to a certain minimum.
4539 
4540  lam1 = abs(unavg - sface + aavg)
4541  lam2 = abs(unavg - sface - aavg)
4542  lam3 = abs(unavg - sface)
4543 
4544  rrad = lam3 + aavg
4545 
4546  lam1 = max(lam1, epsacoustic * rrad)
4547  lam2 = max(lam2, epsacoustic * rrad)
4548  lam3 = max(lam3, epsshear * rrad)
4549 
4550  ! Multiply the eigenvalues by the area to obtain
4551  ! the correct values for the dissipation term.
4552 
4553  lam1 = lam1 * area
4554  lam2 = lam2 * area
4555  lam3 = lam3 * area
4556 
4557  ! Some abbreviations, which occur quite often in the
4558  ! dissipation terms.
4559 
4560  abv1 = half * (lam1 + lam2)
4561  abv2 = half * (lam1 - lam2)
4562  abv3 = abv1 - lam3
4563 
4564  abv4 = gm1 * (alphaavg * dr - uavg * dru - vavg * drv &
4565  - wavg * drw + dre) - gm53 * drk
4566  abv5 = sx * dru + sy * drv + sz * drw - unavg * dr
4567 
4568  abv6 = abv3 * abv4 * ova2avg + abv2 * abv5 * ovaavg
4569  abv7 = abv2 * abv4 * ovaavg + abv3 * abv5
4570 
4571  ! Compute and scatter the dissipative flux.
4572  ! Density.
4573 
4574  fs = lam3 * dr + abv6
4575  fw(i + 1, j, k, irho) = fw(i + 1, j, k, irho) + fs
4576  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
4577 
4578  ! X-momentum.
4579 
4580  fs = lam3 * dru + uavg * abv6 + sx * abv7
4581  fw(i + 1, j, k, imx) = fw(i + 1, j, k, imx) + fs
4582  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
4583 
4584  ! Y-momentum.
4585 
4586  fs = lam3 * drv + vavg * abv6 + sy * abv7
4587  fw(i + 1, j, k, imy) = fw(i + 1, j, k, imy) + fs
4588  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
4589 
4590  ! Z-momentum.
4591 
4592  fs = lam3 * drw + wavg * abv6 + sz * abv7
4593  fw(i + 1, j, k, imz) = fw(i + 1, j, k, imz) + fs
4594  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
4595 
4596  ! Energy.
4597 
4598  fs = lam3 * dre + havg * abv6 + unavg * abv7
4599  fw(i + 1, j, k, irhoe) = fw(i + 1, j, k, irhoe) + fs
4600  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
4601 
4602  ! Set dp1 to dp2 for the next face.
4603 
4604  dp1 = dp2
4605 
4606  end do
4607  end do
4608  end do
4609  !
4610  ! Dissipative fluxes in the j-direction.
4611  !
4612  do k = 2, kl
4613  do i = 2, il
4614 
4615  ! Compute the pressure sensor in the first cell, which
4616  ! is a halo cell.
4617 
4618  dp1 = abs((shocksensor(i, 2, k) - two * shocksensor(i, 1, k) + shocksensor(i, 0, k)) &
4619  / (omega * (shocksensor(i, 2, k) + two * shocksensor(i, 1, k) + shocksensor(i, 0, k)) &
4620  + oneminomega * (abs(shocksensor(i, 2, k) - shocksensor(i, 1, k)) &
4621  + abs(shocksensor(i, 1, k) - shocksensor(i, 0, k))) + plim))
4622 
4623  ! Loop in j-direction.
4624 
4625  do j = 1, jl
4626 
4627  ! Compute the pressure sensor in the cell to the right
4628  ! of the face.
4629 
4630  dp2 = abs((shocksensor(i, j + 2, k) - two * shocksensor(i, j + 1, k) + shocksensor(i, j, k)) &
4631  / (omega * (shocksensor(i, j + 2, k) + &
4632  two * shocksensor(i, j + 1, k) + shocksensor(i, j, k)) &
4633  + oneminomega * (abs(shocksensor(i, j + 2, k) - shocksensor(i, j + 1, k)) &
4634  + abs(shocksensor(i, j + 1, k) - shocksensor(i, j, k))) + plim))
4635 
4636  ! Compute the dissipation coefficients for this face.
4637 
4638  ppor = zero
4639  if (porj(i, j, k) == normalflux) ppor = one
4640 
4641  dis2 = fis2 * ppor * min(dpmax, max(dp1, dp2)) + sigma * fis4 * ppor
4642 
4643  ! Construct the vector of the first and third differences
4644  ! multiplied by the appropriate constants.
4645 
4646  ddw = w(i, j + 1, k, irho) - w(i, j, k, irho)
4647  dr = dis2 * ddw
4648 
4649  ddw = w(i, j + 1, k, irho) * w(i, j + 1, k, ivx) &
4650  - w(i, j, k, irho) * w(i, j, k, ivx)
4651  dru = dis2 * ddw
4652 
4653  ddw = w(i, j + 1, k, irho) * w(i, j + 1, k, ivy) &
4654  - w(i, j, k, irho) * w(i, j, k, ivy)
4655  drv = dis2 * ddw
4656 
4657  ddw = w(i, j + 1, k, irho) * w(i, j + 1, k, ivz) &
4658  - w(i, j, k, irho) * w(i, j, k, ivz)
4659  drw = dis2 * ddw
4660 
4661  ddw = w(i, j + 1, k, irhoe) - w(i, j, k, irhoe)
4662  dre = dis2 * ddw
4663 
4664  ! In case a k-equation is present, compute the difference
4665  ! of rhok and store the average value of k. If not present,
4666  ! set both these values to zero, such that later on no
4667  ! decision needs to be made anymore.
4668 
4669  if (correctfork) then
4670  ddw = w(i, j + 1, k, irho) * w(i, j + 1, k, itu1) &
4671  - w(i, j, k, irho) * w(i, j, k, itu1)
4672  drk = dis2 * ddw
4673 
4674  kavg = half * (w(i, j, k, itu1) + w(i, j + 1, k, itu1))
4675  else
4676  drk = zero
4677  kavg = zero
4678  end if
4679 
4680  ! Compute the average value of gamma and compute some
4681  ! expressions in which it occurs.
4682 
4683  gammaavg = half * (gamma(i, j + 1, k) + gamma(i, j, k))
4684  gm1 = gammaavg - one
4685  ovgm1 = one / gm1
4686  gm53 = gammaavg - five * third
4687 
4688  ! Compute the average state at the interface.
4689 
4690  uavg = half * (w(i, j + 1, k, ivx) + w(i, j, k, ivx))
4691  vavg = half * (w(i, j + 1, k, ivy) + w(i, j, k, ivy))
4692  wavg = half * (w(i, j + 1, k, ivz) + w(i, j, k, ivz))
4693  a2avg = half * (gamma(i, j + 1, k) * p(i, j + 1, k) / w(i, j + 1, k, irho) &
4694  + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
4695 
4696  sx = sj(i, j, k, 1); sy = sj(i, j, k, 2); sz = sj(i, j, k, 3)
4697  area = sqrt(sx**2 + sy**2 + sz**2)
4698  tmp = one / max(1.e-25_realtype, area)
4699  sx = sx * tmp
4700  sy = sy * tmp
4701  sz = sz * tmp
4702 
4703  alphaavg = half * (uavg**2 + vavg**2 + wavg**2)
4704  havg = alphaavg + ovgm1 * (a2avg - gm53 * kavg)
4705  aavg = sqrt(a2avg)
4706  unavg = uavg * sx + vavg * sy + wavg * sz
4707  ovaavg = one / aavg
4708  ova2avg = one / a2avg
4709 
4710  ! The mesh velocity if the face is moving. It must be
4711  ! divided by the area to obtain a true velocity.
4712 
4713  if (addgridvelocities) sface = sfacej(i, j, k) * tmp
4714 
4715  ! Compute the absolute values of the three eigenvalues
4716  ! and make sure they don't become zero by cutting them
4717  ! off to a certain minimum.
4718 
4719  lam1 = abs(unavg - sface + aavg)
4720  lam2 = abs(unavg - sface - aavg)
4721  lam3 = abs(unavg - sface)
4722 
4723  rrad = lam3 + aavg
4724 
4725  lam1 = max(lam1, epsacoustic * rrad)
4726  lam2 = max(lam2, epsacoustic * rrad)
4727  lam3 = max(lam3, epsshear * rrad)
4728 
4729  ! Multiply the eigenvalues by the area to obtain
4730  ! the correct values for the dissipation term.
4731 
4732  lam1 = lam1 * area
4733  lam2 = lam2 * area
4734  lam3 = lam3 * area
4735 
4736  ! Some abbreviations, which occur quite often in the
4737  ! dissipation terms.
4738 
4739  abv1 = half * (lam1 + lam2)
4740  abv2 = half * (lam1 - lam2)
4741  abv3 = abv1 - lam3
4742 
4743  abv4 = gm1 * (alphaavg * dr - uavg * dru - vavg * drv &
4744  - wavg * drw + dre) - gm53 * drk
4745  abv5 = sx * dru + sy * drv + sz * drw - unavg * dr
4746 
4747  abv6 = abv3 * abv4 * ova2avg + abv2 * abv5 * ovaavg
4748  abv7 = abv2 * abv4 * ovaavg + abv3 * abv5
4749 
4750  ! Compute and scatter the dissipative flux.
4751  ! Density.
4752 
4753  fs = lam3 * dr + abv6
4754  fw(i, j + 1, k, irho) = fw(i, j + 1, k, irho) + fs
4755  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
4756 
4757  ! X-momentum.
4758 
4759  fs = lam3 * dru + uavg * abv6 + sx * abv7
4760  fw(i, j + 1, k, imx) = fw(i, j + 1, k, imx) + fs
4761  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
4762 
4763  ! Y-momentum.
4764 
4765  fs = lam3 * drv + vavg * abv6 + sy * abv7
4766  fw(i, j + 1, k, imy) = fw(i, j + 1, k, imy) + fs
4767  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
4768 
4769  ! Z-momentum.
4770 
4771  fs = lam3 * drw + wavg * abv6 + sz * abv7
4772  fw(i, j + 1, k, imz) = fw(i, j + 1, k, imz) + fs
4773  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
4774 
4775  ! Energy.
4776 
4777  fs = lam3 * dre + havg * abv6 + unavg * abv7
4778  fw(i, j + 1, k, irhoe) = fw(i, j + 1, k, irhoe) + fs
4779  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
4780 
4781  ! Set dp1 to dp2 for the next face.
4782 
4783  dp1 = dp2
4784 
4785  end do
4786  end do
4787  end do
4788  !
4789  ! Dissipative fluxes in the k-direction.
4790  !
4791  do j = 2, jl
4792  do i = 2, il
4793 
4794  ! Compute the pressure sensor in the first cell, which
4795  ! is a halo cell.
4796 
4797  dp1 = abs((shocksensor(i, j, 2) - two * shocksensor(i, j, 1) + shocksensor(i, j, 0)) &
4798  / (omega * (shocksensor(i, j, 2) + two * shocksensor(i, j, 1) + shocksensor(i, j, 0)) &
4799  + oneminomega * (abs(shocksensor(i, j, 2) - shocksensor(i, j, 1)) &
4800  + abs(shocksensor(i, j, 1) - shocksensor(i, j, 0))) + plim))
4801 
4802  ! Loop in k-direction.
4803 
4804  do k = 1, kl
4805 
4806  ! Compute the pressure sensor in the cell to the right
4807  ! of the face.
4808 
4809  dp2 = abs((shocksensor(i, j, k + 2) - two * shocksensor(i, j, k + 1) + shocksensor(i, j, k)) &
4810  / (omega * (shocksensor(i, j, k + 2) + &
4811  two * shocksensor(i, j, k + 1) + shocksensor(i, j, k)) &
4812  + oneminomega * (abs(shocksensor(i, j, k + 2) - shocksensor(i, j, k + 1)) &
4813  + abs(shocksensor(i, j, k + 1) - shocksensor(i, j, k))) + plim))
4814 
4815  ! Compute the dissipation coefficients for this face.
4816 
4817  ppor = zero
4818  if (pork(i, j, k) == normalflux) ppor = one
4819 
4820  dis2 = fis2 * ppor * min(dpmax, max(dp1, dp2)) + sigma * fis4 * ppor
4821 
4822  ! Construct the vector of the first and third differences
4823  ! multiplied by the appropriate constants.
4824 
4825  ddw = w(i, j, k + 1, irho) - w(i, j, k, irho)
4826  dr = dis2 * ddw
4827 
4828  ddw = w(i, j, k + 1, irho) * w(i, j, k + 1, ivx) &
4829  - w(i, j, k, irho) * w(i, j, k, ivx)
4830  dru = dis2 * ddw
4831 
4832  ddw = w(i, j, k + 1, irho) * w(i, j, k + 1, ivy) &
4833  - w(i, j, k, irho) * w(i, j, k, ivy)
4834  drv = dis2 * ddw
4835 
4836  ddw = w(i, j, k + 1, irho) * w(i, j, k + 1, ivz) &
4837  - w(i, j, k, irho) * w(i, j, k, ivz)
4838  drw = dis2 * ddw
4839 
4840  ddw = w(i, j, k + 1, irhoe) - w(i, j, k, irhoe)
4841  dre = dis2 * ddw
4842 
4843  ! In case a k-equation is present, compute the difference
4844  ! of rhok and store the average value of k. If not present,
4845  ! set both these values to zero, such that later on no
4846  ! decision needs to be made anymore.
4847 
4848  if (correctfork) then
4849  ddw = w(i, j, k + 1, irho) * w(i, j, k + 1, itu1) &
4850  - w(i, j, k, irho) * w(i, j, k, itu1)
4851  drk = dis2 * ddw
4852  kavg = half * (w(i, j, k + 1, itu1) + w(i, j, k, itu1))
4853  else
4854  drk = zero
4855  kavg = zero
4856  end if
4857 
4858  ! Compute the average value of gamma and compute some
4859  ! expressions in which it occurs.
4860 
4861  gammaavg = half * (gamma(i, j, k + 1) + gamma(i, j, k))
4862  gm1 = gammaavg - one
4863  ovgm1 = one / gm1
4864  gm53 = gammaavg - five * third
4865 
4866  ! Compute the average state at the interface.
4867 
4868  uavg = half * (w(i, j, k + 1, ivx) + w(i, j, k, ivx))
4869  vavg = half * (w(i, j, k + 1, ivy) + w(i, j, k, ivy))
4870  wavg = half * (w(i, j, k + 1, ivz) + w(i, j, k, ivz))
4871  a2avg = half * (gamma(i, j, k + 1) * p(i, j, k + 1) / w(i, j, k + 1, irho) &
4872  + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
4873 
4874  sx = sk(i, j, k, 1); sy = sk(i, j, k, 2); sz = sk(i, j, k, 3)
4875  area = sqrt(sx**2 + sy**2 + sz**2)
4876  tmp = one / max(1.e-25_realtype, area)
4877  sx = sx * tmp
4878  sy = sy * tmp
4879  sz = sz * tmp
4880 
4881  alphaavg = half * (uavg**2 + vavg**2 + wavg**2)
4882  havg = alphaavg + ovgm1 * (a2avg - gm53 * kavg)
4883  aavg = sqrt(a2avg)
4884  unavg = uavg * sx + vavg * sy + wavg * sz
4885  ovaavg = one / aavg
4886  ova2avg = one / a2avg
4887 
4888  ! The mesh velocity if the face is moving. It must be
4889  ! divided by the area to obtain a true velocity.
4890 
4891  if (addgridvelocities) sface = sfacek(i, j, k) * tmp
4892 
4893  ! Compute the absolute values of the three eigenvalues
4894  ! and make sure they don't become zero by cutting them
4895  ! off to a certain minimum.
4896 
4897  lam1 = abs(unavg - sface + aavg)
4898  lam2 = abs(unavg - sface - aavg)
4899  lam3 = abs(unavg - sface)
4900 
4901  rrad = lam3 + aavg
4902 
4903  lam1 = max(lam1, epsacoustic * rrad)
4904  lam2 = max(lam2, epsacoustic * rrad)
4905  lam3 = max(lam3, epsshear * rrad)
4906 
4907  ! Multiply the eigenvalues by the area to obtain
4908  ! the correct values for the dissipation term.
4909 
4910  lam1 = lam1 * area
4911  lam2 = lam2 * area
4912  lam3 = lam3 * area
4913 
4914  ! Some abbreviations, which occur quite often in the
4915  ! dissipation terms.
4916 
4917  abv1 = half * (lam1 + lam2)
4918  abv2 = half * (lam1 - lam2)
4919  abv3 = abv1 - lam3
4920 
4921  abv4 = gm1 * (alphaavg * dr - uavg * dru - vavg * drv &
4922  - wavg * drw + dre) - gm53 * drk
4923  abv5 = sx * dru + sy * drv + sz * drw - unavg * dr
4924 
4925  abv6 = abv3 * abv4 * ova2avg + abv2 * abv5 * ovaavg
4926  abv7 = abv2 * abv4 * ovaavg + abv3 * abv5
4927 
4928  ! Compute and scatter the dissipative flux.
4929  ! Density.
4930 
4931  fs = lam3 * dr + abv6
4932  fw(i, j, k + 1, irho) = fw(i, j, k + 1, irho) + fs
4933  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
4934 
4935  ! X-momentum.
4936 
4937  fs = lam3 * dru + uavg * abv6 + sx * abv7
4938  fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) + fs
4939  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
4940 
4941  ! Y-momentum.
4942 
4943  fs = lam3 * drv + vavg * abv6 + sy * abv7
4944  fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) + fs
4945  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
4946 
4947  ! Z-momentum.
4948 
4949  fs = lam3 * drw + wavg * abv6 + sz * abv7
4950  fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) + fs
4951  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
4952 
4953  ! Energy.
4954 
4955  fs = lam3 * dre + havg * abv6 + unavg * abv7
4956  fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) + fs
4957  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
4958 
4959  ! Set dp1 to dp2 for the next face.
4960 
4961  dp1 = dp2
4962 
4963  end do
4964  end do
4965  end do
4966 
4967  end subroutine invisciddissfluxmatrixapprox
4968 
4969  ! ----------------------------------------------------------------------
4970  ! |
4971  ! No Tapenade Routine below this line |
4972  ! |
4973  ! ----------------------------------------------------------------------
4974 
4975 #ifndef USE_TAPENADE
4976 
4977  subroutine invisciddissfluxscalarcoarse
4978  !
4979  ! inviscidDissFluxScalarCoarse computes the coarse grid, i.e.
4980  ! 1st order, artificial dissipation flux for the scalar
4981  ! dissipation scheme for a given block. Therefore it is assumed
4982  ! that the pointers in blockPointers already point to the
4983  ! correct block.
4984  !
4985  use constants
4986  use blockpointers, only: il, jl, kl, ie, je, ke, w, p, &
4987  pori, porj, pork, fw, radi, radj, radk, gamma
4988  use inputdiscretization, only: vis2coarse
4989  use iteration, only: rfil
4990 
4991  implicit none
4992  !
4993  ! Local variables.
4994  !
4995  integer(kind=intType) :: i, j, k
4996 
4997  real(kind=realtype) :: sfil, fis0, dis0, ppor, fs, rhoi
4998 
4999  ! Check if rFil == 0. If so, the dissipative flux needs not to
5000  ! be computed.
5001 
5002  if (abs(rfil) < thresholdreal) return
5003 
5004  ! Set a couple of constants for the scheme.
5005 
5006  fis0 = rfil * vis2coarse
5007  sfil = one - rfil
5008 
5009  ! Replace the total energy by rho times the total enthalpy.
5010  ! In this way the numerical solution is total enthalpy preserving
5011  ! for the steady Euler equations. Also replace the velocities by
5012  ! the momentum. As only first order halo's are needed, only include
5013  ! the first order halo's.
5014 
5015  do k = 1, ke
5016  do j = 1, je
5017  do i = 1, ie
5018  w(i, j, k, ivx) = w(i, j, k, irho) * w(i, j, k, ivx)
5019  w(i, j, k, ivy) = w(i, j, k, irho) * w(i, j, k, ivy)
5020  w(i, j, k, ivz) = w(i, j, k, irho) * w(i, j, k, ivz)
5021  w(i, j, k, irhoe) = w(i, j, k, irhoe) + p(i, j, k)
5022  end do
5023  end do
5024  end do
5025 
5026  ! Initialize the dissipative residual to a certain times,
5027  ! possibly zero, the previously stored value. Owned cells
5028  ! only, because the halo values do not matter.
5029 
5030  do k = 2, kl
5031  do j = 2, jl
5032  do i = 2, il
5033  fw(i, j, k, irho) = sfil * fw(i, j, k, irho)
5034  fw(i, j, k, imx) = sfil * fw(i, j, k, imx)
5035  fw(i, j, k, imy) = sfil * fw(i, j, k, imy)
5036  fw(i, j, k, imz) = sfil * fw(i, j, k, imz)
5037  fw(i, j, k, irhoe) = sfil * fw(i, j, k, irhoe)
5038  end do
5039  end do
5040  end do
5041  !
5042  ! Dissipative fluxes in the i-direction.
5043  !
5044  do k = 2, kl
5045  do j = 2, jl
5046  do i = 1, il
5047 
5048  ! Compute the dissipation coefficients for this face.
5049 
5050  ppor = zero
5051  if (pori(i, j, k) == normalflux) ppor = half
5052 
5053  dis0 = fis0 * ppor * (radi(i, j, k) + radi(i + 1, j, k))
5054 
5055  ! Compute and scatter the dissipative flux.
5056  ! Density.
5057 
5058  fs = dis0 * (w(i + 1, j, k, irho) - w(i, j, k, irho))
5059  fw(i + 1, j, k, irho) = fw(i + 1, j, k, irho) + fs
5060  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
5061 
5062  ! X-momentum.
5063 
5064  fs = dis0 * (w(i + 1, j, k, ivx) - w(i, j, k, ivx))
5065  fw(i + 1, j, k, imx) = fw(i + 1, j, k, imx) + fs
5066  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
5067 
5068  ! Y-momentum.
5069 
5070  fs = dis0 * (w(i + 1, j, k, ivy) - w(i, j, k, ivy))
5071  fw(i + 1, j, k, imy) = fw(i + 1, j, k, imy) + fs
5072  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
5073 
5074  ! Z-momentum.
5075 
5076  fs = dis0 * (w(i + 1, j, k, ivz) - w(i, j, k, ivz))
5077  fw(i + 1, j, k, imz) = fw(i + 1, j, k, imz) + fs
5078  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
5079 
5080  ! Energy.
5081 
5082  fs = dis0 * (w(i + 1, j, k, irhoe) - w(i, j, k, irhoe))
5083  fw(i + 1, j, k, irhoe) = fw(i + 1, j, k, irhoe) + fs
5084  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
5085 
5086  end do
5087  end do
5088  end do
5089  !
5090  ! Dissipative fluxes in the j-direction.
5091  !
5092  do k = 2, kl
5093  do j = 1, jl
5094  do i = 2, il
5095 
5096  ! Compute the dissipation coefficients for this face.
5097 
5098  ppor = zero
5099  if (porj(i, j, k) == normalflux) ppor = half
5100 
5101  dis0 = fis0 * ppor * (radj(i, j, k) + radj(i, j + 1, k))
5102 
5103  ! Compute and scatter the dissipative flux.
5104  ! Density.
5105 
5106  fs = dis0 * (w(i, j + 1, k, irho) - w(i, j, k, irho))
5107  fw(i, j + 1, k, irho) = fw(i, j + 1, k, irho) + fs
5108  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
5109 
5110  ! X-momentum.
5111 
5112  fs = dis0 * (w(i, j + 1, k, ivx) - w(i, j, k, ivx))
5113  fw(i, j + 1, k, imx) = fw(i, j + 1, k, imx) + fs
5114  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
5115 
5116  ! Y-momentum.
5117 
5118  fs = dis0 * (w(i, j + 1, k, ivy) - w(i, j, k, ivy))
5119  fw(i, j + 1, k, imy) = fw(i, j + 1, k, imy) + fs
5120  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
5121 
5122  ! Z-momentum.
5123 
5124  fs = dis0 * (w(i, j + 1, k, ivz) - w(i, j, k, ivz))
5125  fw(i, j + 1, k, imz) = fw(i, j + 1, k, imz) + fs
5126  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
5127 
5128  ! Energy
5129 
5130  fs = dis0 * (w(i, j + 1, k, irhoe) - w(i, j, k, irhoe))
5131  fw(i, j + 1, k, irhoe) = fw(i, j + 1, k, irhoe) + fs
5132  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
5133 
5134  end do
5135  end do
5136  end do
5137  !
5138  ! Dissipative fluxes in the k-direction.
5139  !
5140  do k = 1, kl
5141  do j = 2, jl
5142  do i = 2, il
5143 
5144  ! Compute the dissipation coefficients for this face.
5145 
5146  ppor = zero
5147  if (pork(i, j, k) == normalflux) ppor = half
5148 
5149  dis0 = fis0 * ppor * (radk(i, j, k) + radk(i, j, k + 1))
5150 
5151  ! Compute and scatter the dissipative flux.
5152  ! Density.
5153 
5154  fs = dis0 * (w(i, j, k + 1, irho) - w(i, j, k, irho))
5155  fw(i, j, k + 1, irho) = fw(i, j, k + 1, irho) + fs
5156  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
5157 
5158  ! X-momentum.
5159 
5160  fs = dis0 * (w(i, j, k + 1, ivx) - w(i, j, k, ivx))
5161  fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) + fs
5162  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
5163 
5164  ! Y-momentum.
5165 
5166  fs = dis0 * (w(i, j, k + 1, ivy) - w(i, j, k, ivy))
5167  fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) + fs
5168  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
5169 
5170  ! Z-momentum.
5171 
5172  fs = dis0 * (w(i, j, k + 1, ivz) - w(i, j, k, ivz))
5173  fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) + fs
5174  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
5175 
5176  ! Energy
5177 
5178  fs = dis0 * (w(i, j, k + 1, irhoe) - w(i, j, k, irhoe))
5179  fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) + fs
5180  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
5181 
5182  end do
5183  end do
5184  end do
5185 
5186  ! Replace rho times the total enthalpy by the total energy and
5187  ! store the velocities again instead of the momentum. As only
5188  ! the first halo cells are included, this must be done here again.
5189 
5190  do k = 1, ke
5191  do j = 1, je
5192  do i = 1, ie
5193  rhoi = one / w(i, j, k, irho)
5194  w(i, j, k, ivx) = w(i, j, k, ivx) * rhoi
5195  w(i, j, k, ivy) = w(i, j, k, ivy) * rhoi
5196  w(i, j, k, ivz) = w(i, j, k, ivz) * rhoi
5197 
5198  w(i, j, k, irhoe) = w(i, j, k, irhoe) - p(i, j, k)
5199  end do
5200  end do
5201  end do
5202 
5203  end subroutine invisciddissfluxscalarcoarse
5204 
5205  subroutine invisciddissfluxmatrixcoarse
5206  !
5207  ! inviscidDissFluxMatrixCoarse computes the matrix artificial
5208  ! dissipation term. Instead of the spectral radius, as used in
5209  ! the scalar dissipation scheme, the absolute value of the flux
5210  ! jacobian is used. This routine is used on the coarser grids in
5211  ! the multigrid cycle and only computes the first order
5212  ! dissipation term. It is assumed that the pointers in
5213  ! blockPointers already point to the correct block.
5214  !
5215  use constants
5216  use blockpointers, only: il, jl, kl, ie, je, ke, ib, jb, kb, w, p, &
5217  pori, porj, pork, fw, gamma, si, sj, sk, &
5218  addgridvelocities, sfacei, sfacej, sfacek
5219  use inputdiscretization, only: vis2coarse
5220  use inputphysics, only: equations
5221  use iteration, only: rfil
5222  use utils, only: getcorrectfork
5223  implicit none
5224  !
5225  ! Local parameters.
5226  !
5227  real(kind=realtype), parameter :: epsacoustic = 0.25_realtype
5228  real(kind=realtype), parameter :: epsshear = 0.025_realtype
5229  !
5230  ! Local variables.
5231  !
5232  integer(kind=intType) :: i, j, k
5233 
5234  real(kind=realtype) :: sfil, fis0, dis0, ppor, rrad, sface
5235  real(kind=realtype) :: gammaavg, gm1, ovgm1, gm53, tmp, fs
5236  real(kind=realtype) :: dr, dru, drv, drw, dre, drk, sx, sy, sz
5237  real(kind=realtype) :: uavg, vavg, wavg, a2avg, aavg, havg
5238  real(kind=realtype) :: alphaavg, unavg, ovaavg, ova2avg
5239  real(kind=realtype) :: kavg, lam1, lam2, lam3, area
5240  real(kind=realtype) :: abv1, abv2, abv3, abv4, abv5, abv6, abv7
5241  logical :: correctForK
5242 
5243  ! Check if rFil == 0. If so, the dissipative flux needs not to
5244  ! be computed.
5245 
5246  if (abs(rfil) < thresholdreal) return
5247 
5248  ! Determine whether or not the total energy must be corrected
5249  ! for the presence of the turbulent kinetic energy.
5250 
5251  correctfork = getcorrectfork()
5252 
5253  ! Initialize sface to zero. This value will be used if the
5254  ! block is not moving.
5255 
5256  sface = zero
5257 
5258  ! Set a couple of constants for the scheme.
5259 
5260  fis0 = rfil * vis2coarse
5261  sfil = one - rfil
5262 
5263  ! Initialize the dissipative residual to a certain times,
5264  ! possibly zero, the previously stored value. Owned cells
5265  ! only, because the halo values do not matter.
5266 
5267  do k = 2, kl
5268  do j = 2, jl
5269  do i = 2, il
5270  fw(i, j, k, irho) = sfil * fw(i, j, k, irho)
5271  fw(i, j, k, imx) = sfil * fw(i, j, k, imx)
5272  fw(i, j, k, imy) = sfil * fw(i, j, k, imy)
5273  fw(i, j, k, imz) = sfil * fw(i, j, k, imz)
5274  fw(i, j, k, irhoe) = sfil * fw(i, j, k, irhoe)
5275  end do
5276  end do
5277  end do
5278  !
5279  ! Dissipative fluxes in the i-direction.
5280  !
5281  do k = 2, kl
5282  do j = 2, jl
5283  do i = 1, il
5284 
5285  ! Compute the dissipation coefficient for this face.
5286 
5287  ppor = zero
5288  if (pori(i, j, k) == normalflux) ppor = one
5289 
5290  dis0 = fis0 * ppor
5291 
5292  ! Construct the vector of the first differences multiplied
5293  ! by dis0.
5294 
5295  dr = dis0 * (w(i + 1, j, k, irho) - w(i, j, k, irho))
5296  dru = dis0 * (w(i + 1, j, k, irho) * w(i + 1, j, k, ivx) &
5297  - w(i, j, k, irho) * w(i, j, k, ivx))
5298  drv = dis0 * (w(i + 1, j, k, irho) * w(i + 1, j, k, ivy) &
5299  - w(i, j, k, irho) * w(i, j, k, ivy))
5300  drw = dis0 * (w(i + 1, j, k, irho) * w(i + 1, j, k, ivz) &
5301  - w(i, j, k, irho) * w(i, j, k, ivz))
5302  dre = dis0 * (w(i + 1, j, k, irhoe) - w(i, j, k, irhoe))
5303 
5304  ! In case a k-equation is present, compute the difference
5305  ! of rhok and store the average value of k. If not present,
5306  ! set both these values to zero, such that later on no
5307  ! decision needs to be made anymore.
5308 
5309  if (correctfork) then
5310  drk = dis0 * (w(i + 1, j, k, irho) * w(i + 1, j, k, itu1) &
5311  - w(i, j, k, irho) * w(i, j, k, itu1))
5312  kavg = half * (w(i + 1, j, k, itu1) + w(i, j, k, itu1))
5313  else
5314  drk = zero
5315  kavg = zero
5316  end if
5317 
5318  ! Compute the average value of gamma and compute some
5319  ! expressions in which it occurs.
5320 
5321  gammaavg = half * (gamma(i + 1, j, k) + gamma(i, j, k))
5322  gm1 = gammaavg - one
5323  ovgm1 = one / gm1
5324  gm53 = gammaavg - five * third
5325 
5326  ! Compute the average state at the interface.
5327 
5328  uavg = half * (w(i + 1, j, k, ivx) + w(i, j, k, ivx))
5329  vavg = half * (w(i + 1, j, k, ivy) + w(i, j, k, ivy))
5330  wavg = half * (w(i + 1, j, k, ivz) + w(i, j, k, ivz))
5331  a2avg = half * (gamma(i + 1, j, k) * p(i + 1, j, k) / w(i + 1, j, k, irho) &
5332  + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
5333 
5334  sx = si(i, j, k, 1); sy = si(i, j, k, 2); sz = si(i, j, k, 3)
5335  area = sqrt(sx**2 + sy**2 + sz**2)
5336  tmp = one / max(1.e-25_realtype, area)
5337  sx = sx * tmp
5338  sy = sy * tmp
5339  sz = sz * tmp
5340 
5341  alphaavg = half * (uavg**2 + vavg**2 + wavg**2)
5342  havg = alphaavg + ovgm1 * (a2avg - gm53 * kavg)
5343  aavg = sqrt(a2avg)
5344  unavg = uavg * sx + vavg * sy + wavg * sz
5345  ovaavg = one / aavg
5346  ova2avg = one / a2avg
5347 
5348  ! The mesh velocity if the face is moving. It must be
5349  ! divided by the area to obtain a true velocity.
5350 
5351  if (addgridvelocities) sface = sfacei(i, j, k) * tmp
5352 
5353  ! Compute the absolute values of the three eigenvalues
5354  ! and make sure they don't become zero by cutting them
5355  ! off to a certain minimum.
5356 
5357  lam1 = abs(unavg - sface + aavg)
5358  lam2 = abs(unavg - sface - aavg)
5359  lam3 = abs(unavg - sface)
5360 
5361  rrad = lam3 + aavg
5362 
5363  lam1 = max(lam1, epsacoustic * rrad)
5364  lam2 = max(lam2, epsacoustic * rrad)
5365  lam3 = max(lam3, epsshear * rrad)
5366 
5367  ! Multiply the eigenvalues by the area to obtain
5368  ! the correct values for the dissipation term.
5369 
5370  lam1 = lam1 * area
5371  lam2 = lam2 * area
5372  lam3 = lam3 * area
5373 
5374  ! Some abbreviations, which occur quite often in the
5375  ! dissipation terms.
5376 
5377  abv1 = half * (lam1 + lam2)
5378  abv2 = half * (lam1 - lam2)
5379  abv3 = abv1 - lam3
5380 
5381  abv4 = gm1 * (alphaavg * dr - uavg * dru - vavg * drv &
5382  - wavg * drw + dre) - gm53 * drk
5383  abv5 = sx * dru + sy * drv + sz * drw - unavg * dr
5384 
5385  abv6 = abv3 * abv4 * ova2avg + abv2 * abv5 * ovaavg
5386  abv7 = abv2 * abv4 * ovaavg + abv3 * abv5
5387 
5388  ! Compute and scatter the dissipative flux.
5389  ! Density.
5390 
5391  fs = lam3 * dr + abv6
5392  fw(i + 1, j, k, irho) = fw(i + 1, j, k, irho) + fs
5393  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
5394 
5395  ! X-momentum.
5396 
5397  fs = lam3 * dru + uavg * abv6 + sx * abv7
5398  fw(i + 1, j, k, imx) = fw(i + 1, j, k, imx) + fs
5399  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
5400 
5401  ! Y-momentum.
5402 
5403  fs = lam3 * drv + vavg * abv6 + sy * abv7
5404  fw(i + 1, j, k, imy) = fw(i + 1, j, k, imy) + fs
5405  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
5406 
5407  ! Z-momentum.
5408 
5409  fs = lam3 * drw + wavg * abv6 + sz * abv7
5410  fw(i + 1, j, k, imz) = fw(i + 1, j, k, imz) + fs
5411  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
5412 
5413  ! Energy.
5414 
5415  fs = lam3 * dre + havg * abv6 + unavg * abv7
5416  fw(i + 1, j, k, irhoe) = fw(i + 1, j, k, irhoe) + fs
5417  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
5418 
5419  end do
5420  end do
5421  end do
5422  !
5423  ! Dissipative fluxes in the j-direction.
5424  !
5425  do k = 2, kl
5426  do j = 1, jl
5427  do i = 2, il
5428 
5429  ! Compute the dissipation coefficient for this face.
5430 
5431  ppor = zero
5432  if (porj(i, j, k) == normalflux) ppor = one
5433 
5434  dis0 = fis0 * ppor
5435 
5436  ! Construct the vector of the first differences multiplied
5437  ! by dis0.
5438 
5439  dr = dis0 * (w(i, j + 1, k, irho) - w(i, j, k, irho))
5440  dru = dis0 * (w(i, j + 1, k, irho) * w(i, j + 1, k, ivx) &
5441  - w(i, j, k, irho) * w(i, j, k, ivx))
5442  drv = dis0 * (w(i, j + 1, k, irho) * w(i, j + 1, k, ivy) &
5443  - w(i, j, k, irho) * w(i, j, k, ivy))
5444  drw = dis0 * (w(i, j + 1, k, irho) * w(i, j + 1, k, ivz) &
5445  - w(i, j, k, irho) * w(i, j, k, ivz))
5446  dre = dis0 * (w(i, j + 1, k, irhoe) - w(i, j, k, irhoe))
5447 
5448  ! In case a k-equation is present, compute the difference
5449  ! of rhok and store the average value of k. If not present,
5450  ! set both these values to zero, such that later on no
5451  ! decision needs to be made anymore.
5452 
5453  if (correctfork) then
5454  drk = dis0 * (w(i, j + 1, k, irho) * w(i, j + 1, k, itu1) &
5455  - w(i, j, k, irho) * w(i, j, k, itu1))
5456  kavg = half * (w(i, j + 1, k, itu1) + w(i, j, k, itu1))
5457  else
5458  drk = zero
5459  kavg = zero
5460  end if
5461 
5462  ! Compute the average value of gamma and compute some
5463  ! expressions in which it occurs.
5464 
5465  gammaavg = half * (gamma(i, j + 1, k) + gamma(i, j, k))
5466  gm1 = gammaavg - one
5467  ovgm1 = one / gm1
5468  gm53 = gammaavg - five * third
5469 
5470  ! Compute the average state at the interface.
5471 
5472  uavg = half * (w(i, j + 1, k, ivx) + w(i, j, k, ivx))
5473  vavg = half * (w(i, j + 1, k, ivy) + w(i, j, k, ivy))
5474  wavg = half * (w(i, j + 1, k, ivz) + w(i, j, k, ivz))
5475  a2avg = half * (gamma(i, j + 1, k) * p(i, j + 1, k) / w(i, j + 1, k, irho) &
5476  + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
5477 
5478  sx = sj(i, j, k, 1); sy = sj(i, j, k, 2); sz = sj(i, j, k, 3)
5479  area = sqrt(sx**2 + sy**2 + sz**2)
5480  tmp = one / max(1.e-25_realtype, area)
5481  sx = sx * tmp
5482  sy = sy * tmp
5483  sz = sz * tmp
5484 
5485  alphaavg = half * (uavg**2 + vavg**2 + wavg**2)
5486  havg = alphaavg + ovgm1 * (a2avg - gm53 * kavg)
5487  aavg = sqrt(a2avg)
5488  unavg = uavg * sx + vavg * sy + wavg * sz
5489  ovaavg = one / aavg
5490  ova2avg = one / a2avg
5491 
5492  ! The mesh velocity if the face is moving. It must be
5493  ! divided by the area to obtain a true velocity.
5494 
5495  if (addgridvelocities) sface = sfacej(i, j, k) * tmp
5496 
5497  ! Compute the absolute values of the three eigenvalues
5498  ! and make sure they don't become zero by cutting them
5499  ! off to a certain minimum.
5500 
5501  lam1 = abs(unavg - sface + aavg)
5502  lam2 = abs(unavg - sface - aavg)
5503  lam3 = abs(unavg - sface)
5504 
5505  rrad = lam3 + aavg
5506 
5507  lam1 = max(lam1, epsacoustic * rrad)
5508  lam2 = max(lam2, epsacoustic * rrad)
5509  lam3 = max(lam3, epsshear * rrad)
5510 
5511  ! Multiply the eigenvalues by the area to obtain
5512  ! the correct values for the dissipation term.
5513 
5514  lam1 = lam1 * area
5515  lam2 = lam2 * area
5516  lam3 = lam3 * area
5517 
5518  ! Some abbreviations, which occur quite often in the
5519  ! dissipation terms.
5520 
5521  abv1 = half * (lam1 + lam2)
5522  abv2 = half * (lam1 - lam2)
5523  abv3 = abv1 - lam3
5524 
5525  abv4 = gm1 * (alphaavg * dr - uavg * dru - vavg * drv &
5526  - wavg * drw + dre) - gm53 * drk
5527  abv5 = sx * dru + sy * drv + sz * drw - unavg * dr
5528 
5529  abv6 = abv3 * abv4 * ova2avg + abv2 * abv5 * ovaavg
5530  abv7 = abv2 * abv4 * ovaavg + abv3 * abv5
5531 
5532  ! Compute and scatter the dissipative flux.
5533  ! Density.
5534 
5535  fs = lam3 * dr + abv6
5536  fw(i, j + 1, k, irho) = fw(i, j + 1, k, irho) + fs
5537  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
5538 
5539  ! X-momentum.
5540 
5541  fs = lam3 * dru + uavg * abv6 + sx * abv7
5542  fw(i, j + 1, k, imx) = fw(i, j + 1, k, imx) + fs
5543  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
5544 
5545  ! Y-momentum.
5546 
5547  fs = lam3 * drv + vavg * abv6 + sy * abv7
5548  fw(i, j + 1, k, imy) = fw(i, j + 1, k, imy) + fs
5549  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
5550 
5551  ! Z-momentum.
5552 
5553  fs = lam3 * drw + wavg * abv6 + sz * abv7
5554  fw(i, j + 1, k, imz) = fw(i, j + 1, k, imz) + fs
5555  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
5556 
5557  ! Energy.
5558 
5559  fs = lam3 * dre + havg * abv6 + unavg * abv7
5560  fw(i, j + 1, k, irhoe) = fw(i, j + 1, k, irhoe) + fs
5561  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
5562 
5563  end do
5564  end do
5565  end do
5566  !
5567  ! Dissipative fluxes in the k-direction.
5568  !
5569  do k = 1, kl
5570  do j = 2, jl
5571  do i = 2, il
5572 
5573  ! Compute the dissipation coefficient for this face.
5574 
5575  ppor = zero
5576  if (pork(i, j, k) == normalflux) ppor = one
5577 
5578  dis0 = fis0 * ppor
5579 
5580  ! Construct the vector of the first differences multiplied
5581  ! by dis0.
5582 
5583  dr = dis0 * (w(i, j, k + 1, irho) - w(i, j, k, irho))
5584  dru = dis0 * (w(i, j, k + 1, irho) * w(i, j, k + 1, ivx) &
5585  - w(i, j, k, irho) * w(i, j, k, ivx))
5586  drv = dis0 * (w(i, j, k + 1, irho) * w(i, j, k + 1, ivy) &
5587  - w(i, j, k, irho) * w(i, j, k, ivy))
5588  drw = dis0 * (w(i, j, k + 1, irho) * w(i, j, k + 1, ivz) &
5589  - w(i, j, k, irho) * w(i, j, k, ivz))
5590  dre = dis0 * (w(i, j, k + 1, irhoe) - w(i, j, k, irhoe))
5591 
5592  ! In case a k-equation is present, compute the difference
5593  ! of rhok and store the average value of k. If not present,
5594  ! set both these values to zero, such that later on no
5595  ! decision needs to be made anymore.
5596 
5597  if (correctfork) then
5598  drk = dis0 * (w(i, j, k + 1, irho) * w(i, j, k + 1, itu1) &
5599  - w(i, j, k, irho) * w(i, j, k, itu1))
5600  kavg = half * (w(i, j, k + 1, itu1) + w(i, j, k, itu1))
5601  else
5602  drk = zero
5603  kavg = zero
5604  end if
5605 
5606  ! Compute the average value of gamma and compute some
5607  ! expressions in which it occurs.
5608 
5609  gammaavg = half * (gamma(i, j, k + 1) + gamma(i, j, k))
5610  gm1 = gammaavg - one
5611  ovgm1 = one / gm1
5612  gm53 = gammaavg - five * third
5613 
5614  ! Compute the average state at the interface.
5615 
5616  uavg = half * (w(i, j, k + 1, ivx) + w(i, j, k, ivx))
5617  vavg = half * (w(i, j, k + 1, ivy) + w(i, j, k, ivy))
5618  wavg = half * (w(i, j, k + 1, ivz) + w(i, j, k, ivz))
5619  a2avg = half * (gamma(i, j, k + 1) * p(i, j, k + 1) / w(i, j, k + 1, irho) &
5620  + gamma(i, j, k) * p(i, j, k) / w(i, j, k, irho))
5621 
5622  sx = sk(i, j, k, 1); sy = sk(i, j, k, 2); sz = sk(i, j, k, 3)
5623  area = sqrt(sx**2 + sy**2 + sz**2)
5624  tmp = one / max(1.e-25_realtype, area)
5625  sx = sx * tmp
5626  sy = sy * tmp
5627  sz = sz * tmp
5628 
5629  alphaavg = half * (uavg**2 + vavg**2 + wavg**2)
5630  havg = alphaavg + ovgm1 * (a2avg - gm53 * kavg)
5631  aavg = sqrt(a2avg)
5632  unavg = uavg * sx + vavg * sy + wavg * sz
5633  ovaavg = one / aavg
5634  ova2avg = one / a2avg
5635 
5636  ! The mesh velocity if the face is moving. It must be
5637  ! divided by the area to obtain a true velocity.
5638 
5639  if (addgridvelocities) sface = sfacek(i, j, k) * tmp
5640 
5641  ! Compute the absolute values of the three eigenvalues
5642  ! and make sure they don't become zero by cutting them
5643  ! off to a certain minimum.
5644 
5645  lam1 = abs(unavg - sface + aavg)
5646  lam2 = abs(unavg - sface - aavg)
5647  lam3 = abs(unavg - sface)
5648 
5649  rrad = lam3 + aavg
5650 
5651  lam1 = max(lam1, epsacoustic * rrad)
5652  lam2 = max(lam2, epsacoustic * rrad)
5653  lam3 = max(lam3, epsshear * rrad)
5654 
5655  ! Multiply the eigenvalues by the area to obtain
5656  ! the correct values for the dissipation term.
5657 
5658  lam1 = lam1 * area
5659  lam2 = lam2 * area
5660  lam3 = lam3 * area
5661 
5662  ! Some abbreviations, which occur quite often in the
5663  ! dissipation terms.
5664 
5665  abv1 = half * (lam1 + lam2)
5666  abv2 = half * (lam1 - lam2)
5667  abv3 = abv1 - lam3
5668 
5669  abv4 = gm1 * (alphaavg * dr - uavg * dru - vavg * drv &
5670  - wavg * drw + dre) - gm53 * drk
5671  abv5 = sx * dru + sy * drv + sz * drw - unavg * dr
5672 
5673  abv6 = abv3 * abv4 * ova2avg + abv2 * abv5 * ovaavg
5674  abv7 = abv2 * abv4 * ovaavg + abv3 * abv5
5675 
5676  ! Compute and scatter the dissipative flux.
5677  ! Density.
5678 
5679  fs = lam3 * dr + abv6
5680  fw(i, j, k + 1, irho) = fw(i, j, k + 1, irho) + fs
5681  fw(i, j, k, irho) = fw(i, j, k, irho) - fs
5682 
5683  ! X-momentum.
5684 
5685  fs = lam3 * dru + uavg * abv6 + sx * abv7
5686  fw(i, j, k + 1, imx) = fw(i, j, k + 1, imx) + fs
5687  fw(i, j, k, imx) = fw(i, j, k, imx) - fs
5688 
5689  ! Y-momentum.
5690 
5691  fs = lam3 * drv + vavg * abv6 + sy * abv7
5692  fw(i, j, k + 1, imy) = fw(i, j, k + 1, imy) + fs
5693  fw(i, j, k, imy) = fw(i, j, k, imy) - fs
5694 
5695  ! Z-momentum.
5696 
5697  fs = lam3 * drw + wavg * abv6 + sz * abv7
5698  fw(i, j, k + 1, imz) = fw(i, j, k + 1, imz) + fs
5699  fw(i, j, k, imz) = fw(i, j, k, imz) - fs
5700 
5701  ! Energy.
5702 
5703  fs = lam3 * dre + havg * abv6 + unavg * abv7
5704  fw(i, j, k + 1, irhoe) = fw(i, j, k + 1, irhoe) + fs
5705  fw(i, j, k, irhoe) = fw(i, j, k, irhoe) - fs
5706 
5707  end do
5708  end do
5709  end do
5710 
5711  end subroutine invisciddissfluxmatrixcoarse
5712 #endif
5713 end module fluxes
riemannflux
subroutine riemannflux(left, right, flux)
Definition: fluxes_d.f90:5366
leftrightstate
subroutine leftrightstate(du1, du2, du3, rotmatrix, left, right)
Definition: fluxes_d.f90:4708
blockpointers::sfacek
real(kind=realtype), dimension(:, :, :), pointer sfacek
Definition: blockPointers.F90:119
blockpointers::viscjminpointer
integer(kind=inttype), dimension(:, :), pointer viscjminpointer
Definition: blockPointers.F90:89
blockpointers::gamma
real(kind=realtype), dimension(:, :, :), pointer gamma
Definition: blockPointers.F90:123
blockpointers::qz
real(kind=realtype), dimension(:, :, :), pointer qz
Definition: blockPointers.F90:135
blockpointers::addgridvelocities
logical addgridvelocities
Definition: blockPointers.F90:117
blockpointers::jl
integer(kind=inttype) jl
Definition: blockPointers.F90:38
blockpointers::radk
real(kind=realtype), dimension(:, :, :), pointer radk
Definition: blockPointers.F90:152
blockpointers::pork
integer(kind=portype), dimension(:, :, :), pointer pork
Definition: blockPointers.F90:103
blockpointers::indfamilyj
integer(kind=inttype), dimension(:, :, :), pointer indfamilyj
Definition: blockPointers.F90:106
blockpointers::viscjmaxpointer
integer(kind=inttype), dimension(:, :), pointer viscjmaxpointer
Definition: blockPointers.F90:90
blockpointers::qy
real(kind=realtype), dimension(:, :, :), pointer qy
Definition: blockPointers.F90:135
blockpointers::aa
real(kind=realtype), dimension(:, :, :), pointer aa
Definition: blockPointers.F90:123
blockpointers::uz
real(kind=realtype), dimension(:, :, :), pointer uz
Definition: blockPointers.F90:132
blockpointers::factfamilyj
integer(kind=inttype), dimension(:, :, :), pointer factfamilyj
Definition: blockPointers.F90:110
blockpointers::blockismoving
logical blockismoving
Definition: blockPointers.F90:117
blockpointers::nx
integer(kind=inttype) nx
Definition: blockPointers.F90:38
blockpointers::spectralsol
integer(kind=inttype) spectralsol
Definition: blockPointers.F90:32
blockpointers::p
real(kind=realtype), dimension(:, :, :), pointer p
Definition: blockPointers.F90:123
blockpointers::radj
real(kind=realtype), dimension(:, :, :), pointer radj
Definition: blockPointers.F90:152
blockpointers::ny
integer(kind=inttype) ny
Definition: blockPointers.F90:38
blockpointers::ie
integer(kind=inttype) ie
Definition: blockPointers.F90:39
blockpointers::w
real(kind=realtype), dimension(:, :, :, :), pointer w
Definition: blockPointers.F90:120
blockpointers::uy
real(kind=realtype), dimension(:, :, :), pointer uy
Definition: blockPointers.F90:132
blockpointers::indfamilyk
integer(kind=inttype), dimension(:, :, :), pointer indfamilyk
Definition: blockPointers.F90:107
blockpointers::sfacei
real(kind=realtype), dimension(:, :, :), pointer sfacei
Definition: blockPointers.F90:119
blockpointers::viscsubface
type(viscsubfacetype), dimension(:), pointer viscsubface
Definition: blockPointers.F90:85
blockpointers::porj
integer(kind=portype), dimension(:, :, :), pointer porj
Definition: blockPointers.F90:103
blockpointers::pori
integer(kind=portype), dimension(:, :, :), pointer pori
Definition: blockPointers.F90:103
blockpointers::wx
real(kind=realtype), dimension(:, :, :), pointer wx
Definition: blockPointers.F90:134
blockpointers::nbkglobal
integer(kind=inttype) nbkglobal
Definition: blockPointers.F90:31
blockpointers::viscimaxpointer
integer(kind=inttype), dimension(:, :), pointer viscimaxpointer
Definition: blockPointers.F90:88
blockpointers::jb
integer(kind=inttype) jb
Definition: blockPointers.F90:39
blockpointers::kb
integer(kind=inttype) kb
Definition: blockPointers.F90:39
blockpointers::rlv
real(kind=realtype), dimension(:, :, :), pointer rlv
Definition: blockPointers.F90:125
blockpointers::si
real(kind=realtype), dimension(:, :, :, :), pointer si
Definition: blockPointers.F90:96
blockpointers::sj
real(kind=realtype), dimension(:, :, :, :), pointer sj
Definition: blockPointers.F90:96
blockpointers::visckminpointer
integer(kind=inttype), dimension(:, :), pointer visckminpointer
Definition: blockPointers.F90:91
blockpointers::factfamilyi
integer(kind=inttype), dimension(:, :, :), pointer factfamilyi
Definition: blockPointers.F90:109
blockpointers::qx
real(kind=realtype), dimension(:, :, :), pointer qx
Definition: blockPointers.F90:135
blockpointers::factfamilyk
integer(kind=inttype), dimension(:, :, :), pointer factfamilyk
Definition: blockPointers.F90:111
blockpointers::vz
real(kind=realtype), dimension(:, :, :), pointer vz
Definition: blockPointers.F90:133
blockpointers::rotmatrixj
real(kind=realtype), dimension(:, :, :, :, :), pointer rotmatrixj
Definition: blockPointers.F90:114
blockpointers::rev
real(kind=realtype), dimension(:, :, :), pointer rev
Definition: blockPointers.F90:125
blockpointers::dw
real(kind=realtype), dimension(:, :, :, :), pointer dw
Definition: blockPointers.F90:128
blockpointers::sk
real(kind=realtype), dimension(:, :, :, :), pointer sk
Definition: blockPointers.F90:96
blockpointers::ux
real(kind=realtype), dimension(:, :, :), pointer ux
Definition: blockPointers.F90:132
blockpointers::shocksensor
real(kind=realtype), dimension(:, :, :), pointer shocksensor
Definition: blockPointers.F90:124
blockpointers::wy
real(kind=realtype), dimension(:, :, :), pointer wy
Definition: blockPointers.F90:134
blockpointers::wz
real(kind=realtype), dimension(:, :, :), pointer wz
Definition: blockPointers.F90:134
blockpointers::vol
real(kind=realtype), dimension(:, :, :), pointer vol
Definition: blockPointers.F90:97
blockpointers::ib
integer(kind=inttype) ib
Definition: blockPointers.F90:39
blockpointers::sfacej
real(kind=realtype), dimension(:, :, :), pointer sfacej
Definition: blockPointers.F90:119
blockpointers::vy
real(kind=realtype), dimension(:, :, :), pointer vy
Definition: blockPointers.F90:133
blockpointers::fw
real(kind=realtype), dimension(:, :, :, :), pointer fw
Definition: blockPointers.F90:128
blockpointers::nz
integer(kind=inttype) nz
Definition: blockPointers.F90:38
blockpointers::vx
real(kind=realtype), dimension(:, :, :), pointer vx
Definition: blockPointers.F90:133
blockpointers::je
integer(kind=inttype) je
Definition: blockPointers.F90:39
blockpointers::radi
real(kind=realtype), dimension(:, :, :), pointer radi
Definition: blockPointers.F90:152
blockpointers::ke
integer(kind=inttype) ke
Definition: blockPointers.F90:39
blockpointers::indfamilyi
integer(kind=inttype), dimension(:, :, :), pointer indfamilyi
Definition: blockPointers.F90:105
blockpointers::x
real(kind=realtype), dimension(:, :, :, :), pointer x
Definition: blockPointers.F90:94
blockpointers::visckmaxpointer
integer(kind=inttype), dimension(:, :), pointer visckmaxpointer
Definition: blockPointers.F90:92
blockpointers::visciminpointer
integer(kind=inttype), dimension(:, :), pointer visciminpointer
Definition: blockPointers.F90:87
blockpointers::rotmatrixi
real(kind=realtype), dimension(:, :, :, :, :), pointer rotmatrixi
Definition: blockPointers.F90:113
blockpointers::kl
integer(kind=inttype) kl
Definition: blockPointers.F90:38
blockpointers::il
integer(kind=inttype) il
Definition: blockPointers.F90:38
blockpointers::rotmatrixk
real(kind=realtype), dimension(:, :, :, :, :), pointer rotmatrixk
Definition: blockPointers.F90:115
cgnsgrid::cgnsdoms
type(cgnsblockinfotype), dimension(:), allocatable cgnsdoms
Definition: cgnsGrid.F90:495
cgnsgrid::massflowfamilydiss
real(kind=realtype), dimension(:, :), allocatable massflowfamilydiss
Definition: cgnsGrid.F90:547
cgnsgrid::massflowfamilyinv
real(kind=realtype), dimension(:, :), allocatable massflowfamilyinv
Definition: cgnsGrid.F90:546
constants::roe
integer(kind=inttype), parameter roe
Definition: constants.F90:155
constants::vanleer
integer(kind=inttype), parameter vanleer
Definition: constants.F90:155
constants::firstorder
integer(kind=inttype), parameter firstorder
Definition: constants.F90:142
constants::zero
real(kind=realtype), parameter zero
Definition: constants.F90:71
constants::three
real(kind=realtype), parameter three
Definition: constants.F90:74
constants::third
real(kind=realtype), parameter third
Definition: constants.F90:81
constants::thresholdreal
real(kind=realtype), parameter thresholdreal
Definition: constants.F90:101
constants::ausmdv
integer(kind=inttype), parameter ausmdv
Definition: constants.F90:155
constants::eighth
real(kind=realtype), parameter eighth
Definition: constants.F90:84
constants::turkel
integer(kind=inttype), parameter turkel
Definition: constants.F90:165
constants::itu1
integer, parameter itu1
Definition: constants.F90:40
constants::irho
integer, parameter irho
Definition: constants.F90:34
constants::imx
integer, parameter imx
Definition: constants.F90:65
constants::choimerkle
integer(kind=inttype), parameter choimerkle
Definition: constants.F90:165
constants::vanalbeda
integer(kind=inttype), parameter vanalbeda
Definition: constants.F90:160
constants::boundflux
integer(kind=portype), parameter boundflux
Definition: constants.F90:29
constants::noflux
integer(kind=portype), parameter noflux
Definition: constants.F90:28
constants::eulerequations
integer(kind=inttype), parameter eulerequations
Definition: constants.F90:110
constants::ivx
integer, parameter ivx
Definition: constants.F90:35
constants::normalflux
integer(kind=portype), parameter normalflux
Definition: constants.F90:30
constants::irhoe
integer, parameter irhoe
Definition: constants.F90:38
constants::five
real(kind=realtype), parameter five
Definition: constants.F90:76
constants::noprecond
integer(kind=inttype), parameter noprecond
Definition: constants.F90:165
constants::one
real(kind=realtype), parameter one
Definition: constants.F90:72
constants::half
real(kind=realtype), parameter half
Definition: constants.F90:80
constants::steady
integer(kind=inttype), parameter steady
Definition: constants.F90:115
constants::ivz
integer, parameter ivz
Definition: constants.F90:37
constants::two
real(kind=realtype), parameter two
Definition: constants.F90:73
constants::minmod
integer(kind=inttype), parameter minmod
Definition: constants.F90:160
constants::fourth
real(kind=realtype), parameter fourth
Definition: constants.F90:82
constants::imz
integer, parameter imz
Definition: constants.F90:67
constants::nolimiter
integer(kind=inttype), parameter nolimiter
Definition: constants.F90:160
constants::imy
integer, parameter imy
Definition: constants.F90:66
constants::nsequations
integer(kind=inttype), parameter nsequations
Definition: constants.F90:110
constants::ivy
integer, parameter ivy
Definition: constants.F90:36
constants::ransequations
integer(kind=inttype), parameter ransequations
Definition: constants.F90:110
flowutils::etot
subroutine etot(rho, u, v, w, p, k, etotal, correctForK)
Definition: flowUtils.F90:675
flowvarrefstate::gammainf
real(kind=realtype) gammainf
Definition: flowVarRefState.F90:70
flowvarrefstate::pinfcorr
real(kind=realtype) pinfcorr
Definition: flowVarRefState.F90:69
flowvarrefstate::rgas
real(kind=realtype) rgas
Definition: flowVarRefState.F90:70
flowvarrefstate::nwf
integer(kind=inttype) nwf
Definition: flowVarRefState.F90:17
flowvarrefstate::tref
real(kind=realtype) tref
Definition: flowVarRefState.F90:39
flowvarrefstate::nw
integer(kind=inttype) nw
Definition: flowVarRefState.F90:17
flowvarrefstate::rhoinf
real(kind=realtype) rhoinf
Definition: flowVarRefState.F90:69
flowvarrefstate::timeref
real(kind=realtype) timeref
Definition: flowVarRefState.F90:40
fluxes
Definition: fluxes.F90:1
fluxes::invisciddissfluxmatrixcoarse
subroutine invisciddissfluxmatrixcoarse
Definition: fluxes.F90:5206
fluxes::invisciddissfluxmatrixapprox
subroutine invisciddissfluxmatrixapprox
Definition: fluxes.F90:4345
fluxes::invisciddissfluxscalarcoarse
subroutine invisciddissfluxscalarcoarse
Definition: fluxes.F90:4978
fluxes::invisciddissfluxscalar
subroutine invisciddissfluxscalar
Definition: fluxes.F90:1050
fluxes::invisciddissfluxmatrix
subroutine invisciddissfluxmatrix
Definition: fluxes.F90:404
fluxes::inviscidcentralflux
subroutine inviscidcentralflux
Definition: fluxes.F90:5
fluxes::viscousfluxapprox
subroutine viscousfluxapprox
Definition: fluxes.F90:3488
fluxes::inviscidupwindflux
subroutine inviscidupwindflux(fineGrid)
Definition: fluxes.F90:1439
fluxes::viscousflux
subroutine viscousflux
Definition: fluxes.F90:2535
fluxes::invisciddissfluxscalarapprox
subroutine invisciddissfluxscalarapprox
Definition: fluxes.F90:3862
inputdiscretization::vis2
real(kind=realtype) vis2
Definition: inputParam.F90:78
inputdiscretization::vis2coarse
real(kind=realtype) vis2coarse
Definition: inputParam.F90:78
inputdiscretization::sigma
real(kind=realtype) sigma
Definition: inputParam.F90:83
inputdiscretization::orderturb
integer(kind=inttype) orderturb
Definition: inputParam.F90:73
inputdiscretization::riemanncoarse
integer(kind=inttype) riemanncoarse
Definition: inputParam.F90:74
inputdiscretization::vis4
real(kind=realtype) vis4
Definition: inputParam.F90:78
inputdiscretization::kappacoef
real(kind=realtype) kappacoef
Definition: inputParam.F90:80
inputdiscretization::riemann
integer(kind=inttype) riemann
Definition: inputParam.F90:74
inputdiscretization::limiter
integer(kind=inttype) limiter
Definition: inputParam.F90:73
inputdiscretization::precond
integer(kind=inttype) precond
Definition: inputParam.F90:74
inputiteration::disscontmidpoint
real(kind=realtype) disscontmidpoint
Definition: inputParam.F90:297
inputiteration::usedisscontinuation
logical usedisscontinuation
Definition: inputParam.F90:296
inputiteration::disscontmagnitude
real(kind=realtype) disscontmagnitude
Definition: inputParam.F90:297
inputiteration::disscontsharpness
real(kind=realtype) disscontsharpness
Definition: inputParam.F90:297
inputphysics::equations
integer(kind=inttype) equations
Definition: inputParam.F90:583
inputphysics::equationmode
integer(kind=inttype) equationmode
Definition: inputParam.F90:583
inputphysics::prandtlturb
real(kind=realtype) prandtlturb
Definition: inputParam.F90:596
inputphysics::useqcr
logical useqcr
Definition: inputParam.F90:587
inputphysics::wallfunctions
logical wallfunctions
Definition: inputParam.F90:589
inputphysics::prandtl
real(kind=realtype) prandtl
Definition: inputParam.F90:596
iteration::totalr0
real(kind=realtype) totalr0
Definition: iteration.f90:126
iteration::currentlevel
integer(kind=inttype) currentlevel
Definition: iteration.f90:18
iteration::totalr
real(kind=realtype) totalr
Definition: iteration.f90:126
iteration::groundlevel
integer(kind=inttype) groundlevel
Definition: iteration.f90:18
iteration::rkstage
integer(kind=inttype) rkstage
Definition: iteration.f90:19
iteration::rfil
real(kind=realtype) rfil
Definition: iteration.f90:36
solverutils::utauwf
subroutine utauwf(rFilv)
Definition: solverUtils.F90:3173
utils
Definition: utils.F90:1
utils::getcorrectfork
logical function getcorrectfork()
Definition: utils.F90:487
utils::mydim
real(kind=realtype) function mydim(x, y)
Definition: utils.F90:473
utils::terminate
subroutine terminate(routineName, errorMessage)
Definition: utils.F90:502
Generated by doxygen 1.9.1