...

Chung2010_.pdf

by user

on
Category: Documents
6

views

Report

Comments

Transcript

Chung2010_.pdf
A COMPUTER PROGRAM FOR THE SOLUTION OF NAVIER-STOKES
SYSTEM OF EQUATIONS USING THE FLOWFIELD-DEPENDENT
VARIATION (FDV) METHOD WITH FINITE ELEMENTS
This is a computer program for the solution of Navier-Stokes system of equations in
which all features of flows are included to accommodate a wide variety of Mach
numbers and Reynolds numbers (compressible, incompressible, inviscid, and
viscous flows). The governing equations are of the form (conservation form of the
Navier-Stokes system of equations):
∂U ∂F i ∂G i
+
+
=B
∂t ∂x i ∂x i
The solution is carried out using the Flowfield-Dependent Variation (FDV) method
with element-by-element (EBE) assembly via Generalized Minimal Residual
(GMRES) solution scheme using finite element discretizations with isoparametric
elements and Gaussian quadrature integrations.
The advantages of FDV method are:
(1) The first order FDV parameters (s 1 , s 3 ) as calculated from the current
flowfield variables (Mach numbers and Reynolds numbers) assure the
accuracy of solution. They alter the roles of each term in the governing
equations in different positions of the domain, reflecting the incompressible
behavior very close to the wall and compressible behavior or shock wave
discontinuities away from the wall automatically. This can be demonstrated
by contour plots of the FDV parameters themselves resembling the actual
flowfields. The FDV scheme provides accurate solutions in turbulence with
DNS mesh configurations and in supersonic combustion through FDV
Jacobians.
(2) The second order FDV parameters (s 2 , s 4 ) assure the stability of solution
process.
(3) A single program based on the FDV theory is capable of accommodating all
different flow physics, high speed or low speed, compressible or
incompressible, viscous or inviscid, in 1-D, 2-D, and 3-D geometries.
(4) The FDV method can be applied to both FDM and FEM geometries.
Note:
The FDV method is used to solve all problems, demonstrating that
incompressible, compressible, viscous, and inviscid flows in 1D, 2D, and
3D can be solved with one code. FDV parameters as calculated will
determine different types of flows throughout the domain and time.
1
Example problems include:
A. Incompressible viscous flow
A-1 2-D lid driven cavity
A-2 2-D Backstep
B. Compressible inviscid flow (1-D shock tube)
C. Compressible viscous flow
C-1 2-D flat plate
C-2 3-D flat plate
C-3 2-D compression corner
C-3-1 Geometry 1
C-3-2 Geometry 2
C-4 3-D compression corner
C-5 Mach 20 Shock wave turbulent boundary layer interaction problem with an
impinging shock wave
2
A. INCOMPRESSIBLE VISCOUS FLOW
A-1. TWO-DIMENSIONAL LID-DRIVEN CAVITY
U0 = 1, v0 = 0
H=1
u = 0, v = 0
∂T/∂n = 0
L=1
Solve for the following cases
(1) Re = 1000, (2) Re = 3200, (3) Re = 5000
Solutions:
Using FDV FEM, assume a freestream Mach number of 0.05 and a freestream temperature of 460 R, and
use the100 x 100 finite element grid shown below. Results can be compared with Ghia, U., Ghia, K.N, and
Shin, C.T., “High-Re Solutions for Incompressible Flow Using the Navier-Stokes Equations and a
Multigrid Method,” Journal of Computational Physics, 48, 387-411 (1982).
(1) Re = 1000
Plots of convection and diffusion FDV parameters, streamlines and velocity vectors are shown below. The
size of the corner vortices agree well with the streamline plots of Ghia, et al.
3
Convection FDV Parameters (s1)
Diffusion FDV Parameters (s3)
Streamlines
Velocity Vectors
Below are plots of the horizontal velocity along a vertical line through the geometric center of the cavity
and the vertical velocity along a horizontal line through the geometric center. The results agree well with
the results of Ghia, et al.
4
0.50
1.20
0.40
0.30
1.00
0.20
0.10
ebeFDV
Ghia Re 1000
0.60
V/Uinf
Y/L
0.80
0.00
0.00
0.20
0.40
0.60
0.80
1.00
1.20
ebeFDV
Ghia Re 1000
-0.10
-0.20
0.40
-0.30
0.20
-0.40
-0.50
-0.60
-0.40
-0.20
0.00
0.00
0.20
0.40
0.60
0.80
1.00
-0.60
1.20
X/L
U/Uinf
(2) Re = 3200
Plots of the convection and diffusion FDV parameters, streamlines and velocity vectors are shown below.
The FDV algorithm successfully resolves the vortices that form in the two lower corners. The size of these
vortices agrees well with the results of Ghia, et al.
Convection FDV Parameters (s1)
Diffusion FDV Parameters (s3)
5
Streamlines
Velocity Vectors
1.20
0.60
1.00
0.40
0.80
0.20
ebeFDV
Ghia Results
0.60
V/Uinf
Y/L
Plots of horizontal velocity through a vertical line through the geometric center and of the vertical velocity
through a horizontal line through the geometric center are shown below. These plots agree well with the
calculations of Ghia, et al.
0.00
0.00
0.20
0.40
0.60
0.40
-0.20
0.20
-0.40
-0.60
-0.40
-0.20
0.00
0.00
0.20
0.40
0.60
0.80
1.00
-0.60
1.20
X/L
U/Uinf
6
0.80
1.00
1.20
ebeFDV
Ghia Results
(3) Re = 5000
Plots of convection and diffusion FDV parameters, streamlines and velocity vectors are shown below. The
FDV algorithm successfully captures the vortices in the lower two corners of the cavity, as well as the
vortex in the upper left hand corner.
Convection FDV Parameters (s1)
Diffusion FDV Parameters (s3)
Streamlines
Velocity Vectors
Reasonable agreement with the calculations of Ghia, et al, is indicated below for plots of the horizontal
velocity through a vertical line through the cavity’s geometric center and of the vertical velocity through a
horizontal line through the geometric center.
7
0.60
1.20
0.40
1.00
0.20
ebe FDV
Ghia Results
0.60
V/Uinf
Y/L
0.80
0.00
0.00
0.20
0.40
0.60
0.80
1.00
1.20
ebe FDV
Ghia Results
-0.20
0.40
-0.40
0.20
-0.60
-0.60
-0.40
0.00
-0.20
0.00
0.20
0.40
0.60
0.80
1.00
1.20
-0.80
X/L
U/Uinf
Plot of u-velocity along vertical line through the geometric center of cavity
A-2. TWO-DIMENSIONAL BACKSTEP
Inlet:
v = 0, u parabolic
∂ / ∂n = 0
ρ = 1, T = 1, T∞ = 46
1
u = v = 0,
∂T
=0
∂n
1
y
38
6
x
Initially, interior nodes set to:
u = 0 , v = 0 , ρ = 1, T = 1
Solve and plot the streamline distributions for (1) Re = 150 and (2) Re = 500
Solution: Using FDV FEM and assuming a freestream Mach number of 0.05 and a freestream temperature
of 460 R.
(1) For Re = 150, a plot of the streamlines and velocity vectors are shown below.
8
Streamlines for Re =150
B.
Velocity Vectors near step for Re = 150
COMPRESSIBLE INVISCID FLOW
(ONE-DIMENSIONAL SHOCK TUBE)
Initial conditions: PL = 10 ,
5
ρ L = 1, PR = 104 , ρ R = 0.125, uL = uR = 0
Geometry and boundary conditions
ρ = ρL
ρ = ρR
P = PL
P = PR
u=0
State L
u=0
Diaphragm
State R
Schematic Diagram of Shock Tube Flow
9
Initial position
of diaphragm
L
3
2
R
V
Expansion
Wave
C
Contact Shock Wave
Discontinuity
Governing equations
⎡ρ⎤
U = ⎢⎢ ρu ⎥⎥
⎢⎣ ρE ⎥⎦
∂U ∂F
+
=0
∂t
∂x
⎡ ρu ⎤
F = ⎢⎢ ρu 2 ⎥⎥
⎢⎣(ρE + p )u ⎥⎦
Analytical Solution: The analytical solution can be calculated from the initial conditions as follows.
Referring to the schematic drawing of the shock tube problem shown above, and given the initial pressure
ratio, P2 PR ≡ P . The properties at position 2 to the left of the shock wave can be calculated from the
pressure ratio as follows:
ρ2 1 + α P
,
=
ρR α + P
with
α=
C − uR ( P − 1) aR
,
=
aR
γ ( u2 − u R )
γ + 1 u2 − u R
P −1
1
.
=
12
γ −1
aR
(1 + α P ) γ (γ − 1) 2
a2
aR
2
=P
α+P
1+α P
where C is the propagation speed of the shock wave and a is the speed of sound.
The contact surface sustains a discontinuity in density, but the pressure and velocities normal to
the surface are continuous. Therefore, the contact discontinuity propagates at a velocity, V , equal to u2 .
Along the contact surface, P3 = P2 and u3 = u2 ≡ V . The density in region 3 is calculated from
P3
γ
ρ3
=
PL
γ
ρL
, and the acoustic velocity is calculated using a3 = aL −
γ −1
2
V.
In region 5 that separates region 3 from region L, there is a continuous variation of the flow
variables through the expansion fan. The flow variables in this region are calculated from
⎛ γ − 1 u5 ⎞
2 ⎛x
γ −1 ⎞
u5 =
uL ⎟ , P5 = PL ⎜1 −
⎟
⎜ + aL +
γ +1⎝ t
2
2 cL ⎠
⎠
⎝
10
2γ
γ −1
, a5 = aL −
γ −1
2
( u5 − uL )
1
⎛ P ργ ⎞ γ
and ρ 5 = ⎜ 5 L ⎟ . These relationships are valid for
⎝ PL ⎠
γ −1 ⎞
⎛ γ −1
⎞ x ⎛ γ +1
−⎜
u L + aL ⎟ < < ⎜
V − aL −
uL ⎟ . This is a time dependent problem. The location
2
⎝ 2
⎠ t ⎝ 2
⎠
of the shock wave, contact discontinuity, and expansion fan changes with time. After solving the Euler
equations using a given numerical method, calculate the analytical solution based on the elapsed time in
your numerical solution. The shock wave will be locate at x = C ⋅ t , the contact discontinuity will be
located at x = V ⋅ t , and the expansion fan will be located at
γ −1 ⎞
⎛ γ −1
⎞
⎛ γ +1
u L + aL ⎟ < x < t ⎜
V − aL −
uL ⎟ .
−t ⎜
2
⎝ 2
⎠
⎝ 2
⎠
Solution (using FDV FEM)
Plots of the density, pressure, and Mach number distribution compared with the exact solution are shown
below. These plots indicate the continuous variation of the density and pressure through the expansion
wave that propagates to the left from the diaphragm into the high pressure region. To the right of the
diaphragm, a contact discontinuity and a shock wave propagates into the low pressure region. There is an
instantaneous drop of the density through both the contact discontinuity and the shock wave. Note that the
pressure remains constant through the contact discontinuity, but drops instantaneous through the shock
wave.
9
8
7
RHO/RHOinf
6
5
EBE_FDV
Analytic Solution (t=5.19 ms)
4
3
2
1
0
-0.6
-0.4
-0.2
0
0.2
0.4
0.6
X/L
Shock Tube Density Distribution
12
10
P/Pref
8
EBEFDV (2500 Elements)
Analytical Solution (5.19 ms)
6
4
2
0
-0.6
-0.4
-0.2
0
0.2
0.4
0.6
X/L
Shock Tube Pressure Distribution
11
1
0.9
0.8
Mach Number
0.7
0.6
EBEFDV (2500 Elements)
Analytical Solution (5.19 ms)
0.5
0.4
0.3
0.2
0.1
0
-0.6
-0.4
-0.2
0
0.2
0.4
0.6
X/L
Shock Tube Mach number Distribution
C.
COMPRESSIBLE VISCOUS FLOW
Governing Equations (Navier Stokes System of Equations)
∂ U ∂ Fi ∂G i
+
+
=0
∂ t ∂ xi ∂ xi
⎡ ρ ⎤
U = ⎢⎢ ρV j ⎥⎥ ,
⎢⎣ ρE ⎥⎦
ρV i
⎡
⎤
⎢
F i = ⎢ ρV iV j+ Pδ ij ⎥⎥ ,
⎢⎣ (ρE + P )V i ⎥⎦
⎡
⎤
0
⎢
⎥
G i = ⎢ −τ ij ⎥
⎢−τ ijV j− q i ⎥
⎣
⎦
C-1. 2-D FLAT PLATE
Given: Flow over a flat plate shown below with the following freestream conditions:
M∞ = 3
Re L = 1000
Pr = 0.72
γ = 1.4
T∞ = 390 R .
An isothermal wall is assumed with the wall temperature set equal to the freestream stagnation
⎛
⎝
temperature, Twall = T∞ ⎜ 1 +
γ −1
⎞
M ∞2 ⎟ .
2
⎠
12
Initial 45 x 31 grid (1395 elements)
13
FDV Parameters
14
Close-up of velocity vectors near wall, Flat Plate, Mach 3, Re 1000
0.25
6.00
5.00
3.00
Level 1 Grid
Carter's Results
2.00
Wall Skin Friction Distribution
Wall Pressure Distribution P/Pinf
0.20
4.00
0.15
Level 1 Grid
Carter's Results
0.10
1.00
0.05
0.00
0.00
0.20
0.40
0.60
0.80
1.00
1.20
0.00
0.00
-1.00
0.20
0.40
0.60
0.80
1.00
1.20
X/L
X/L
Wall Pressure Distribution
Wall Skin Friction Distribution
15
C-2. Three-Dimensional Flat Plate
Boundary conditions for a three-dimensional version of Carter’s flat plate are shown
below. The plate is assumed to be infinite in width, with symmetry conditions applied on the
left and right sides of the plate. Freestream conditions are the same as for the twodimensional version of Carter’s flat plate. One other boundary condition deserves mention.
On the left and right edges of the domain in front of the plate leading edge, there is an
intersection between a symmetry condition in the y-z plane (u = 0) and a symmetry
conditions in the x-y plane (w = 0). For these points on the edge, both u and w velocity
components are set to zero.
Geometry and Boundary Conditions
Density Contours
Finite Element Grid (52,800 Elements)
Pressure Contours
FDV Parameters
16
Mach Number Contours
C-3.
2-D Compression Corner
Solve the Navier Stokes System Equations for the following inflow conditions
⎛
⎝
Case (1) M = 3.0, Re = 1.68 x 104, Isothermal wall Twall = T∞ ⎜ 1 +
γ −1
⎞
M ∞2 ⎟ , α = 10° , T∞ = 390° R ,
2
⎠
h = 1.2
∂T
= 0 , α = 10° , T∞ = 88° R , h = 0.8
∂n
∂T
Case (3) M = 6.06, Re = 1.5 x 105, Adiabatic Wall,
= 0 . α = 10.25° , T∞ = 88° R , h = 0.6
∂n
Case (2) M = 4.0, Re = 6.8 x 104, Adiabatic Wall,
GEOMETRY 1
Symmetry, v = 0,
∂T/∂n = τ12 = 0
Inflow
No-slip wall,
u=v=0
h
Exit
α
0.1
1.0
1.0
Case (1) M = 3.0
Contour plots of density and pressure indicate the formation of shock waves at the leading edge of the flat
plate section of the domain and at the compression surface. A plot of pressure at the wall indicates good
agreement with the numerical results of Carter.
17
Finite Element Grid (92 x 50)
FDV Parameters
Density Contours
Pressure Contours
18
3.00
Wall Pressure Distribution, P/Pinf
2.50
2.00
1.50
EBEFDV (Level 1 Grid)
Carter's Results
1.00
0.50
0.00
0.00
0.50
1.00
1.50
2.00
2.50
-0.50
-1.00
X/Xc
Wall Pressure Distribution
(Carter’s Results from NASA Technical Report NASA TR R-385, July, 1972)
Case (2) Mach = 4
Contour plots of density and pressure show the formation of shock waves at the leading edge of the flat
plate section and at the compression surface. A plot of the pressure at the wall shows good agreement with
the experimental results of Lewis, Kubota, and Lees through the pressure rise in the flow separation region.
Some discrepancy is shown near the exit of the domain, possibly due to an inexact boundary condition at
the exit.
Finite Element Grid (131 x 48)
19
FDV Parameters
Density Contours
Pressure Contours
20
3.00
2.50
Wall Pressure P/Pinf
2.00
1.50
EBE FDV
Experimental Data
1.00
0.50
0.00
0.00
0.50
1.00
1.50
2.00
2.50
-0.50
X/Xc
Wall Pressure Distribution
(Experimental Results from Lewis, Kubota, and Lees, AIAA Journal, January, 1968, pp.7-14)
Case (3) M = 6
As above, contour plots of density and pressure indicate the formation of shock waves at the leading edge
of the flat plate and at the compression surface. A plot of pressure at the wall shows good agreement with
experimental and prior numerical results, with a slight underprediction of the pressure rise through the flow
separation region.
21
Density Contours
Pressure Contours
10.00
8.00
6.00
P/Pref
4.00
ebeFDV
Experiment
Carter's Results
2.00
0.00
0.00
0.50
1.00
1.50
2.00
2.50
-2.00
-4.00
-6.00
X/Xc
Wall Pressure Distribution
(Experimental Results from Lewis, Kubota, and Lees, AIAA Journal, January, 1968, pp.7-14. Carter’s
Results from NASA Technical Report NASA TR R-385, July, 1972)
22
Geometry 2
Symmetry: v = 0
∂T/∂n = τ12 = 0
No-slip, adiabatic wall
u = v = 0, ∂T/∂n = 0
Inflow 1.0
0.8
Exit
0.2
1.0
1.0
1.0
Inlet Conditions: M = 2.0, γ = 1.4, R = 1716 ft / sec ° R, T = 519° R
2
a = γ RT = 1117 ft / sec,
2
ρ = 0.002378 slugs / ft 3
u = 2*1117 = 2234 ft / sec, v = 0, P = 2116 lbf / ft 2
P
1
ρE =
+ ρ ( u 2 + v 2 ) = 11224 lbf / ft 2
γ −1 2
ρV∞ L
Assuming the reference length is 1 inch, Re =
= 1.184 ×106
μ∞
Nondimensional variables:
(ρE)
*
ρ * = 1.0, u* = 1.0, v* = 0, P* =
P
= 0.1783
ρV∞2
= 0.9457
Solution (using FDV FEM):
Contour plots of density and pressure are shown below. These plots indicate the presence of a shock wave
at the leading edge of the flat plate section due to the compression of the incoming supersonic flow by the
formation of the viscous boundary layer and a shock wave at the compression section of the domain. Both
of these shock waves are reflected at the top surface due to the specification of a symmetry (no flow)
boundary condition for the top surface. An expansion fan forms at the beginning of the constant area
section following the compression section of the domain.
23
Finite Element Grid
Density Contours
Pressure Contours
24
C-4
3-D COMPRESSION CORNER
(a depth of 1.0 in the third dimension and the addition of a no-slip wall on the back
side, same inlet conditions as prob 4a (compressible viscous)
No-slip Walls,
u=v=w=0
∂T/∂n = 0
0.6
1.0
z
1.0
y
x
0.6
Solution (using FDV FEM):
The results are compared with the numerical results in Hung, C.M and MacCormack, R.W., “Numerical
Solution of Supersonic Laminar Flow Over a Three-Dimensional Compression Corner,” AIAA Paper 77694, June 1977. Density contours at Y/L of 0.3292 indicate the intersection of the two leading edge shocks
formed at the leading edge of the flat plate and at the leading edge of side wall. The intersections of these
shock waves form a corner shock in the lower left corner. Also shown in the plot are the boundary layers
on the two surfaces.
Density Contours at Y=0.3292 showing intersection of two leading edge shocks
The density and pressure contour plots below are taking downstream of the compression surface. The
density plot on the left shows the interaction of the wedge shock with the boundary layer on the side wall.
Also, in the upper right hand corner, one observes the formation of a corner shock from the intersection of
the reflection of the sidewall leading edge shock from the opposite symmetry side wall with the reflection
of the flat plate leading edge shock from the top surface.
25
Density and Pressure contours at Y = 1.59
C-5 SHOCK WAVE TURBULENT BOUNDARY LAYER INTERACTION
PROBLEM WITH AN INPINGING SHOCK WAVE
The geometry and boundary conditions for the interaction of an oblique shock
wave with a viscous boundary layer is shown below. The shock wave is generated by the
supersonic flow being compressed through an angle, θ, with a resulting shock angle, β.
ρ 2* , T2* , u2* , v2*
β
ρ1* = 1
T1* = 1
Shock
No slip,
adiabatic wall
Boundary
Layer
u =1
*
1
v1* = 0
0.1
1.5
26
0.25
The flow variables are set to the undisturbed freestream conditions on the left side
and to post-shock flow conditions on the top surface. The flat plate is a no-slip, adiabatic
surface. The subscript 1 denotes the undisturbed freestream conditions, the subscript 2
denotes the post-shock flow conditions, and the asterisk superscript indicates nondimensional variables. The asterisks are omitted in the equations below for simplicity.
The post-shock flow conditions are calculated from the inviscid flow relations as shown
below.
Assume freestream conditions of M ∞ = 2, T0 ∞ = 295K , and a shock deflection
angle of θ = 10° . The shock angle, β, can be obtained from the θ − β − M chart or the
θ − β − M relation shown below.
⎡ M 2 sin 2 β − 1 ⎤
tan θ = 2cot β ⎢ 2 1
⎥
⎣ M 1 ( γ + cos 2 β ) + 2 ⎦
For M ∞ = 2 and θ = 10° , then β = 39.3137° . The normal component of Mach number
upstream of the shock wave, M n1 = M 1 sin β = 1.267 . The density and pressure ratios
across the shock wave are calculated from
(γ + 1) M n21 = 1.458
ρ2
=
ρ1 ( γ − 1) M n21 + 2
P2
2γ
= 1+
M n21 − 1) = 1.706
(
γ +1
P1
The normal component of the Mach number downstream of the shock wave is calculated
from
M
2
n2
M n21 + ⎡⎣ 2 ( γ − 1) ⎤⎦
=
= 0.645
⎡⎣ 2γ ( γ − 1) ⎤⎦ M n21 − 1
M n 2 = 0.803 .
The temperature ratio downstream of the shock wave is calculated from
T2 P2 ρ1
=
= 1.170 .
T1 P1 ρ 2
M n2
= 1.640 .
sin ( β − θ )
From these calculations, one can calculate the input flow variables for the top surface.
Finally, the Mach number downstream of the shock wave is M 2 =
ρ
ρ = 2 ρ1* = 1.458
ρ1
*
2
T
T = 2 T1* = 1.170
T1
*
2
27
u = M2
*
2
γ P2*
cosθ = 0.874
ρ 2*
v2* = − M 2
γ P2*
sin θ = −0.154
ρ 2*
The post shock conditions for Mach numbers of 2, 4, 14.1, and 20 are shown in the table
below.
Mach
T0
Re
θ
β
ρ 2*
2
4
14.1
20
295 K
295 K
2385 K
2400 K
300,000
300,000
300,000
300,000
10°
10°
10°
10°
39.3137°
22.234°
13.329°
12.7016°
1.458
1.886
4.0729
4.7685
28
T2*
1.170
1.330
2.986
4.7017
u2*
0.874
0.932
0.960
0.9618
v2*
-0.154
-0.164
-0.169
-0.1696
First Order Convection FDV Parameters (s1)
29
First Order Dissipation FDV Parameters (s3)
30
Temperature Contours
31
Pressure Contours
32
Velocity Vectors
33
Velocity Vectors near wall in Boundary Layer
34
Enhanced View of Mach 20 Velocity Vectors near the wall
35
FLOWCHART FOR FDV PROGRAM
START
OPENING
INPUT
CONSVAR
BLOCK
GENBFAC
NDIMN = 2
NDIMN = 3
WHAT
IS
NDIMN
GENBFAC3
GAUSINT
NDIMN = 1
ELELENG
A
NDIMN = 2
WHAT
IS
NDIMN
EVALELE
NDIMN = 3
EVALELE3D
1
1
1
CFLTODT
IMPARM
NDIMN = 1
CONVFLX1
TIME
MARCHING
LOOP
NDIMN = 2
WHAT
IS
NDIMN
CONVFLX
NDIMN = 3
CONVFLX3
MEIEQNS
SOLVE
RMSERR
PRIMVAR
2
2
B
GMRES_EBE
C
2
OUTPUT
OUTIMP
END
A
GAULEG
WHAT
IS
NDIMN?
SHAP1D
1
2
SHAPDOM
3
SHAPDOM3
SHAPSURF
SHAPSURF_3D
RETURN
3
B
1
ONED_INGRL
WHAT
IS
NDIMN?
E1
3
DOMINGRL3D
E3
BOUINGRL3D
2
E2
F
DOMINGRL
BOUINGRL
BC
RETURN
4
G
D2
C
NO
DIAG_PRECOND
ELECNCT
H
IS
ADAP
TRUE?
YES
ADPCLER
LU_PRECOND
RECHANG
J
EL2NORM
AU_PRODUCT
K
ERR_IMPL
PRECOND
BUFFER
LOCAL
RETURN
SWITCH
UNREFINE
DIVIDE
REFINE
NODCNCT
TWODSORT
RENUMB
BLOCK
EVALELE
EXCHANG
5
RETURN
E1
E2
DERSH1D
DERSHA
EVALDOM
E3
DERSHA_3D
EVALDOM
EVALDOM
AJACOB
AJACOB_3D
AJACOB1
VISCFLX
VISCFLX_3D
MATXMULT
Parallel
Element
Loop
BJACOB
RETURN
CJACOB
BJACOB_3D
CJACOB_3D
MATXMULT
RETURN
MATXMULT
RETURN
6
F
G
CALNORM
CALNORM3
EVALBOU
EVALBOU3D
AJACOB_3D
AJACOB
VISCFLX_3D
VISCFLX
BJACOB
BJACOB_3D
CJACOB
CJACOB_3D
MATXMULT
MATXMULT
RETURN
RETURN
7
H
J
LOCAL
Parallel
Processing
Parallel
Loop
PRECOND
AU_PRODUCT
K
RETURN
RETURN
K
LOCAL
Parallel
Processing
LOCAL
RETURN
8
SUBROUTINE FUNCTIONS
Subroutine OPENING – Opens input/output files and reads in initial parameters and fluid properties
Subroutine INPUT – Reads in element connectivity, nodal point coordinates, initial flow variables, and
boundary point information
Subroutine CONSVAR – Calculates conservation variables from primitive variables
Subroutine BLOCK – Groups elements in blocks of non-adjacent elements to allow element operations to
be performed in parallel (Ref: Shakib, Hughes, and Johan, 1989, and Hughes, Ferencz, and Hallquist, 1987)
Subroutine GENBFAC – Generates information on boundary face connectivity for 2-D flow
Subroutine GAUINT – Calculates information for Gauss-Legendre integration for the domain and surface
integrals. This subroutine calls GAULEG, SHAPDOM, SHAPSURF, SHAP1D, SHAPDOM3, and
SHAPSURF_3D.
Subroutine SHAPDOM – Calculates two-dimensional shape functions and their derivatives for twodimensional flow calculations.
Subroutine SHAPSURF – Calculates one-dimensional shape functions and their derivatives for evaluating
surface integrals in two-dimensional calculations
Subroutine SHAP1D – Calculates one-dimensional shape functions and their derivatives for onedimensional flow calculations.
Subroutine GAULEG – Calculates weighting functions and abscissas for Gauss-Legendre integration.
Enables user to change number of Gaussian points used on the fly without major reprogramming.
Subroutine ELELENG – Calculates characteristic lengths for one-dimensional elements
Subroutine EVALELE – Calculates characteristic lengths for two-dimensional elements.
Subroutine DERSHA – Calculates spatial derivatives of shape functions in two-dimensions.
Subroutine DERSHA1D – Calculates spatial derivatives of shape functions in one-dimension.
Subroutine PRIMVAR – Calculates primitive variables from conservation variables.
Subroutine CFLTODT –Calculates time step from CFL number and flow conditions.
Subroutine IMPARM – Calculates variation parameters for the elements based on local Mach numbers,
Reynolds numbers, and Peclet numbers in element.
Subroutine CONVFLX1 – Calculates convective flux from flow conditions in one-dimensional flow.
Subroutine CONVFLX – Calculates convective flux from flow conditions in two-dimensional flow.
Subroutine MEIEQNS – Main subroutine to begin building process for the FDV equations.
Subroutine ONED_INGRL – Calculates element matrices and right-hand-side (RHS) vector for FDV
equations in one-dimensional flow.
Subroutine DOMINGRL – Calculates domain integral terms in element matrices and RHS vector for FDV
equations in two-dimensional flow.
9
Subroutine DOMINGRL3D – Calculates domain integral terms in element matrices and RHS vector for
FDV equations in three-dimensional flow.
Subroutine BOUINGRL3D – Calculates surface integral terms in element matrices and RHS vector for
FDV equations in three-dimensional flow.
Subroutine BOUINGRL - Calculates surface integral terms in element matrices and RHS vector for FDV
equations in two-dimensional flow.
Subroutine EVALBOU – Calculates flow variables at each Gaussian point during evaluation of the surface
integrals for two-dimensional flow.
Subroutine APLBNCN2D – Applies boundary conditions to surface integrals for two-dimensional flow.
Subroutine APLBNDCND – Applies boundary conditions to surface integrals for three-dimensional flow.
Subroutine JACBNC2D – Applies boundary conditions to Jacobians in surface integrals for twodimensional flow (Ref: Chung, 2002).
Subroutine JACBNDCND - Applies boundary conditions to Jacobians in surface integrals for threedimensional flow (Ref: Chung, 2002).
Subroutine BC – Applies boundary conditions to element matrices before transfer to equation solver.
Subroutine AJACOB1 – Calculates one-dimensional convection Jacobians
Subroutine AJACOB – Calculates two-dimensional convection Jacobians.
Subroutine EVALDOM – Calculates flow variables at each Gaussian point during evaluation of domain
integrals.
Subroutine BJACOB – Calculates two-dimensional dissipation Jacobians.
Subroutine CJACOB – Calculates two-dimensional dissipation-gradient Jacobians.
Subroutine VISCFLX – Calculates two-dimensional viscous flux terms.
Subroutine MATXMULT – Performs multiplication of two Jacobians matrices.
Subroutine CALNORM – Calculates direction cosines of unit normal vector to boundary surface for twodimensional flow calculations.
Subroutine SOLVE – Initiates equation solver routines.
Subroutine GMRES_EBE – Solves system of equations using an element-by-element GMRES algorithm
with left preconditioning.
Subroutine PRECOND – Applies LU-preconditioning to system of equations in GMRES algorithm.
Subroutine DIAG_PRECOND – Applies Diagonal preconditioning to system of equations in GMRES
algorithm. Ref: Shakib, 1989.
Subroutine LOCAL – Performs gathering and scattering operations on element matrices for GMRES
algorithm.
10
Subroutines FWDSUBSTN and BACKSUBSTN – perform forward reduction and back substitution
operations on element matrices for preconditioning operations. These subroutines are not used in current
version of program. These operations are incorporated in subroutines PRECOND, LU_PRECOND, and
SOR_PRECOND.
Subroutine LU_PRECOND – Performs LU factorization of element matrices and initial preconditioning
operations.
Subroutine SOR_PRECOND – Performs preconditioning operations using a successive over-relaxation
preconditioner of the form M = ( I − ω E ) × ( I − ω F ) , where
−E and −F are the strict lower and strict
upper components of the stiffness matrix, and ω is a relaxation factor. This preconditioner was used for
three-dimensional problems to avoid the extra storage required for storing the LU factorization of the
element matrices. 0 ≤ ω ≤ 1
Subroutine LU_FACT – Performs LU factorization of a matrix. This subroutine is not currently used. This
operation is incorporated in subroutine LU_PRECOND.
Subroutine AU_PRODUCT – Calculates product of element matrices with a vector and assembles it into a
single column vector.
Subroutine MATX_VEC – Earlier subroutine to calculate a matrix-vector product. This subroutine is not
used in current version.
Subroutine EL2NORM – Calculates L2 norm of a vector in GMRES algorithm.
Subroutine DOTPROD – Calculates dot product of two vectors.
Subroutines CNSTWLTMP and APLBOUN – These subroutines are not used in current version. These
subroutines were used previously to apply the constant wall temperature boundary condition and to apply
boundary conditions to the equations.
Subroutine RMSERR – Calculates the RMS error of the system of equations to monitor convergence.
Subroutine OUTPUT – Writes value of element connectivity, nodal coordinates, flow variables, etc., to a
file. The resulting file can be read back into the program as a new input file to restart the calculations at the
end of the specified number of time steps.
Subroutine OUTIMP – Writes the values of the variation parameters at the nodal points for plotting
purposes.
Subroutine WALLPRES3D – Calculates wall pressure and writes it to a file for plotting purposes for threedimensional problems.
Subroutine QUICK_SORT_2D – Uses a quick sort routine to sort a list of items ascending in the x any y
directions.
Subroutine WALLPROPT – Calculates wall pressure, skin friction, and heat transfer distributions at the
wall for two-dimensional problems.
Subroutine QUICK_SORT – Uses a quick sort routine to sort the wall pressure, skin friction, heat transfer
ascending in the x direction.
Subroutine GENBFAC3 – Generates information on the boundary face connectivity of a two-dimensional
boundary surface in three-dimensional flow.
11
Subroutine SHAPDOM3 - Calculates three-dimensional shape functions and their derivatives for threedimensional flow calculations.
Subroutine DERSHA_3D - Calculates spatial derivatives of shape functions in three-dimensions.
Subroutine SHAPSURF_3D - Calculates two-dimensional shape functions and their derivatives for
evaluating surface integrals in three-dimensional calculations
Subroutine CONVFLX3 - Calculates convective flux from flow conditions in three-dimensional flow.
Subroutine EVALELE3D – Calculates characteristic lengths for three-dimensional elements.
Subroutine GPG – Calculates Petrov-Galerkin terms. This subroutine is not used in the current version.
Subroutine AJACOB_3D – Calculates convection Jacobians in three-dimensions.
Subroutine BJACOB_3D – Calculates dissipation Jacobians in three-dimensions.
Subroutine CJACOB_3D – Calculates dissipation gradient Jacobians in three-dimensions.
Subroutine EVALBOU3D - Calculates flow variables at each Gaussian point during evaluation of the
surface integrals for three-dimensional flow.
Subroutine CALNORM3 – Calculates the spatial derivatives of the shape functions and the components of
the unit normal vector for the evaluation of the surface integrals in three-dimensional flow.
Subroutine D2SHAPSURF – Calculates the second spatial derivatives of the shape functions for the surface
integrals in three-dimensional flows.
12
TABLE OF CONTENTS
Page
1
4
5
6
8
8
9
10
10
11
11
11
12
12
12
13
13
14
15
15
17
18
18
18
21
23
25
27
30
31
33
39
41
45
45
46
46
47
48
48
49
49
50
50
53
53
54
55
55
55
56
57
57
57
58
58
58
59
59
59
61
61
62
63
64
65
Modules
Program ebe_fdv_ver1
Subroutine OPENING
Subroutine INPUT
Subroutine CONSVAR
Subroutine BLOCK
Subroutine GENBFAC
Subroutine GAUSINT
Subroutine SHAPDOM
Subroutine SHAPSURF
Subroutine SHAP1D
Subroutine GAULEG
Subroutine ELELENG
Subroutine EVALELE
Subroutine DERSHA
Subroutine DERSHA1D
Subroutine DERSHA2
Subroutine PRIMVAR
Subroutine CFLTODT
Subroutine IMPARM
Subroutine CONVFLX1
Subroutine CONVFLX
Subroutine MEIEQNS
Subroutine ONED_INGRL
Subroutine DOMINGRL
Subroutine DOMINGRL3D
Subroutine BOUINGRL3D
Subroutine BOUINGRL
Subroutine EVALBOU
Subroutine APLBNCN2D
Subroutine APLBNDCND
Subroutine JACBNC2D
Subroutine JACBNDCND
Subroutine BC
Subroutine AJACOB1
Subroutine AJACOB
Subroutine EVALDOM
Subroutine BJACOB
Subroutine CJACOB
Subroutine VISCFLX
Subroutine MATXMULT
Subroutine CALNORM
Subroutine SOLVE
Subroutine GMRES_EBE
Subroutine PRECOND
Subroutine DIAG_PRECOND
Subroutine LOCAL
Subroutine FWDSUBSTN
Subroutine BACKSUBSTN
Subroutine LU_PRECOND
Subroutine SOR_PRECOND
Subroutine LU_FACT
Subroutine AU_PRODUCT
Subroutine MATX_VEC
Subroutine EL2NORM
Subroutine DOTPROD
Subroutine CNSTWLTMP
Subroutine APLBOUN
Subroutine RMSERR
Subroutine OUTPUT
Subroutine OUTIMP
Subroutine WALLPRES3D
Subroutine QUICK_SORT_2D
Subroutine WALLPROPT
Subroutine QUICK_SORT
Subroutine GENBFAC3
i
Subroutine SHAPDOM3
Subroutine DERSHA_3D
Subroutine SHAPSURF_3D
Subroutine CONVFLX3
Subroutine EVALELE3D
Subroutine GPG
Subroutine AJACOB_3D
Subroutine BJACOB_3D
Subroutine CJACOB_3D
Subroutine VISCFLX_3D
Subroutine EVALBOU3D
Subroutine CALNORM3
Subroutine D2SHAPSURF
71
72
76
76
76
77
78
79
80
81
81
82
84
ii
!
! Variation Parameter information
! s1,s2,s3,s4 = Constant-value Variation parameters
! s1ele,s2ele,s3ele,s4ele = Element variation parameters
! s3pec,s4pec = dissipation variation parameters calc. from Peclet
No.
! emachold,reyold,pecold = element mach numbers, Reynolds
numbers,
!
and Peclet numbers from previous time step
!
! w,xi = weighting functions and abscissas for Gaussian
Quadrature
! phi,phibou = element shape functions, boundary surface shape
func.
! dpxi = derivatives of shape functions wrt natural coordinates
! d2phi,d2phidxde,d2phidxdz,d2phidedz = Second derivatives of
shape
!
functions wrt to natural coordinates
! d2shpdx = spatial derivatives of shape functions
! d2phidx = Second spatial derivatives of shape functions
!
! FDV equation variables
!
rhs = right hand side vector of FDV equations
!
delu = vector of unknowns
!
Bel = Element stiffness matrix
!
alu = LU factorization of element stiffness matrix
!
! F = Convective Flux vector
!
!
*******************************************************
*********
! Module that contains dimensions for variables
!
Module param_var
!
Implicit None
Save
!
integer, parameter :: mpoin = 8000
integer, parameter :: melem = 8000
integer, parameter :: mboun = 1000,mface = mboun
integer, parameter :: mdimn=2,mnode=4,mequa=4
integer, parameter :: ngaus=2,mgaus=ngaus**mdimn
integer, parameter :: mordr=mpoin*mequa,meleq=mnode*mequa
integer, parameter :: mbsize=128,mblock=melem/64 + 1
! This file contains modules for common global variables used in
! Program ebe_fdv_ver1.f90
!
! *************************** Variables
**************************
! mpoin = dimension for number of grid points
! melem - dimension for number of elements
! mboun = dimension for number of boundary points
! mface = dimension for number of boundary faces
! mdimn = dimension for number of dimensions
! mnode = dimension for number of nodes per element
! mequa = dimension for number of unknowns per grid point
! ngaus = number of Gaussian points used in Gaussian Quadrature
! mbsize = number of elements per block
! mconn = dimension for element connectivity array
! mhng = dimension for hanging node array
!
! gamma = ratio of specific heats, gamm1 = gamma - 1
! gm1m2pr = (gamma-1)*Mach^2*prandtl number
! gm3d2 = (gamma-3)/2, gm1d2 = (gamma-1)/2, gamm3 = gamma
-3
! cgas = nondimensional gas constant
! csuth = nondimensional Sutherland constant
! creyn = Freestream Reynolds number
! cmach = Freestream Mach number, cmasq = cmach^2
! cv = specific heat at constant volume
! cartf = coefficient of artificial viscosity (not currently used)
! tinf = Freestream static temperature
! twall = nondimensional wall temperature
! dense = nondimensional fluid density at grid points
! energ = nondimensional total energy at grid points
! press = nondimensional pressure at grid points
! tempr = nondimensional temperature at grid points
! u = conservation variables at grid points
! uold = value of conservation variable from previous time step
! vel = nondimensional fluid velocity at grid points
! lnod = element connectivity
! lpold = element connectivity containing hanging nodes
! x = Cartesian coordinates of grid points
! lblock = element block information
! cleng = element characteristic length
! alpa = compression corner deflection angle (in radians)
!
! ibcon = boundary point information:
!
ibcon(1,:) global point number of boundary point
!
ibcon(2,:) boundary condition of boundary point (see below)
!
ibcon(3,:) = 2 for adiabatic wall, otherwise, = 0
! Boundary conditions (value of ibcon(2,:)):
!
= -12 Top surface on lid-driven cavity, Dirichlet, d/dn.ne.0
!
= -1 Dirichlet inlet
!
= 2,12 Symmetry in x-y plane, w=tau23=tau13=q3=0
!
= 1 No-slip wall in x-y plane, u=v=w=0, T=Twall or q3=0
!
= 4 No-slip Inclined surface in x-y plane, u=v=w=0, T=Twall
or q3=0
!
= 6 Outlet, d/dn=0
!
= 7 Top surface, d/dn=0
!
= 8 Compression corner outlet, deriv. wrt flow dir. = 0
!
= 9 Triple shock outlet, deriv. wrt flw dir. = 0
!
= 11,21 No-slip wall in y-z plane, 11 - left side, 21 - right side
!
= 14 No-slip Inclined surface in y-z plane, u=v=w=0, T=Twall
or q1=0
!
= 22 Symmetry in y-z plane, u=tau12=tau13=q1=0
!
= 31,41 No-slip wall in x-z plane, 31 - left side, 41 - right side
!
! indbc,indbd = boundary condition information for each grid point
! ibouncnd = boundary condition information for each equation
! rbcon = direction cosines along boundary surface (not used for 3D)
! lface,lfacnode = nodal point information for boundary faces (see
!
subroutines genbfac & genbfac3d for complete description)
!
! parameters for adaptive mesh
! integer, parameter :: mconn=24,mhng=36 ! 3-D Adaptive
Mesh
integer,parameter :: mconn=8,mhng=8
! 2-D Adaptive Mesh
!
end module param_var
!
!
*******************************************************
***********
! Module that contains thermodynamic properties
!
Module thermo_propt
!
Implicit None
!
Save
!
real :: gamma,gamm1,gm1m2pr,gm3d2,gm1d2,gamm3
real :: cgas,csuth,creyn,cmach,cmasq,cv,cartf
real :: tinf,twall
!
1
Save
end Module thermo_propt
!
!
*******************************************************
*********
! Module to initialize flow variables
!
Module flow_var
!
Use param_var
!
Implicit None
Save
!
real, dimension(mpoin) :: dense,energ,press,tempr
real, dimension(mordr) :: u,uold
real, dimension(mdimn,mpoin) :: vel
!
End Module flow_var
!
!
*******************************************************
*********
! Module to initialize finite element grid data
!
Module grid_info
!
Use param_var
!
Implicit None
Save
!
integer, dimension(mnode,melem) :: lnod ! Element Nodes
real, dimension(mdimn,mpoin) :: x
integer :: lblock(mblock) ! Block information
real :: cleng(melem)
! Element Characteristic Length
real :: alpa
! Compression Corner Deflection Angle
integer :: imax,jmax,kmax ! Initial points in x, y, and z dir
!
end module grid_info
!
!
*******************************************************
********
! Module containing boundary condition information
!
Module Bnd_cnd
!
Use param_var
!
Implicit None
Save
!
integer :: ibcon(3,mboun) ! Boundary Point information
integer, dimension(mpoin) :: indbc,indbd
integer :: ibouncnd(mordr) ! Boundary Condition Array
real :: rbcon(mdimn,mboun) ! Direction Cosines along
Boundary Surf
!
End Module Bnd_cnd
!
*******************************************************
********
! Module with Boundary Face information
!
Module bface_info
!
Use param_var
!
Implicit None
!
integer,dimension(8,mface) :: lface,lfacnode
!
end module bface_info
!
!
*******************************************************
*********
! Module to initialize Variation Parameters
!
Module Var_parm
!
Use param_var
!
Implicit None
Save
!
real :: s1,s2,s3,s4
real, dimension(melem) :: s1ele,s2ele,s3ele,s4ele
real, dimension(melem) :: s3pec,s4pec ! Variation parameters
! from Peclet Number
!
end module Var_parm
!
!
*******************************************************
*********
! Module for old values of Mach Number, Reynolds number, and
Peclet
! number for calculation of variation parameters
!
Module Mach_old
!
Use Param_var
!
Implicit None
Save
!
real, dimension(mpoin) :: emachold,reyold,pecold ! Values
from
! previous timestep
end Module Mach_old
!
!
*******************************************************
*********
! Module to initialize the domain shape functions for Gaussian
Quadrature
!
Module Gaus_quad
!
Use param_var
!
Implicit None
Save
!
real :: w(ngaus),xi(ngaus),ww(mgaus) ! Gaussian points
!
end module Gaus_quad
!
!
*******************************************************
*********
! Module to initialize the domain shape functions for Gaussian
Quadrature
!
Module shap_fcns
!
Use param_var
2
Save
!
!
Implicit None
Save
integer, parameter :: ngsurf=ngaus**(mdimn-1)
real :: phi(4,ngsurf),dpxi(2,4,ngsurf)
real :: d2phi(4,ngsurf), w_w(ngsurf)
real :: dshpdx(mdimn,4,ngsurf),detjac(ngsurf)
real :: d2phidx(mdimn,mdimn,4,ngsurf)
!
real :: phi(mnode,mgaus),dpxi(mdimn,mnode,mgaus) ! Shape
Functions
real :: d2phi(mnode,mgaus) ! Second derivative of shape
Functions
!
! of shape functions
end module shap_fcns
!
!
*******************************************************
*********
! Module for additional derivative for Three-D shape functions
!
! d2phidxde - derivative wrt xi and eta
! d2phidxdz "
" xi and zeta
! d2phidedz "
" eta and zeta
!
Module Shap3d_fcns
!
Use param_var
!
Implicit None
Save
!
real, dimension(mnode,mgaus) ::
d2phidxde,d2phidxdz,d2phidedz
!
end module Shap3d_fcns
!
!
*******************************************************
*********
! Shape functions for the boundary surfaces for a 2-D Domain
!
Module Shapbou_2d
!
Use param_var
!
Implicit None
Save
!
real :: phibou(2,ngaus),dpxi(2,ngaus)
!
end module Shapbou_2d
!
!
*******************************************************
*********
! Module to initialize shape functions for the boundary surfaces
! for a Three-dimensional domain
!
Module Shapbou_3d
!
Use param_var
!
Implicit None
!
end module Shapbou_3d
!
!
*******************************************************
**********
! Module for Coefficients for FDV Equations
!
Module FDV_coef
!
Use param_var
!
Implicit None
Save
!
real,dimension(mordr) :: rhs,delu
real,dimension(melem,meleq,meleq) :: Bel
!
end module FDV_coef
!
!
*******************************************************
*********
! Module to initialize Convective Flux
!
Module Conv_Flux
!
Use param_var
!
Implicit None
Save
!
real :: F(mpoin,mdimn,mequa) ! Convective Flux
!
end module Conv_Flux
!
!
*******************************************************
**********
! LU Factorization of Stiffness Matrix for GMRES Solve
!
Module GMRES_var
!
Implicit None
!
Save
!
real,allocatable,dimension(:,:,:) :: alu
!
end module GMRES_var
!
3
!
! Flowfield Dependent Variation Finite Element Method with
! a Element-by-Element GMRES Equation Solver with Left
! Preconditioning
!
! Programmed by Gary W. Heard
!
Graduate Research Assistant
!
University of Alabama in Huntsville
!
! This version contains no parallel processing or adaptive mesh
!
! **************************** Variables
**************************
! npoin = number of grid points, nelem = number of element
! nboun = number of boundary point, nface = number of boundary
faces
! npold = total number of grid points, including hanging nodes
! nnode = number of grid points per element
! nequa = number of unknowns per nodal point
! ndimn = number of dimensions
! nordr = total number of equations (npoin*nequa)
! neleq = number of element equation (nnode*nequa)
! ntime = number of time steps to be executed
! ntstp = number of time steps to be executed prior to mesh
!
refinement, if < ntime, no refinement
! isolve = specifies equation solver, = 4 for EBE GMRES
! iprecnd = preconditioner for solver, = 0, no preconditioner
!
= 1, LU Preconditioner only
!
= 2, Diagonal + LU
!
= 3, Diagonal only
!
= 4, Diagonal + SOR
! igmres = number of iterations in GMRES cycle
! nvisc = 1 for N-S Equations, 0 for Euler
! ierrind = 1 for FDV parameters as error indicators
!
= 2 for primitive variable error indicators
! imppa = definition of 2nd-order variation parameters,
!
= 7 for current definitiion (0.5(1+s1^eta))
! nblock = number of element blocks
! time = total elapsed time
! cfl = Courant-Frederich-Levy number
! dt = delta t
! en = exponent for 2nd-order variation parameter
! adap = logical variable describing whether grid has been refined
! artvis, strem = logical variables (not currently used)
!
*******************************************************
**********
!
PROGRAM ebe_fdv_ver1
!
Use param_var
!
Use FDV_coef
!
Implicit None
!
integer :: npoin,nelem,nboun,nface,npold
integer :: nnode,nequa,ndimn,nordr,neleq
integer :: ntime,ntstp,niter,itime
integer :: isym,nsave,itmax,iunit,isolve,iprecnd,igmres
integer :: nvisc,ierrind,imppa
integer :: koun,iout,iternum,iter
integer :: ifile,jfile,kfile
integer :: nblock
integer :: ierr
integer :: numrefi
integer :: istat ! Allocation status parameter
real :: time,cfl,dt,en
real :: epstol,tol,omega
LOGICAL :: ADAP, artvis,strem
!
CHARACTER*1 NUMB
CHARACTER(len=4) :: NUM
CHARACTER(len=12) :: FILENAME
!
open(unit=23,file='timestep.out')
!
!
!
READ IN INITIAL DATA
CALL
OPENING(NPOIN,NELEM,NBOUN,NFACE,NNODE,NEQUA,N
DIMN,neleq,&
&
NPOLD,NTIME,NTSTP,NITER,TIME,ISYM,NSAVE,epstol, &
&
TOL,ITMAX,omega,IUNIT,NORDR,CFL,isolve,iprecnd, &
&
adap,igmres,NVISC,ierrind,artvis,strem,
&
&
IMPPA,en)
!
CALL
INPUT(NPOIN,NELEM,NBOUN,NFACE,NDIMN,NNODE,NPOL
D,
&
&
nequa,adap,TIME,nblock)
!
! CONVERT PRIMITIVE INPUT DATA TO CONSERVATION
VARIABLES
!
call consvar(npoin,nequa,ndimn)
!
if(time.eq.0.000000) &
! Block elements for GMRES
solver
! Ref: Shakib (1989)
& call block(ndimn,nnode,nelem,nface,npoin,adap,nblock)
!
! CALCULATE BOUNDARY FACE CONNECTIVITY
!
IF(TIME.EQ.0.000000.AND.NDIMN.eq.2)
&
& CALL GENBFAC(NELEM,NBOUN,NNODE,NFACE) !
Two Dimensions
!
if(time.eq.0.000.and.ndimn.eq.3)
&
& call genbfac3(nelem,nboun,nnode,nface) ! Three
Dimensions
!
! INITIALIZE VARIABLES FOR PRINTING INTERMEDIATE
OUTPUT
!
KOUN = 1
IOUT = NTIME/5 ! Counter for printing intermediate output
! iout = 100
!
ITERNUM = 0
!
! CALCULATE SHAPE FUNCTIONS FOR GAUSSIAN
QUADRATURE INTEGRATION
!
CALL GAUSINT(ndimn)
!
! Calculate element characteristic lengths
!
Select Case(ndimn)
Case(1)
call eleleng(nelem)
Case(2)
CALL EVALELE(NNODE,NELEM,adap)
Case(3)
call evalele3d(adap,ndimn,nnode,nelem)
end Select
!
! print *, ' ENTERING ITERATION LOOP'
4
!
!
!
!
!
ifile=17
open(unit=ifile,file=filename)
BEGIN ITERATION LOOP
!
timeloop: DO ITIME = 1, NTIME
ITERNUM = ITERNUM + 1
print *, ' CALCULATING TIME STEP'
if(iter.lt.10) then
filename='wall'//num(4:4)//'.out'
elseif(iter.lt.100) then
filename='wall'//num(3:4)//'.out'
elseif(iter.lt.1000) then
filename='wall'//num(2:4)//'.out'
else
filename='wall'//num(1:4)//'.out'
endif
jfile = 19
if(ndimn>1) open(unit=jfile,file=filename)
if(ndimn>1) then
CALL CFLTODT(NELEM,nnode,ndimn,CFL,DT) ! Calculate
timestep from
! CFL number
!
else
!
dt=0.407e-03
!
endif
!
! print *, ' CALCULATING IMPLICITNESS PARAMETERS'
IF(IMPPA.GE.1) &
& CALL
IMPARM(NELEM,NPOIN,NNODE,NVISC,IMPPA,ndimn,en,itern
um)
! &
kount,iout,ITERNUM)
!
TIME = TIME + DT ! Increment time
!
! print *, ' CALCULATING CONVECTIVE FLUX'
Select Case(ndimn)
Case(1)
call convflx1(npoin)
Case(2)
CALL CONVFLX(NPOIN)
Case(3)
call convflx3(npoin)
end Select
!
!
write(*,5000)
! 5000 format(' BUILDING MEI EQUATIONS')
CALL
MEIEQNS(NELEM,NNODE,NFACE,NEQUA,NDIMN,nordr,neleq
,DT, &
&
nvisc,IMPPA,nblock,adap,artvis,itime)
!
! print *,' ENTERING EQUATION SOLVER SUBROUTINE'
!
call
Solve(nblock,nelem,nnode,nequa,ndimn,nordr,neleq,epstol,tol,&
&
iprecnd,igmres,itime,itmax,iunit,omega,isolve,ierr)
!
CALL RMSERR(npoin,nequa,dt,itime,ierr) ! Calculate
RMS error
!
! Calculate primitive variables from Conservation Variables
!
CALL PRIMVAR(NPOIN,nequa,ndimn)
!
! Print intermediate output every "iout" timesteps
!
iter=iternum
if((ntime<ntstp.and.iter==koun*iout)&
&.or.iter/ntstp*ntstp==iter) then
! if(iter/ntstp*ntstp.eq.iter) then ! Print output prior to
remeshing
write(num,'(i4)')iter
if(iter.lt.10) then
filename='t_'//num(4:4)//'.out'
elseif(iter.lt.100) then
filename='t_'//num(3:4)//'.out'
elseif(iter.lt.1000) then
filename='t_'//num(2:4)//'.out'
else
filename='t_'//num(1:4)//'.out'
endif
!
CALL
output(ifile,jfile,npoin,nelem,nboun,nface,nnode,nequa,ndimn,&
&
adap,ntime,ntstp,time,cfl,igmres,iprecnd,isolve,
&
&
nvisc,ierrind,imppa,en,npold,artvis,strem,nblock)
!
if(iter.lt.10) then
filename='imp'//num(4:4)//'.out'
elseif(iter.lt.100) then
filename='imp'//num(3:4)//'.out'
elseif(iter.lt.1000) then
filename='imp'//num(2:4)//'.out'
else
filename='imp'//num(1:4)//'.out'
endif
!
kfile = 18
open(unit=kfile,file=filename)
call outimp(kfile,nelem,npoin,nnode,npold,adap)
koun=koun+1
endif
!
numrefi = itime/ntstp
!
!
enddo timeloop
!
! Print final output
!
CALL
output(60,70,npoin,nelem,nboun,nface,nnode,nequa,ndimn, &
&
adap,ntime,ntstp,time,cfl,igmres,iprecnd,isolve, &
&
nvisc,ierrind,imppa,en,npold,artvis,strem,nblock)
!
IF(IMPPA.GE.1) &
& CALL OUTIMP(11,nelem,npoin,nnode,npold,adap)
!
! if(strem) then
!
!
call stremfn(npoin,nelem,nequa,nnode,adap,
! &
isym,nsave,epstol,tol,itmax,ierr)
!
!
call outstrem(npoin)
!
endif
1500 format(' WARNING: ALLOCATION OF FDV ARRAYS
FAILED, istat = ',i8)
!
STOP
END Program ebe_fdv_ver1
! -------------------------------------------------------------------!
subroutine
opening(npoin,nelem,nboun,nface,nnode,nequa,ndimn,neleq,&
&
npold,ntime,ntstp,niter,time,isym,nsave,epstol, &
&
tol,itmax,omega,iunit,nordr,cfl,isolve,iprecnd, &
&
adap,igmres,nvisc,ierrind,artvis,strem,imppa,en)
5
!
!
gamma=1.4
gamm1=gamma-1.0
cpran=0.72
cartf=2.0
Use param_var
Use thermo_propt
Use var_parm
Use grid_info
Implicit None
!
csuth=110./tinf
cmasq=cmach*cmach
cv=1./gamma/gamm1/cmasq
cgas=1./gamma/cmasq
!
logical,intent(out) :: adap, artvis,strem
integer,intent(out) :: npoin,nelem,nboun,nface,npold
integer,intent(out) :: nnode,nequa,ndimn
integer,intent(out) :: ntime,ntstp,niter,nordr,neleq
integer,intent(out) :: isym,nsave,itmax,iunit,isolve,iprecnd,igmres
integer,intent(out) :: nvisc,ierrind,imppa
real,intent(out) :: time,cfl,en
real,intent(out) :: epstol,tol,omega
real :: cpran
!
gm1m2pr=gamm1*cmasq*cpran
gm1d2=gamm1/2.
gamm3=gamma-3.
gm3d2=gamm3/2.
!
return
end subroutine opening
!
open(50,file='f.dat')
open(60,file='t.out')
open(70,file='wallprop.out')
open(21,file='rmserror.out')
open(unit=11,file='impparm.out',status='unknown')
!
!
!
!
!
!
!
! -------------------------------------------------------------------!
subroutine
input(npoin,nelem,nboun,nface,ndimn,NNODE,npold, &
&
nequa,adap,TIME,nblock)
!
Use param_var
Use thermo_propt
Use grid_info
Use flow_var
Use bface_info
Use bnd_cnd
!
Implicit None
!
logical,intent(in) :: adap
integer,intent(in) :: npoin,nelem,nboun,nface,npold
integer,intent(in) :: ndimn,nnode,nequa
integer,intent(out) :: nblock
real,intent(in) :: time
integer :: ielem,ipoin,ip,ie,idimn,iboun,iequa,iordr,iface
integer ::iblock,j ! Loop counters
real :: energy,velo2
!
read(50,1)
do ielem=1,nelem
read(50,*)ie,(LNOD(j,ielem),j=1,NNODE) ! Element
Connectivity
enddo
!
read(50,1)
do ipoin=1,npoin
read(50,*)ip,(X(j,ipoin),j=1,ndimn) ! Cartesian Coordinates
enddo
!
! --- NONDIMENSIONALIZED PRIMITIVE VARIABLES.
!
read(50,1)
do ipoin=1,npoin
read(50,*)ip,dense(ipoin),(VEL(idimn,IPOIN),idimn=1,ndimn)
&
&
,energ(ipoin)
velo2 = 0.0
do idimn = 1, ndimn
velo2 = velo2+vel(idimn,ipoin)*vel(idimn,ipoin)
enddo
energy=energ(ipoin)-0.5*(velo2)
press(ipoin)=dense(ipoin)*gamm1*energy
tempr(ipoin)=energy/cv
enddo
!
read(50,1)
read(50,2)ntstp,adap,remesh,incom,artvis
read(50,1)
read(50,*)nvisc,isolve,ierrind,iprecnd,artvis,imppa
read(50,1)
read(50,*) ntime,ntstp,time,adap,igmres
read(50,1)
read(50,*) cfl,s1,s2,s3,s4
read(50,1)
read(50,*) igeom, dimcorn, endcorn,alpa
read(50,1)
read(50,*) cmach,creyn,tinf,twall
read(50,1)
read(50,*) en,strem,alpa
READ(50,1)
READ(50,*) NNODE,NEQUA,NDIMN
read(50,1)
if(ndimn.ne.3) then
read(50,*) nelem,npoin,nboun,nface,imax,jmax
else
read(50,*) nelem,npoin,nboun,nface,imax,jmax,kmax
endif
if(iacnt.eq.2.or.iacnt.eq.3) read(50,*) npold
if(adap) read(50,*) npold
1 format(20a4)
2 format(i7,4L7)
!
!
! --- NUMBER OF ITERATION OF LUMPING MASS
CALCULATION.
niter=3
!
! nnode=4
! nequa=4
! ndimn=2
!
! --- PARAMETERS FOR PGMRES.
isym=0
nsave=10
epstol = 1.0e-09
tol=1.0e-12
itmax=10
omega = 0.0
iunit=10
nordr=npoin*nequa
neleq = nnode*nequa
!
! --- THERMODYNAMICS PROPERTIES.
6
!
!
Boundary points and boundary conditions
!
read(50,1)
do iboun=1,nboun
if(ndimn.lt.3) then
read(50,*)(ibcon(j,iboun),j=1,3),(rbcon(j,iboun),j=1,ndimn)
else
read(50,*)(ibcon(j,iboun),j=1,3)
endif
enddo
!
endif
if(ndimn==3) then
!
IORDR = 0
DO IPOIN = 1, NPOIN
DO IEQUA = 1, NEQUA
IORDR = IORDR + 1
IBOUNCND(IORDR) = INDBC(IPOIN)
! No slip wall on bottom (1), left side (11), and right side (21)
IF(INDBC(IPOIN)==1.OR.INDBC(IPOIN)==11.OR.
&
&
INDBC(IPOIN)==21.or.indbc(ipoin)==31.or.
&
&
indbc(ipoin)==41) THEN
!u=v=w=0
IF(IEQUA.EQ.2.OR.IEQUA.EQ.3.or.iequa.eq.4)
&
&
IBOUNCND(IORDR) = -IBOUNCND(IORDR)
IF(INDBD(IPOIN).NE.2.AND.IEQUA.EQ.5)
&
&
IBOUNCND(IORDR) = 100 ! T = Twall
ENDIF
!
! Compression Ramp on bottom (4) and left side (14)
IF(INDBC(IPOIN)==4.OR.INDBC(IPOIN)==14)then
!
DO IPOIN = 1, NPOIN
INDBC(IPOIN) = 0
INDBD(IPOIN) = 0
enddo
DO IBOUN = 1, NBOUN
INDBC(IBCON(1,IBOUN)) = IBCON(2,IBOUN)
INDBD(IBCON(1,IBOUN)) = IBCON(3,IBOUN)
enddo
!
! Set boundary conditions on each equations
!
if(ndimn==1) then
iordr = 0
do ipoin = 1,npoin
do iequa = 1,nequa
iordr = iordr + 1
ibouncnd(iordr) = indbc(ipoin)
if(indbc(ipoin)==6) then ! Constant density at exit
if(iequa==1) ibouncnd(iordr) = -ibouncnd(iordr)
endif
enddo
enddo
endif
!
if(ndimn==2) then
!
IORDR = 0
DO IPOIN = 1, NPOIN
DO IEQUA = 1, NEQUA
IORDR = IORDR + 1
IBOUNCND(IORDR) = INDBC(IPOIN)
IF(IEQUA.EQ.2.OR.IEQUA.EQ.3.or.iequa.eq.4) & !
u = v = w =0
&
IBOUNCND(IORDR) = -IBOUNCND(IORDR)
IF(INDBD(IPOIN).NE.2.AND.IEQUA.EQ.5)
&
&
IBOUNCND(IORDR) = 100
! T = Twall
ENDIF
!
if(indbc(ipoin).eq.222) then ! Bottom corner, u = w = 0
if(iequa.eq.2.or.iequa.eq.4)
&
&
ibouncnd(iordr) = -ibouncnd(iordr)
endif
!
if(indbc(ipoin).eq.22) then ! Symmetry on left and right sides
if(iequa.eq.2) ibouncnd(iordr) = -ibouncnd(iordr) ! u = 0
endif
!
if(indbc(ipoin).eq.2.or.indbc(ipoin).eq.12) then ! Symmetry
on
IF(INDBC(IPOIN).EQ.1.OR.INDBC(IPOIN).EQ.11.OR.
&
&
INDBC(IPOIN).EQ.21.or.indbc(ipoin).eq.4) THEN
IF(IEQUA.EQ.2.OR.IEQUA.EQ.3)
&
&
IBOUNCND(IORDR) = -IBOUNCND(IORDR)
IF(INDBD(IPOIN).NE.2.AND.IEQUA.EQ.4)
&
&
IBOUNCND(IORDR) = 100
ENDIF
!
if(indbc(ipoin).eq.3.or.indbc(ipoin).eq.5) then
IF(IEQUA.EQ.2.OR.IEQUA.EQ.3)
&
&
IBOUNCND(IORDR) = -IBOUNCND(IORDR)
IF(INDBD(IPOIN).NE.2.AND.IEQUA.EQ.4)
&
&
IBOUNCND(IORDR) = 100
ENDIF
!
if(indbc(ipoin).eq.2.or.indbc(ipoin).eq.12) then
if(iequa.eq.3) ibouncnd(iordr) = -ibouncnd(iordr)
endif
!
if(indbc(ipoin).eq.15) then
if(iequa.eq.2) ibouncnd(iordr) = 101
if(iequa.eq.3) ibouncnd(iordr) = -ibouncnd(iordr)
endif
ENDDO
ENDDO
if(iequa.eq.4) ibouncnd(iordr) = -ibouncnd(iordr) ! Top and
bottom
endif
! Surface w = 0
!
ENDDO
ENDDO
!
endif
!
! Read in boundary face connectivity
!
if(ndimn/=1) then
IF(adap.or.TIME>0.000000) THEN
read(50,1)
do iface=1,nface
read(50,*) (lface(j,iface),j=1,8)
if(ndimn.eq.3) read(50,*) (lfacnode(j,iface),j=1,8)
enddo
endif
endif
!
! Element block information Ref: Shakib, 1989
!
7
integer :: istart,ifirst,ibsize,j,iel,isum
integer :: ielem,knode,kblock,icount,jelem,iface
integer :: iconn,ihng,jnode,lnode,kelem
integer :: knod1,knod2,knod3,igrp,igrp1,jblock
integer :: kelem1
if(time>0.000000) then
read(50,1)
read(50,*)nblock,(lblock(iblock),iblock=1,nblock+1)
endif
!
!
!
!
1 format(20a4)
!
return
end subroutine input
initialize IBLOCK array
iblock = 0
lblock = 0
!
!
*******************************************************
****
! THE FOLLOWING SUBROUTINE CONVERTS PRIMITIVE
VARIABLES TO
! CONSERVATION VARIABLES
!
SUBROUTINE CONSVAR(NPOIN,nequa,ndimn)
!
Use flow_var
!
Implicit None
!
integer,intent(in) :: npoin,nequa,ndimn
integer :: L,idimn,iordr ! Loop counters
!
DO L = 1,NPOIN
iordr = nequa*(L-1)
U(iordr+1) = DENSE(L)
do idimn=1,ndimn
U(iordr+1+idimn)=dense(L)*VEL(idimn,L)
enddo
U(iordr+2+ndimn)=dense(L)*ENERG(L)
enddo
!
RETURN
end subroutine consvar
!
*******************************************************
********
! Subroutine to block elements in nonrecursive blocks
!
adapted from Hughes, Ferencz, and Hallquist (1987)
!
Subroutine block(ndimn,nnode,nelem,nface,npoin,adap,nblock)
!
!
*****************Variables******************************
*********
!
! iblock = array storing the block number assigned to each element
! lblock = pointer identifying the first element number in a block
! nblock = total number of blocks required for the finite element
grid
! ielblk = array storing the number of elements in each block
! mbsize = maximum number of element allowed in a block
!
Use param_var
Use grid_info
Use Bface_info
!
Implicit None
!
logical,intent(in) :: adap
integer,intent(in) ::ndimn,nnode,nelem,nface,npoin
integer,intent(inout) :: nblock
!
!
integer :: iblock(nelem),ielblk(mblock),inode(npoin)
integer :: larra(mhng,melem)
integer :: newelno(nelem),ltemp(nelem)
!
!
!
set initial search parameters and number of blocks
istart = 1
nblock = 0
100 continue
!
!
!
!
Find first element in original ordering not previously
assigned to a block
do ifirst = istart,nelem
!
if(iblock(ifirst).eq.0) then
!
!
!
start a new block
nblock = nblock + 1
! increment number of blocks
iblock(ifirst) = nblock
! assign element to new block
ibsize = 1
! initialize block size
istart = ifirst + 1
! reset search parameter
inode = 0
! zero the INODE array
do j = 1,nnode
! designate element's nodes as
inode (lnod(j,ifirst)) = 1 ! active within current block
enddo
!
! Search subsequent elements in original ordering and test
!
unassigned elements for inclusion in current block
!
do iel = istart,nelem
!
if(iblock(iel).eq.0) then
!
!
current element not blocked. Test if it shares common nodes
!
with any element previously assigned to current block
!
(i.e., have any of its nodes been previously activated)
!
isum = 0
do j = 1,nnode
isum = isum + inode(lnod(j,iel))
enddo
!
if(isum.eq.0) then
!
!
current element does not share nodes with elements
!
in current block, so add element to block
!
iblock(iel) = nblock ! assign block number to element
ibsize = ibsize + 1 ! increment size of current block
do j = 1,nnode ! designate element's nodes as
inode(lnod(j,iel)) = 1 ! active within current block
enddo
!
if(ibsize.eq.mbsize) then
!
!
block has reached maximum size
!
ielblk(nblock) = mbsize ! store size of completed
block
goto 100
! and begin new search
endif
8
integer,intent(in) :: nelem,nboun,nnode
integer,intent(inout) :: nface
integer :: ielem,inode,inod,jnode
! Loop counter
integer :: iface,iboun,jpoin,ibc1,ibc2
integer :: lflag,lbnode,ipoin,msum,nsum
integer :: lnode(3)
integer :: kboun
!
endif
!
endif
enddo
!
!
!
element list exhausted before block filled to maximum size
ielblk(nblock) = ibsize
goto 100
!
!
!
!
!
!
!
!
!
!
!
!
! store size of completed block
and begin new block
!
endif
!
enddo
!
!
!
all element assigned to a block, now reorder the lnod array
do ielem = 1,nelem
do knode = 1,nnode
larra(knode,ielem) = lnod(knode,ielem) ! temporary storage
enddo
! of the old connectivity
enddo
lface(1,iface) = point number for 1st boundary node
2
= point number for 2nd boundary node
3
= 1st boundary node number
4
= 2nd boundary node number
5
= 1st local node number
6
= 2nd local node number
7
= element number
8
= boundary condition
nface=0
!
elemloop: do ielem=1,nelem
!
lbnode=0
do inode=1,nnode
ipoin=lnod(inode,ielem)
lflag=0
if(indbc(ipoin).ne.0) then
lflag=1
lbnode=lbnode+1
goto 350
endif
350 continue
if(lflag.eq.1) lnode(lbnode)=inode
enddo
!
jelem = 0
!
do kblock = 1,nblock
!
icount = 0
!
do ielem = 1,nelem
!
if(iblock(ielem).eq.kblock) then
!
icount = icount + 1
jelem = jelem + 1
!
if(lbnode.eq.2) then
nface=nface+1
lface(7,nface)=ielem
lface(1,nface)=lnod(lnode(1),ielem)
lface(2,nface)=lnod(lnode(2),ielem)
if(lnode(1).eq.1.and.lnode(2).eq.4) then
lface(1,nface)=lnod(lnode(2),ielem)
lface(2,nface)=lnod(lnode(1),ielem)
endif
endif
!
do knode = 1,nnode
lnod(knode,jelem) = larra(knode,ielem)
enddo
!
newelno(ielem) = jelem
!
if(icount.eq.1) lblock(kblock) = jelem
!
endif
!
!
if(lbnode.eq.3) then
enddo
enddo
!
nsum=10
msum=0
do inod=1,3
msum=msum+lnode(inod)
enddo
!
lblock(nblock+1) = nelem + 1
!
write(45,1000) nblock,(lblock(jblock),jblock=1,nblock+1)
1000 format(8i8)
1050 format(' New Element Numbers')
1100 format(' Nelgrp Information')
!
return
end subroutine block
!
! -------------------------------------------------------------------!
subroutine genbfac(nelem,nboun,nnode,nface)
!
Use bnd_cnd
Use param_var
Use grid_info
Use bface_info
!
Implicit None
!
!
if(msum.eq.9) then
nface=nface+1
lface(7,nface)=ielem
lface(1,nface)=lnod(2,ielem)
lface(2,nface)=lnod(3,ielem)
nface=nface+1
lface(7,nface)=ielem
lface(1,nface)=lnod(3,ielem)
lface(2,nface)=lnod(4,ielem)
endif
!
if(msum.eq.8) then
nface=nface+1
lface(7,nface)=ielem
lface(1,nface)=lnod(3,ielem)
lface(2,nface)=lnod(4,ielem)
9
if(ibc1==10) lface(8,iface) = ibc2
if(ibc2==12.or.ibc2==7) lface(8,iface)=ibc1
if(ibc1==12) lface(8,iface) = ibc1
if(ibc1==-2.or.ibc1==-12) lface(8,iface)=ibc1
if(ibc1==5) lface(8,iface) = ibc2
if(ibc2==-2.and.ibc1==21) lface(8,iface) = ibc2
if(ibc2==15.and.ibc1==21) lface(8,iface) = ibc2
if(ibc2==8.or.ibc2==9) lface(8,iface) = ibc2
enddo
nface=nface+1
lface(7,nface)=ielem
lface(1,nface)=lnod(4,ielem)
lface(2,nface)=lnod(1,ielem)
endif
!
if(msum.eq.7) then
nface=nface+1
lface(7,nface)=ielem
lface(1,nface)=lnod(4,ielem)
lface(2,nface)=lnod(1,ielem)
nface=nface+1
lface(7,nface)=ielem
lface(1,nface)=lnod(1,ielem)
lface(2,nface)=lnod(2,ielem)
endif
!
return
end subroutine genbfac
!
!
*******************************************************
**********
!
Subroutine GAUSINT(ndimn)
!
Use Gaus_quad
!
Implicit None
!
integer,intent(in) :: ndimn
!
! CALCULATE GAUSSIAN POINTS AND WEIGHT
FUNCTIONS FOR GAUSSIAN
! QUADRATURE INTEGRATION
!
CALL GAULEG(NGAUS,XI,W,-1.0,1.0)
!
! CALCULATE SHAPE FUNCTIONS
! SUBROUTINE SHAPDOM - DOMAIN SHAPE FUNCTIONS
!
if(msum.eq.6) then
nface=nface+1
lface(7,nface)=ielem
lface(1,nface)=lnod(1,ielem)
lface(2,nface)=lnod(2,ielem)
nface=nface+1
lface(7,nface)=ielem
lface(1,nface)=lnod(2,ielem)
lface(2,nface)=lnod(3,ielem)
endif
!
endif
!
enddo elemloop
!
! --- save the boundary node in the lface
!
lp1: do iface=1,nface
lp2: do inode=1,2
ipoin=lface(inode,iface)
lp3: do iboun=1,nboun
jpoin=ibcon(1,iboun)
if(ipoin.eq.jpoin) then
kboun=iboun
exit lp3
endif
enddo lp3
lface(2+inode,iface)=kboun
enddo lp2
enddo lp1
!
do iface=1,nface
ielem=lface(7,iface)
do inode=1,2
ipoin=lface(inode,iface)
do jnode=1,nnode
jpoin=lnod(jnode,ielem)
if(ipoin.eq.jpoin) lface(4+inode,iface)=jnode
enddo
enddo
enddo
!
do iface=1,nface
ibc1=ibcon(2,lface(3,iface))
ibc2=ibcon(2,lface(4,iface))
lface(8,iface)=ibc1
if(ibc1<ibc2) lface(8,iface)=ibc2
if(ibc1==1.and.ibc2==11) lface(8,iface)=ibc1
if(ibc1==-1.and.ibc2==1) lface(8,iface)=ibc1
if(ibc1==1.and.ibc2==-1) lface(8,iface)=ibc2
if(ibc1==11.and.ibc2==1) lface(8,iface)=ibc1
if(ibc1==21.and.ibc2==-12) lface(8,iface) = ibc2
if(ibc1==9) lface(8,iface) = ibc1
! SUBROUTINE SHAPSURF - BOUNDARY SHAPE
FUNCTIONS
!
Select Case(ndimn)
Case(1)
call shap1d
Case(2)
CALL SHAPDOM
CALL SHAPSURF(XI)
Case(3)
call shapdom3
call shapsurf_3d
end Select
!
RETURN
end subroutine gausint
!
!
*******************************************************
*********
! SUBROUTINE TO CALCULATE DOMAIN SHAPE
FUNCTIONS AND DERIVATIVES
!
SUBROUTINE SHAPDOM
!
Use param_var
Use Gaus_quad
Use shap_fcns
!
Implicit None
!
integer :: igaus,i,j
!
! LINEAR INTERPOLATION FUNCTIONS
!
IGAUS=0
10
! THE FOLLOWING SUBROUTINE CALCULATE THE
SHAPE FUNCTIONS AND THEIR
! DERIVATIVES FOR A BOUNDARY SURFACE
!
SUBROUTINE SHAP1d
!
Use param_var
Use Gaus_quad
Use shap_fcns
!
Implicit None
!
integer :: i
!
! TWO-DIMENSIONAL LINEAR SHAPE FUNCTIONS
!
DO I = 1, MGAUS
PHI(1,I)=0.5*(1.-XI(I))
PHI(2,I)=0.5*(1.+XI(I))
!
! DERIVATIVE OF SHAPE FUNCTIONS
!
DPXI(1,1,I)=-0.5
DPXI(1,2,I)=0.5
ww(i)=w(i)
ENDDO
!
RETURN
end subroutine shap1d
!
! -------------------------------------------------------------------!
subroutine gauleg(n,x,w,x1,x2)
!
! --- given the lower and upper limits of integration x1 and x2, and
! given N, this routine returns arrays x and w of length N,
! containing the abscissas and weights of the Gauss-Legendre
! N point quadrature formula.
!
Implicit None
!
integer,intent(in) :: n
real,intent(out),dimension(n) :: x,w
real,intent(in) :: x1,x2
integer :: m,i,j
real :: xm,xl,z,p1,p2,p3,pp,z1
!
real,parameter :: eps=3.e-14
!
m=(n+1)/2
xm=0.5*(x2+x1)
xl=0.5*(x2-x1)
!
do i=1,m
z=cos(3.141592654*(i-0.25)/(n+0.5))
1 continue
p1=1.0
p2=0.0
do j=1,n
p3=p2
p2=p1
p1=((2.0*j-1.0)*z*p2-(j-1.)*p3)/j
enddo
pp=n*(z*p1-p2)/(z*z-1.0)
z1=z
z=z1-p1/pp
if(abs(z-z1).gt.eps) goto 1
x(i)=xm-xl*z
x(n+1-i)=xm+xl*z
w(i)=2.0*xl/((1.0-z*z)*pp*pp)
DO I = 1, NGAUS
DO J = 1, NGAUS
IGAUS = IGAUS + 1
PHI(1,IGAUS)=0.25*(1.-XI(I))*(1.-XI(J))
PHI(2,IGAUS)=0.25*(1.+XI(I))*(1.-XI(J))
PHI(3,IGAUS)=0.25*(1.+XI(I))*(1.+XI(J))
PHI(4,IGAUS)=0.25*(1.-XI(I))*(1.+XI(J))
!
!
!
derivatives of linear interpolation functions
dpxi(1,1,IGAUS)=-0.25*(1.-xi(j))
dpxi(2,1,IGAUS)=-0.25*(1.-xi(i))
dpxi(1,2,IGAUS)=0.25*(1.-xi(j))
dpxi(2,2,IGAUS)=-0.25*(1.+xi(i))
dpxi(1,3,IGAUS)=0.25*(1.+xi(j))
dpxi(2,3,IGAUS)=0.25*(1.+xi(i))
dpxi(1,4,IGAUS)=-0.25*(1.+xi(j))
dpxi(2,4,IGAUS)=0.25*(1.-xi(i))
WW(IGAUS)=W(I)*W(J)
!
!
!
Second derivatives of interpolation functions
d2phi(1,igaus) = 0.25
d2phi(2,igaus) = -0.25
d2phi(3,igaus) = 0.25
d2phi(4,igaus) = -0.25
!
enddo
enddo
!
RETURN
end subroutine shapdom
!
!
*******************************************************
********
! THE FOLLOWING SUBROUTINE CALCULATE THE
SHAPE FUNCTIONS AND THEIR
! DERIVATIVES FOR A BOUNDARY SURFACE
!
SUBROUTINE SHAPSURF(XI)
!
Use param_var
Use shapbou_2d
!
Implicit None
!
real,intent(in) :: XI(NGAUS)
integer :: i
!
! TWO-DIMENSIONAL LINEAR SHAPE FUNCTIONS
!
DO I = 1, NGAUS
PHIBOU(1,I)=0.5*(1.-XI(I))
PHIBOU(2,I)=0.5*(1.+XI(I))
!
! DERIVATIVE OF SHAPE FUNCTIONS
!
DPXI(1,I)=-0.5
DPXI(2,I)=0.5
ENDDO
!
RETURN
end subroutine shapsurf
!
!
*******************************************************
********
11
!
w(n+1-i)=w(i)
enddo
DO IEL=1,NELEM
do inode = 1, nnode
iel_nod(inode) = lnod(inode,iel)
do idimn = 1,mdimn
xloc(idimn,inode) = x(idimn,iel_nod(inode))
enddo
enddo
CALL DERSHA(NNODE,mdimn,xloc,dpxi,d2phi,1,dshpdx,&
detjac,d2phidx)
ELEAREA(IEL)=0.0
DO I=1,MGAUS
!
do i=1,n
if(abs(x(i)).lt.eps) x(i)=0.0
if(abs(w(i)).lt.eps) w(i)=0.0
enddo
!
return
end subroutine gauleg
!
!
*******************************************************
*
! THE FOLLOWING SUBROUTINE CALCULATES THE
CHARACTERISTIC
! LENGTH OF EACH ELEMENT FOR THE ONE-D ELEMENT
!
subroutine eleleng(nelem)
!
Use grid_info
!
Implicit None
!
integer,intent(in) :: nelem
integer :: i,iel,nod1,nod2
real :: dxmin
!
dxmin = 1000.
do iel = 1,nelem
nod1 = lnod(1,iel)
nod2 = lnod(2,iel)
if(nod1==0.or.nod2==0) then
print *,'NODES ARRAY IS ZERO!'
write(*,*)'ELEMENT: ',iel,' NODES: ',(lnod(i,iel),i=1,2)
endif
cleng(iel)=abs(x(1,nod2) - x(1,nod1))
if(cleng(iel)<=dxmin) dxmin = cleng(iel)
enddo
!
write(*,100) dxmin
100 format('Delta X min = ',e16.8)
!
return
end subroutine eleleng
!
!
*******************************************************
*
! THE FOLLOWING SUBROUTINE CALCULATES THE
CHARACTERISTIC
! LENGTH OF EACH ELEMENT
!
SUBROUTINE EVALELE(NNODE,NELEM,adap)
!
Use grid_info
Use Gaus_quad
Use shap_fcns
!
Implicit None
!
integer,intent(in) :: nnode,nelem
integer :: iel,inode,jpoin,i,idimn
integer,dimension(nnode) :: iel_nod
real,dimension(mdimn,nnode) :: xloc
real :: ELEAREA(nelem)
real :: dshpdx(mdimn,mnode,mgaus),detjac(mgaus)
real :: d2phidx(mdimn,mdimn,mnode,mgaus)
!
logical,intent(in) :: adap
ELEAREA(IEL)=ELEAREA(IEL)+DETJAC(I)*ww(i)
enddo
if(elearea(iel).le.0.0) then
write(*,1000)iel
do inode = 1,nnode
jpoin = iel_nod(inode)
write(*,*)jpoin,x(1,jpoin),x(2,jpoin)
enddo
endif
CLENG(IEL)=SQRT(ELEAREA(IEL))
!
write(27,*)iel,cleng(iel)
enddo
1000 format('Element ',i8,' has zero or negative area.',/, &
&
'Coordinates are: ')
RETURN
end subroutine evalele
!
!
*******************************************************
******
SUBROUTINE DERSHA(NNODE,ndimn,xloc,dpxi,d2phi,iflag,
&
&
dshpdx,detjac,d2phidx)
!
! THIS SUBROUTINE CALCULATES THE DERIVATIVES OF
THE SHAPE FUNCTIONS
!
Use param_var
!
Use Gaus_quad
!
Use shap_fcns
!
Use grid_info
!
Implicit None
!
integer,intent(in) :: nnode,ndimn,iflag
real,dimension(ndimn,nnode),intent(in) :: xloc
real,intent(in) ::
dpxi(mdimn,mnode,mgaus),d2phi(mnode,mgaus)
real,intent(out) :: dshpdx(mdimn,mnode,mgaus),detjac(mgaus)
real,intent(out) :: d2phidx(mdimn,mdimn,mnode,mgaus)
integer :: i,igaus,k,L
real,dimension(nnode) :: XELEM,YELEM
real :: dxdxi,dxdeta,dydxi,dydeta
!
DO I=1,nnode
XELEM(I)=Xloc(1,i)
YELEM(I)=Xloc(2,i)
enddo
!
DO IGAUS = 1, MGAUS
DXDXI = 0.0
DXDETA = 0.0
DYDXI = 0.0
DYDETA = 0.0
DO L = 1, NNODE
DXDXI = DXDXI + dpxi(1,L,IGAUS)*xelem(L)
12
DXDS(IGAUS) = 0.0
DXDETA = DXDETA +
dpxi(2,L,IGAUS)*xelem(L)
DYDXI = DYDXI + dpxi(1,L,IGAUS)*yelem(L)
DYDETA = DYDETA +
dpxi(2,L,IGAUS)*yelem(L)
enddo
!
! determinant of Jacobian
!
detjac(IGAUS)=dxdxi*dydeta - dxdeta*dydxi
!
if(detjac(IGAUS).lt.1.0e-12)then
write(*,*)'detjac = ',detjac(igaus)
write(*,*)'X-Coordinates: ',(xelem(i),i=1,nnode)
write(*,*)'Y-Coordinates: ',(yelem(i),i=1,nnode)
stop
endif
!
!
! CALCULATE DERIVATIVES OF SHAPE FUNCTIONS
!
DO K = 1,NNODE
!
DO INODE = 1, 2
DXDS(IGAUS)=DXDS(IGAUS)+DPXI(1,INODE,IGAUS)*XELE
M(INODE)
enddo
!
!
write(*,50)igaus,dxds(igaus),dyds(igaus)
! 50 format(i4,2e16.8)
!
DL=DXDS(IGAUS)
DETJAC(IGAUS) = DL
!
!
write(*,55)dl
! 55 format(' DL = ',e16.8)
!
DO INODE = 1, 2
DSHPDX(1,INODE,IGAUS) =
dpxi(1,inode,igaus)/dxds(igaus)
enddo
enddo
!
RETURN
end subroutine dersh1d
!
!
*******************************************************
********
! Subroutine to calculate spatial second derivative of shape
! functions for numerical damping
!
subroutine
dersha2(igaus,nnode,ndimn,xloc,dpxi,d2phi,dxdxi,dxdeta,&
&dydxi,dydeta,detjac,d2phidx)
!
!DIR$ INLINEALWAYS dersha2
Use param_var
!
Use Gaus_quad
!
Use shap_fcns
!
Use grid_info
!
Implicit None
!
integer,intent(in) :: igaus,nnode,ndimn
real,dimension(ndimn,nnode),intent(in) :: xloc
real,intent(in) ::
dpxi(mdimn,mnode,mgaus),d2phi(mnode,mgaus)
real,intent(in) :: dxdxi,dxdeta,dydxi,dydeta
real,intent(in) :: detjac(mgaus)
real,dimension(mdimn,mdimn,mnode,mgaus),intent(out)
::d2phidx
real :: xelem(nnode), yelem(nnode)
integer :: i,inode
real :: dxxieta,dyxieta,djacdxi,djacdeta,detjac2,detjac3
real :: term1,term2,term3,term4
!
! print *, 'Entering Subroutine to calculate second derivatives'
do i = 1, nnode
xelem(i) = xloc(1,i)
yelem(i) = xloc(2,i)
enddo
!
dxxieta = 0.0
dyxieta = 0.0
!
do inode = 1, nnode
dxxieta = dxxieta + d2phi(inode,igaus)*xelem(inode)
dyxieta = dyxieta + d2phi(inode,igaus)*yelem(inode)
enddo
DSHPDX(1,K,IGAUS)=(DYDETA*DPXI(1,K,IGAUS) &
&
DYDXI*DPXI(2,K,IGAUS))/DETJAC(IGAUS)
DSHPDX(2,K,IGAUS)=(DXDETA*DPXI(1,K,IGAUS) + &
&
DXDXI*DPXI(2,K,IGAUS))/DETJAC(IGAUS)
enddo
!
if(iflag.eq.2) &
&
call dersha2(igaus,nnode,ndimn,xloc,dpxi,d2phi,dxdxi,&
&dxdeta,dydxi,dydeta,detjac,d2phidx)
!
!
DETJAC(IGAUS) = DETJAC(IGAUS)*WW(IGAUS)
enddo
!
return
end subroutine dersha
!
!
*******************************************************
****
! THE FOLLOWING SUBROUTINE CALCULATES THE
Derivatives of the
! ONE-D SHAPE FUNCTIONS
!
SUBROUTINE DERSH1D(nnode,xloc,dpxi,dshpdx,detjac)
!
Use param_var
!
Use Gaus_quad
!
Use shap_fcns
!
Use grid_info
!
Implicit None
!
integer,intent(in) :: nnode
real,dimension(mdimn,nnode),intent(in) :: xloc
real,dimension(mdimn,mnode,mgaus),intent(in) :: dpxi
real,intent(out) :: dshpdx(mdimn,mnode,mgaus),detjac(mgaus)
integer :: inode,igaus
real :: dl
real :: DXDS(MGAUS)
real :: XELEM(2)
DO INODE = 1, 2
XELEM(INODE) = Xloc(1,inode)
enddo
!
DO IGAUS = 1, NGAUS
13
d2phidx(1,2,inode,igaus) = term1 + term2 + term3 +
!
term4
!
djacdxi = dxdxi*dyxieta - dxxieta*dydeta
djacdeta = dxxieta*dydeta - dxdeta*dyxieta
!
!
write(*,1100) igaus,detjac(igaus)
1100 format('At Gaussian Point ',i4,'Det of Jacobian = ',e16.8)
detjac2 = 1./detjac(igaus)**2
detjac3 = 1./detjac(igaus)**3
!
do inode = 1, nnode
term1 = -detjac3*djacdxi*(dydeta**2*
&
&
dpxi(1,inode,igaus) - dydeta* &
&
dydxi*dpxi(2,inode,igaus))
!
term2 = detjac2*(dydeta*dyxieta*dpxi(1,inode,igaus)
&
&
- dydeta*dydxi*d2phi(inode,igaus))
!
term3 = detjac3*djacdeta*(dydxi*dydeta*
&
&
dpxi(1,inode,igaus) - dydxi**2* &
&
dpxi(2,inode,igaus))
!
term4 = -detjac2*(dydxi*dydeta*
&
&
d2phi(inode,igaus) - dydxi*dyxieta* &
&
dpxi(2,inode,igaus))
!
! d2phi/dx2
!
d2phidx(1,1,inode,igaus) = term1 + term2 + term3 +
term4
!
term1 = detjac3*djacdxi*(-dxdeta**2*
&
&
dpxi(1,inode,igaus) + dxdeta* &
&
dxdxi*dpxi(2,inode,igaus))
!
term2 = -detjac2*(-dxdeta*dxxieta*
&
&
dpxi(1,inode,igaus) + dxdeta* &
&
dxdxi*d2phi(inode,igaus))
!
term3 = -detjac3*djacdeta*(-dxdxi*dxdeta* &
&
dpxi(1,inode,igaus) + dxdxi**2* &
&
dpxi(2,inode,igaus))
!
term4 = detjac2*(-dxdxi*dxdeta*
&
&
d2phi(inode,igaus) + dxdxi*dxxieta* &
&
dpxi(2,inode,igaus))
!
! d2phi/dy2
!
d2phidx(2,2,inode,igaus) = term1 + term2 + term3 +
term4
!
term1 = -detjac3*djacdxi*(-dydeta*dxdeta* &
&
dpxi(1,inode,igaus) + dydeta* &
&
dxdxi* dpxi(2,inode,igaus))
!
term2 = detjac2*(-dydeta*dxxieta*dpxi(1,inode,igaus)
&
&
+ dydeta*dxdxi*d2phi(inode,igaus))
!
term3 = detjac3*djacdeta*(-dydxi*dxdeta* &
&
dpxi(1,inode,igaus) + dydxi*
&
&
dxdxi*dpxi(2,inode,igaus))
!
term4 = -detjac2*(-dydxi*dxdeta*
&
&
d2phi(inode,igaus) + dydxi*dxxieta* &
&
dpxi(2,inode,igaus))
!
! d2phi/dxdy
!
&
&
term1 = detjac3*djacdxi*(dxdeta*dydeta*
dpxi(1,inode,igaus) - dxdeta* &
dydxi*dpxi(2,inode,igaus))
&
!
term2 = -detjac2*(dxdeta*dyxieta*dpxi(1,inode,igaus)
&
&
- dxdeta*dydxi*d2phi(inode,igaus))
&
&
term3 = -detjac3*djacdeta*(dxdxi*dydeta*
dpxi(1,inode,igaus) - dxdxi* &
dydxi*dpxi(2,inode,igaus))
&
&
term4 = detjac2*(dxdxi*dydeta*
d2phi(inode,igaus) - dxdxi*dyxieta* &
dpxi(2,inode,igaus))
!
&
!
!
!
!
&
d2phidydx
d2phidx(2,1,inode,igaus) = term1 + term2 + term3 +
term4
!
enddo
!
!
write(55,1000)igaus
!
write(55,'(4e16.8)')(d2phidx2(knode,igaus), knode = 1, nnode)
!
write(55,'(4e16.8)')(d2phidy2(knode,igaus), knode = 1, nnode)
!
write(55,'(4e16.8)')(d2phidxy(knode,igaus), knode = 1, nnode)
!
write(55,'(4e16.8)')(d2phidyx(knode,igaus), knode = 1, nnode)
!
1000 format(' Gaussian Point ',i8)
! print *,'Finished calculating second derivatives'
!
return
end subroutine dersha2
!
!
*******************************************************
*********
! SUBROUTINE TO CONVERT CONSERVATION
VARIABLES TO PRIMITIVE
! VARIABLES
!
SUBROUTINE PRIMVAR(NPOIN,nequa,ndimn)
!
Use thermo_propt
Use flow_var
!
Implicit None
!
integer,intent(in) :: npoin,nequa,ndimn
integer :: j,iordr,idimn
real ::energy
!
DO J=1,NPOIN
iordr = nequa*(J-1)
DENSE(J) = U(iordr+1)
ENERG(J)=U(iordr+2+ndimn)/U(iordr+1)
ENERGY = ENERG(J)
do idimn = 1,ndimn
VEL(idimn,j)=U(iordr+1+idimn)/U(iordr+1)
ENERGY=ENERGY-0.5*VEL(idimn,J)*VEL(idimn,J)
enddo
TEMPR(J)=ENERGY/CV
PRESS(J)=DENSE(J)*GAMM1*ENERGY
enddo
!
14
!
*******************************************************
************
! THE FOLLOWING SUBROUTINE CALCULATES THE
IMPLICITNESS PARAMETERS
! BASED ON THE ELEMENT MACH NUMBER AND
REYNOLDS NUMBER
!
Subroutine
imparm(NELEM,NPOIN,NNODE,NVISC,IMPPA,ndimn,en,iternu
m)
!
Use thermo_propt
Use grid_info
Use flow_var
Use var_parm
Use Mach_old
!
Implicit None
!
integer,intent(in) :: nelem,npoin,nnode,nvisc,ndimn
integer,intent(in) :: imppa,iternum
integer :: ipoin,idimn,iel,i,jpoin
real,intent(in) :: en
real :: pwr,acou,velo,emmax,emmin,emach
real :: s1spat,ri,emmaxt,emmint,s1time
real :: cvisc,cp,hk,remax,remin,pemax,pemin,re,pe
real :: s3spat,pratio,remaxt,remint,pemaxt,pemint
real :: s3time,s3pspat,s3ptime
real :: EM(nPOIN),REYNO(nPOIN),pecno(npoin)
!
! CHARACTER*4 NUM
! CHARACTER*12 FILENAME
!
!
en = 6.0
pwr = en
!
! CALCULATE CONVECTIVE IMPLICITNESS
PARAMETERS BASED ON MACH
! NUMBER
!
!
DO IPOIN = 1, NPOIN
IF(TEMPR(IPOIN).LT.1.0E-12) TEMPR(IPOIN)=0.0
ACOU = SQRT(GAMMA*CGAS*TEMPR(IPOIN))
velo = 0.0
do idimn = 1, ndimn
velo = velo +vel(idimn,ipoin)*vel(idimn,ipoin)
enddo
VELO=SQRT(velo)
IF(ACOU.LT.1.0E-12) THEN
EM(IPOIN)=CMACH
ELSE
EM(IPOIN)=VELO/ACOU
ENDIF
enddo
!
DO IEL = 1, NELEM
IPOIN = LNOD(1,IEL)
EMMAX = EM(IPOIN)
EMMIN = EMMAX
DO I= 2, NNODE
JPOIN = LNOD(i,IEL)
EMACH = EM(JPOIN)
IF(EMACH.GE.EMMAX) EMMAX = EMACH
IF(EMACH.LE.EMMIN) EMMIN = EMACH
enddo
!
IF(EMMIN.EQ.0.0)THEN
S1SPAT=1.
RETURN
end subroutine primvar
!
!
*******************************************************
**
! THE FOLLOWING SUBROUTINE CALCULATES THE
TIME STEP
! FROM THE CFL CONDITION
!
SUBROUTINE CFLTODT(NELEM,nnode,ndimn,CFL,DT)
!
Use thermo_propt
Use grid_info
Use flow_var
!
Implicit None
!
integer,intent(in) :: nelem,nnode,ndimn
real,intent(in) :: cfl
real,intent(out) :: dt
integer :: iel,jnode,idimn,L
real :: dxoumx,dxou,velo,acou,denom,dxouele
real :: amaxele,amax,velmax,vmax
integer :: ipoin,jpoin
!
DXOUMX=1000.
DO IEL=1,NELEM
DXOU=1000.
DO JNODE=1,nnode
L=LNOD(JNODE,iel)
velo = 0.0
do idimn = 1, ndimn
velo=velo + vel(idimn,L)*vel(idimn,L)
enddo
VELO=SQRT(VELO)
IF(TEMPR(L).LT.1.0E-12) TEMPR(L)=0.0
ACOU=SQRT(GAMMA*CGAS*TEMPR(L))
DENOM=ACOU+VELO
if(denom.eq.0.0) cycle
DXOUELE=CLENG(IEL)/DENOM
IF(DXOUELE.LE.DXOU) then
DXOU = DXOUELE
ipoin = L;amaxele=acou;velmax=velo
endif
enddo
IF(DXOU.LE.DXOUMX) then
DXOUMX = DXOU
jpoin = ipoin; amax=amaxele; vmax=velmax
endif
enddo
DT=CFL*DXOUMX
!
write(23,150) jpoin,amax,vmax
!
if(dt.le.1.0e-10) then
write(*,100) dt
stop
endif
!
100 format(' ALGORITHM MAY BE UNSTABLE! DT = ',e16.8)
150 format('Maximum velocity at point ',i8,' Max Acou vel:
',e12.6, &
&
/,'Max vel: ',e12.6)
RETURN
end subroutine cfltodt
!
15
!
!
! CALCULATE COEFFICIENT OF VISCOSITY USING
SUTHERLAND'S
! RELATIONSHIP
!
IF(TEMPR(IPOIN).LT.1.0E-12) THEN
CVISC = 1.0
ELSE
if(emmin==0.0.and.emmax==0.0) s1spat = 0.0
ELSE
ri=sqrt(emmax**2-emmin**2)/emmin
IF(RI.GE.0.01)THEN
S1SPAT=AMIN1(RI,1.0)
if(emmax-emmin<=1.0e-06) s1spat = 0.0
ELSE
S1SPAT=0.
ENDIF
ENDIF
CVISC=(1.0+CSUTH)/(TEMPR(IPOIN)+CSUTH)*TEMPR(IPOIN
)**1.5
ENDIF
!
velo = 0.0
do idimn = 1, ndimn
velo=velo+vel(idimn,ipoin)*vel(idimn,ipoin)
enddo
VELO=SQRT(velo)
REYNO(IPOIN) = DENSE(IPOIN)*VELO/CVISC
cp = gamma*cv
hk = cvisc/gm1m2pr
pecno(ipoin) = cp*velo*dense(ipoin)/hk
enddo
!
DO IEL = 1, NELEM
IPOIN = LNOD(1,IEL)
REMAX = REYNO(IPOIN)
REMIN = REMAX
pemax = pecno(ipoin)
pemin = pemax
DO I= 2, NNODE
JPOIN = LNOD(i,IEL)
RE = REYNO(JPOIN)
IF(RE.GE.REMAX) REMAX = RE
IF(RE.LE.REMIN) REMIN = RE
pe = pecno(jpoin)
if(pe.ge.pemax) pemax = pe
if(pe.le.pemin) pemin = pe
enddo
!
! s3 based on Reynolds number
!
if(remin.lt.1.0e-12) remin = 0.0
!
IF(REMIN.EQ.0.0)THEN
S3SPAT=1.
ELSE
ri = sqrt(remax**2-remin**2)/remin
IF(RI.GE.0.01)THEN
S3SPAT=AMIN1(RI,1.0)
ELSE
S3SPAT=0.
ENDIF
ENDIF
!
s3ele(iel) = s3spat
!
! s3 based on Peclet number
!
if(pemin.lt.1.0e-12) pemin = 0.0
!
IF(PEMIN.EQ.0.0)THEN
S3PSPAT=1.
ELSE
pratio = sqrt(pemax**2 - pemin**2)/pemin
IF(pratio.GE.0.01)THEN
S3PSPAT=AMIN1(pratio,1.0)
ELSE
S3PSPAT=0.
ENDIF
ENDIF
!
s1ele(iel) = s1spat
!
if(iternum.gt.1) then
IPOIN = LNOD(1,IEL)
EMMAXT = EMACHOLD(IPOIN)
EMMINT = EMMAXT
DO I= 2, NNODE
JPOIN = LNOD(i,IEL)
EMACH = EMACHOLD(JPOIN)
IF(EMACH.GE.EMMAXT) EMMAXT = EMACH
IF(EMACH.LE.EMMINT) EMMINT = EMACH
ENDDO
!
!
!
IF(EMMAX.GT.EMMAXT) EMMAXT = EMMAX
IF(EMMIN.LT.EMMINT) EMMINT = EMMIN
IF(EMMINt.EQ.0.0)THEN
S1TIME=1.
if(emmint==0.0.and.emmaxt==0.0) s1time = 0.0
ELSE
ri=sqrt(emmaxt**2-emmint**2)/emmint
IF(RI.GE.0.01)THEN
S1TIME=AMIN1(RI,1.0)
if(emmaxt-emmint<=1.0e-06) s1time = 0.0
ELSE
S1TIME=0.
ENDIF
ENDIF
!
if(s1time>s1spat) s1ele(iel) = s1time
!
endif
!
Select Case(imppa)
Case(1)
S2ELE(IEL) = S1ELE(IEL)
Case(2)
S2ELE(IEL) = 1. - S1ELE(IEL)
Case(3)
S2ELE(IEL) = s2
Case(4)
S2ELE(IEL) = MAX(1.-S1ELE(IEL),0.5)
Case(5)
s2ele(iel) = sqrt(1. - s1ele(iel)**2)
Case(6)
s2ele(iel) = s1ele(iel)**pwr
Case(7)
s2ele(iel) = 0.5*(1. + s1ele(iel)**pwr)
end Select
enddo
!
! CALCULATE DISSIPATIVE IMPLICITNESS PARAMETER
BASED ON
! REYNOLDS NUMBER
!
IF(NVISC.EQ.1) THEN
!
DO IPOIN = 1, NPOIN
!
16
Case(6)
s4ele(iel) = s3ele(iel)**pwr
s4pec(iel) = s3pec(iel)**pwr
Case(7)
s4ele(iel) = 0.5*(1. + s3ele(iel)**pwr)
s4pec(iel) = 0.5*(1. + s3pec(iel)**pwr)
end Select
enddo
!
s3pec(iel) = s3pspat
!
if(iternum.gt.1) then
IPOIN = LNOD(1,IEL)
REMAXT = REYOLD(IPOIN)
REMINT = REMAXT
pemaxt = pecold(ipoin)
pemint = pemaxt
DO I= 2, NNODE
JPOIN = LNOD(i,IEL)
RE = REYOLD(JPOIN)
IF(RE.GE.REMAXT) REMAXT = RE
IF(RE.LE.REMINT) REMINT = RE
pe = pecold(jpoin)
if(pe.ge.pemaxt) pemaxt = pe
if(pe.le.pemint) pemint = pe
enddo
!
else
do iel = 1,nelem
s3ele(iel) = 0.0
s4ele(iel) = 0.0
s3pec(iel) = 0.0
s4ele(iel) = 0.0
enddo
!
ENDIF
!
do ipoin = 1, npoin
emachold(ipoin) = em(ipoin)
if(nvisc.eq.1) then
reyold(ipoin) = reyno(ipoin)
pecold(ipoin) = pecno(ipoin)
endif
enddo
!
if(remint.lt.1.0e-12) remint = 0.0
if(pemint.lt.1.0e-12) pemint = 0.0
!
if(remax.gt.remaxt) remaxt = remax
if(remin.lt.remint) remint = remin
if(pemax.gt.pemaxt) pemaxt = pemax
if(pemin.lt.pemint) pemint = pemin
!
RETURN
end subroutine imparm
!
IF(REMINT.EQ.0.0)THEN
S3TIME=1.
ELSE
ri = sqrt(remaxt**2-remint**2)/remint
IF(RI.GE.0.01)THEN
S3TIME=AMIN1(RI,1.0)
ELSE
S3TIME=0.
ENDIF
ENDIF
!
!
*******************************************************
*******
! THE FOLLOWING SUBROUTINE CALCULATES THE
CONVECTIVE FLUX
! AT A NODAL POINT (ONE-D)
!
SUBROUTINE CONVFLX1(NPOIN)
!
Use flow_var
Use Conv_flux
!
Implicit None
!
integer,intent(in) :: npoin
integer :: k
real :: r,uvel,p,e
!
DO K=1,NPOIN
!
R = DENSE(K)
UVEL = VEL(1,K)
P = PRESS(K)
E = ENERG(K)
!
F(K,1,1)=R*UVEL
F(K,1,2)=R*UVEL*UVEL + P
F(K,1,3)=R*E*UVEL + P*UVEL
!
enddo
!
RETURN
end subroutine CONVFLX1
!
!
*******************************************************
*******
! THE FOLLOWING SUBROUTINE CALCULATES THE
CONVECTIVE FLUX
! AT A NODAL POINT
!
IF(PEMINT.EQ.0.0)THEN
S3PTIME=1.
ELSE
pratio = sqrt(pemaxt**2 - pemint**2)/pemint
IF(pratio.GE.0.01)THEN
S3PTIME=AMIN1(pratio,1.0)
ELSE
S3PTIME=0.
ENDIF
ENDIF
!
if(s3time>s3spat) s3ele(iel) = s3time
if(s3ptime>s3pspat) s3pec(iel) = s3ptime
endif
!
Select Case(imppa)
Case(1)
S4ELE(IEL) = S3ELE(IEL)
s4pec(iel) = s3pec(iel)
Case(2)
S4ELE(IEL) = 1. - S3ELE(IEL)
s4pec(iel) = 1. - s3pec(iel)
Case(3)
S4ELE(IEL) = s4
s4pec(iel) = s4
Case(4)
S4ELE(IEL) = MAX(1.-S3ELE(IEL),0.5)
s4pec(iel) = max(1. - s3pec(iel),0.5)
Case(5)
s4ele(iel) = sqrt(1. - s3ele(iel)**2)
s4pec(iel) = sqrt(1. - s3pec(iel)**2)
17
call
ONED_INGRL(NELEM,nblock,NEQUA,NNODE,NDIMN,neleq,n
ordr,&
&
NVISC,DT,IMPPA,adap,artvis)
!
Case(2)
! Calculate Domain intergral FDV equations
CALL
DOMINGRL(NELEM,nblock,NEQUA,NNODE,NDIMN,neleq,&
&
nordr,NVISC,DT,IMPPA,adap,artvis)
!
! Calculate Surface integral FDV equations
CALL
BOUINGRL(nface,dt,nequa,ndimn,ndbou,neleq,nvisc,imppa)
!
Case(3)
! Calculate Domain intergral FDV equations
CALL
DOMINGRL3D(NELEM,nblock,NEQUA,NNODE,NDIMN,neleq,n
ordr, &
&
NVISC,DT,IMPPA,adap,artvis)
! Calculate Surface integral FDV equations
call bouingrl3d(nface,dt,nnode,nequa,ndimn,neleq,nvisc, &
&
ndbou,imppa,itime)
end Select
!
! Apply boundary conditions
!
call bc (nnode,nordr,ndimn,ndbou,nequa,nface,neleq,nblock)
!
!
1000 format(' WARNING: DIAGONAL AT EQUATION ',i8,' IS
NEGATIVE')
1100 FORMAT(' NODE: ',i8,' DIAGONAL = ',e16.8,'
BOUNDARY CONDITION ' &
&
,I8)
2005 format(' IORDR RHS VECTOR DIAGONAL ENTRY')
2010 format(i8,2(1x,e16.8))
!
RETURN
end subroutine meieqns
!
!
*******************************************************
**********
! SUBROUTINE TO BUILD DOMAIN INTEGRALS (One
Dimension)
!
SUBROUTINE
ONED_INGRL(NELEM,nblock,NEQUA,NNODE,NDIMN,neleq,n
ordr,&
&
NVISC,DT,IMPPA,adap,artvis)
!
Use grid_info
Use flow_var
Use thermo_propt
Use Gaus_quad
Use shap_fcns
Use FDV_coef
Use Conv_flux
Use var_parm
Use bnd_cnd
!
Implicit None
!
integer,intent(in) :: nelem,nequa,nnode,ndimn,neleq,nvisc,imppa
integer,intent(in) :: nordr,nblock
real,intent(in) :: dt
LOGICAL,intent(in) :: ADAP, artvis
!
!
SUBROUTINE CONVFLX(NPOIN)
!
Use flow_var
Use Conv_flux
!
Implicit None
!
integer,intent(in) :: npoin
integer :: k
real :: r,uvel,vvel,p,e
!
DO K=1,NPOIN
!
R = DENSE(K)
UVEL = VEL(1,K)
VVEL = VEL(2,K)
P = PRESS(K)
E = ENERG(K)
!
F(K,1,1)=R*UVEL
F(K,1,2)=R*UVEL*UVEL + P
F(K,1,3)=R*UVEL*VVEL
F(K,1,4)=R*E*UVEL + P*UVEL
!
F(K,2,1)=R*VVEL
F(K,2,2)=R*UVEL*VVEL
F(K,2,3)=R*VVEL*VVEL + P
F(K,2,4)=R*E*VVEL + P*VVEL
enddo
!
RETURN
end subroutine CONVFLX
!
!
*******************************************************
********
! SUBROUTINE TO BUILD EQUATIONS FOR MEIFEM
METHOD
!
SUBROUTINE
MEIEQNS(NELEM,NNODE,NFACE,NEQUA,NDIMN,nordr,neleq
,DT, &
&
nvisc,IMPPA,nblock,adap,artvis,itime)
!
Use grid_info
Use flow_var
Use FDV_coef
!
Implicit None
!
integer,intent(in) :: nelem,nnode,nface,nequa,ndimn
integer,intent(in) :: nordr,nvisc,imppa,nblock,itime
integer,intent(in) :: neleq
real,intent(in) :: dt
integer :: ndbou
LOGICAL :: ADAP,ARTVIS
!
if(ndimn.eq.2) ndbou = 2
if(ndimn.eq.3) ndbou = 4
!
! INITIALIZE FDV VARIABLES
!
rhs = 0.0
! zero array
delu = 0.0
! zero array
!
Select Case(ndimn)
Case(1)
18
if(kequa.eq.nequa) s4imp(kequa) = s4pec(iel)
enddo
ELSE
do kequa = 1,nequa
S1IMP(kequa) = S1
S2IMP(kequa) = S2
S3IMP(kequa) = S3
S4IMP(kequa) = S4
enddo
ENDIF
real :: dt2ov2,reinv,re2inv
real :: e,T,vis,hk,vkk
real :: term1,term2,dfluxsum,fluxsum
real :: termb1,termb2
real :: aaba,abbb,detww,apb,pipj,dpixpj,dpixdpjx
integer :: inode,igaus,iel,koun,kequa,ieleq,jeleq
integer :: ig,idimn,jdimn,ir,is,nel,iordr,iequa
integer :: nel,mel,irow,icol
integer :: nal
integer :: ipoin,jpoin
integer :: ia,ja,jnode,jordr,kcol
integer,dimension(nnode) :: iel_nod
integer :: iblock,ieone,ie0,ielast,iv,nvec
!
do ieleq = 1,neleq
do jeleq = 1,neleq
bel(iel,ieleq,jeleq) = 0.0
enddo
enddo
!
!
!
!
!
!
!
!
!
!
real,dimension(ndimn,nnode) :: xloc,vloc
real,dimension(nnode) :: Eloc,Tloc
real :: Uloc(nnode,nequa),Floc(nnode,ndimn,nequa)
real :: DUNDX(ndimn,nEQUA),unkn(nequa),velo(ndimn)
real :: CFLUX(nDIMN,nEQUA),DFJDXJ(nEQUA)
real :: G(nDIMN,nEQUA),tau(ndimn,ndimn)
real :: dgjdxj(nequa)
real :: dudx(ndimn,ndimn),dtdx(ndimn)
real :: d2tdx2(ndimn),d2udx2(ndimn,ndimn,ndimn)
real :: e1(ndimn,nequa,nequa), e2(ndimn,ndimn,nequa,nequa)
real :: dshpdx(mdimn,mnode,mgaus),detjac(mgaus)
real :: d2phidx(mdimn,mdimn,mnode,mgaus)
real delx(mdimn),S(mdimn,mdimn,mdimn,mdimn)
!
do inode = 1, nnode
iel_nod(inode) = lnod(inode,iel)
ipoin = lnod(inode,iel)
Eloc(inode) = energ(ipoin)
Tloc(inode) = tempr(ipoin)
do idimn = 1,ndimn
xloc(idimn,inode) = x(idimn,ipoin)
vloc(idimn,inode) = vel(idimn,ipoin)
enddo
do iequa = 1,nequa
iordr = nequa*(ipoin-1) + iequa
uloc(inode,iequa) = u(iordr)
do idimn = 1,ndimn
Floc(inode,idimn,iequa) = F(ipoin,idimn,iequa)
enddo
enddo
enddo
real,dimension(ndimn,nequa,nequa) :: aj,bj
real,dimension(ndimn,ndimn,nequa,nequa) :: cj
real :: xjac_flux(nequa)
real :: aa(ndimn,ndimn,nequa,nequa)
real :: ab(ndimn,ndimn,nequa,nequa)
real :: ba(ndimn,ndimn,nequa,nequa)
real :: bb(ndimn,ndimn,nequa,nequa)
real dphidx(mdimn,mnode),d2shdx2(mdimn,mdimn,mnode)
real ht(mnode,mnode)
real hxi(mdimn)
real :: s1imp(nequa),s2imp(nequa),s3imp(nequa),s4imp(nequa)
real Fbar(mordr)
real psi(mnode)
real artdis(mordr)
!
call dersh1d(nnode,xloc,dpxi,dshpdx,detjac)
d2phidx = 0.0
!
!
!
!
!
!
!
!
DT2OV2 = DT*DT/2.
reinv = 1./creyn
re2inv = reinv/creyn
!
!
!
!
!
if(koun.le.100) then
do ig = 1,mgaus
do idimn = 1,ndimn
write(26,105)(dshpdx(idimn,inode,ig),inode = 1,nnode)
enddo
enddo
endif
105 format(4(1x,e16.8))
!
koun = koun + 1
!
! 101 format(' Element No. ',i8)
!
do igaus = 1, mgaus
!
detjac(igaus) = detjac(igaus)*ww(igaus)
!
enddo
!
!
gausloop: DO IG=1,MGAUS
!
!
if(iel.lt.200) then
!
write(38,2001)iel,ig
2001 format(' Shape function derivatives for element ',i8, &
&
' at Gaussian point ',i4)
!
do kdimn = 1,ndimn
!
write(38,*)(dshpdx(kdimn,knode,ig),knode=1,nnode)
!
enddo
!
endif
!
CALL
EVALDOM(NEQUA,NDIMN,NNODE,ig,vloc,Eloc,Tloc, &
&
Uloc,Floc,phi,dshpdx,&
do kequa = 1, nordr
artdis(kequa) = 0.0
enddo
koun = 1
!
blkloop: do iblock = 1,nblock
ieone = lblock(iblock)
ie0 = ieone - 1
ielast = lblock(iblock+1) - 1
nvec = lblock(iblock+1) - ieone
!
elemntlp: DO iv = 1, nvec
!
iel = ie0 + iv
!
IF(IMPPA.GE.1) THEN
do kequa = 1,nequa
S1IMP(kequa) = S1ELE(IEL)
S2IMP(kequa) = S2ELE(IEL)
S3IMP(kequa) = S3ELE(IEL)
if(kequa.eq.nequa) s3imp(kequa) = s3pec(iel)
S4IMP(kequa) = S4ELE(IEL)
19
!
&
d2phidx,VELO,E,T,unkn,DUDX,DTDX,DUNDX,CFLUX, &
&
DFJDXJ,d2tdx2,d2udx2)
!
!
CALL
AJACOB1(VELO,E,gamma,gamm1,gm3d2,gm1d2,gamm3,aj)
!
! CALCULATE VISCOUS TERMS ASSOCIATED WITH THE
NAVIER-STOKES
! EQUATIONS
!
! CALCULATE THE VISCOSITY USING SUTHERLAND'S
RELATIONSHIP
!
IF(T.LT.1.E-12) THEN
VIS=1.0
ELSE
VIS = (1.0 +CSUTH)/(T + CSUTH)*T**1.5
ENDIF
!
HK = VIS/GM1M2PR
!
if(nvisc.eq.1) then
vkk = 0.0
do idimn = 1,ndimn
vkk = vkk + dudx(idimn,idimn)
enddo
!
do idimn = 1,ndimn
do jdimn = 1,ndimn
tau(idimn,jdimn) = vis*(dudx(idimn,jdimn) + &
&
dudx(jdimn,idimn))
if(idimn.eq.jdimn) &
&
tau(idimn,jdimn) = tau(idimn,jdimn) - 2.*vis/3.*vkk
enddo
enddo
!
2000 format(' Element No. ',i6,' Gaussian Point ',i4,/,
&
&
' Viscous Flux')
2025 format(5(e12.6,1x))
!
2010 format(' Element No. ',i6,' Gaussian Point ',i4,
&
&
' Diffusion Jacobian')
2015 format(' Element No. ',i6,' Gaussian Point ',i4,
&
&
'Diffusion Gradient Jacobian')
!
endif
!
IF(NVISC.NE.1) THEN
!
do ir = 1,nequa
xjac_flux(ir) = 0.0
enddo
!
do is = 1,nequa
do ir = 1,nequa
xjac_flux(ir) = xjac_flux(ir) + aj(1,ir,is)* &
&
dfjdxj(is)
enddo
&
RHS(iordr)=RHS(iordr) + (DT*TERM1
&
-DT2OV2*TERM2)*DetJAC(ig)*ww(ig)
enddo
enddo
!
ELSE
!
do ir = 1,nequa
xjac_flux(ir) = 0.0
enddo
!
do is = 1,nequa
dfluxsum = dfjdxj(is) + dgjdxj(is)
do ir = 1,nequa
apb = aj(1,ir,is) + bj(1,ir,is)
xjac_flux(ir) = xjac_flux(ir) + apb*dfluxsum
enddo
enddo
!
DO NAL = 1, NNODE
DO IR = 1, NEQUA
!
iordr=nequa*(iel_nod(nal)-1)+ir
fluxsum = cflux(1,ir) + g(1,ir)
TERM1=DSHPDX(1,NAL,ig)*fluxsum
TERM2= xjac_flux(ir)*DSHPDX(1,NAL,ig)
!
RHS(iordr)=RHS(iordr) + (DT*TERM1
&
&
-DT2OV2*TERM2)*DETJAC(ig)*ww(ig)
enddo
enddo
ENDIF
!
! CALCULATE LHS MATRIX
!
call matxmult(ndimn,nequa,aj,aj,aa)
!
IF(NVISC.NE.1) THEN
!
do ir = 1,nequa
do is = 1,nequa
e2(1,1,ir,is) = -dt2ov2*s2imp(ir)*aa(1,1,ir,is)
e1(1,ir,is) = dt*s1imp(ir)*aj(1,ir,is)
enddo
enddo
!
else
!
call matxmult(ndimn,nequa,aj,bj,ab)
call matxmult(ndimn,nequa,bj,aj,ba)
call matxmult(ndimn,nequa,bj,bj,bb)
!
do ir = 1,nequa
do is = 1,nequa
aaba = aa(1,1,ir,is) + ba(1,1,ir,is)
abbb = ab(1,1,ir,is) + bb(1,1,ir,is)
e2(1,1,ir,is) = dt*s3imp(ir)*cj(1,1,ir,is) &
&
-dt2ov2*(s2imp(ir)*aaba
&
&
+s4imp(ir)*abbb)
e1(1,ir,is) = dt*(s1imp(ir)*aj(1,ir,is)+ &
&
s3imp(ir)*bj(1,ir,is))
enddo
enddo
endif
!
detww = detjac(ig)*ww(ig)
!
DO NEL=1,NNODE
enddo
!
DO NAL = 1, NNODE
DO IR = 1, NEQUA
iordr=nequa*(iel_nod(nal)-1)+ir
!
TERM1=
DSHPDX(1,NAL,ig)*CFLUX(1,IR)
TERM2 = xjac_flux(ir)*DSHPDX(1,NAL,ig)
20
Subroutine
DOMINGRL(NELEM,nblock,NEQUA,NNODE,NDIMN,neleq,nor
dr,&
&
NVISC,DT,IMPPA,adap,artvis)
!
Use param_var
Use grid_info
Use flow_var
Use thermo_propt
Use Gaus_quad
Use shap_fcns
Use FDV_coef
Use Conv_flux
Use Var_parm
!
IMplicit None
!
integer,intent(in) :: nelem,nequa,nnode,ndimn,neleq,nvisc,imppa
integer,intent(in) :: nordr,nblock
real,intent(in) :: dt
LOGICAL,intent(in) :: ADAP, artvis
!
integer :: i,iblock,icol,idimn,iel,iel0,ielno,iequa
integer :: ig,igaus,inode,iordr,ipoin,ir,irow,is,iv
integer :: j,jdimn
integer :: nal,na,nb,nvec
integer,dimension(nnode) :: iel_nod
!
real :: dt2ov2,E,reinv,T,vis,vkk,hk
real,dimension(nequa) :: s1imp,s2imp,s3imp,s4imp
real,dimension(nnode,mgaus) :: shap
real,dimension(mgaus) :: detjac
real,dimension(nnode) :: Eloc,Tloc
real,dimension(nnode,ndimn,nequa) :: Floc
real,dimension(nnode,nequa) :: Uloc
real,dimension(ndimn,nnode) :: vloc,xloc
real,dimension(nequa) :: dfjdxj,dgjdxj,unkn
real,dimension(ndimn,nequa) :: cflux,dundx,G
real,dimension(ndimn) :: dtdx,d2tdx2,velo
real,dimension(ndimn,ndimn) :: dudx,tau
real,dimension(ndimn,ndimn,ndimn) :: d2udx2
real,dimension(ndimn,nnode,mgaus) :: dshpdx
real,dimension(ndimn,ndimn,nnode,mgaus) :: d2phidx
real,dimension(ndimn,nequa,nequa) :: aj,bj,e1
real,dimension(ndimn,ndimn,nequa,nequa) :: cj,aa,ba,ab,bb,e2
real :: detww,term1,term2
real :: aapba,abpbb,pipj,dpixpj,dpiypj,dpixdpjx,dpixdpjy
real :: dpiydpjx,dpiydpjy
real :: axpbx,aypby,dfluxsum,xfluxsum,yfluxsum
real,dimension(nequa) :: xjac_flux,yjac_flux
!
dt2ov2 = dt*dt/2.
reinv = 1./creyn
!
blocklp: do iblock = 1,nblock
iel = lblock(iblock)
iel0 = iel - 1
nvec = lblock(iblock+1) - iel
!
eleloop: do iv = 1,nvec
ielno = iel0 + iv
!
! Variation Parameters
!
do iequa = 1,nequa
if(imppa>0) then
s1imp(iequa) = s1ele(ielno)
s2imp(iequa) = s2ele(ielno)
s3imp(iequa) = s3ele(ielno)
s4imp(iequa) = s4ele(ielno)
DO MEL=1,NNODE
!
pipj = phi(nel,ig)*phi(mel,ig)*detww
dpixpj = dshpdx(1,nel,ig)*phi(mel,ig)*detww
dpixdpjx = dshpdx(1,nel,ig)*dshpdx(1,mel,ig)*detww
!
DO IR=1,NEQUA
DO IS=1,NEQUA
!
TERMB1= -e1(1,ir,is)*dpixpj
TERMB2= -e2(1,1,ir,is)*dpixdpjx
!
irow = nequa*(nel-1) + ir
icol = nequa*(mel-1) + is
!
&
&
BEL(iel,irow,icol)=BEL(iel,irow,icol) +
&
(TERMB1+TERMB2)
IF(IR.EQ.IS) &
BEL(iel,irow,icol) = BEL(iel,irow,icol) + pipj
!
!
enddo
enddo
enddo
enddo
!
ENDDO gausloop
!
!
!
Apply boundary conditions
do inode = 1,nnode
ipoin = iel_nod(inode)
do ir = 1,nequa
iordr = nequa*(ipoin-1) + ir
do jnode = 1,nnode
jpoin = iel_nod(jnode)
do is = 1,nequa
jordr = nequa*(jpoin-1) + is
if(ibouncnd(jordr)<0) then
irow = nequa*(inode-1) + ir
icol = nequa*(jnode-1) + is
bel(iel,irow,icol) = 0.0
if(irow==icol) then
do kcol = 1,neleq
Bel(iel,irow,kcol) = 0.0 ! Zero column
enddo
Bel(iel,irow,icol) = 1.0
rhs(iordr) = 0.0
endif
endif
enddo
enddo
enddo
enddo
!
enddo elemntlp
!
enddo blkloop
!
RETURN
end subroutine oned_ingrl
!
!
*******************************************************
*************
! Subroutine to calculate domain integrals for the FDV Equations
!
21
&*vkk
else
s1imp(iequa) = s1
s2imp(iequa) = s2
s3imp(iequa) = s3
s4imp(iequa) = s4
endif
enddo
! Zero element stiffness matrix
!
Bel(ielno,1:neleq,1:neleq) = 0.0
!
do inode = 1,nnode
iel_nod(inode) = lnod(inode,ielno)
ipoin = lnod(inode,ielno)
Eloc(inode) = energ(ipoin)
Tloc(inode) = tempr(ipoin)
!
do idimn = 1,ndimn
vloc(idimn,inode) = vel(idimn,ipoin)
xloc(idimn,inode) = x(idimn,iel_nod(inode))
do iequa = 1,nequa
Floc(inode,idimn,iequa) = F(ipoin,idimn,iequa)
enddo
enddo
!
do iequa = 1,nequa
iordr = nequa*(ipoin-1) + iequa
Uloc(inode,iequa) = U(iordr)
enddo
enddo
!
shap = phi
!
!
! Calculate spatial derivatives of shape functions
!
CALL DERSHA(NNODE,ndimn,xloc,dpxi,d2phi,2,dshpdx,&
detjac,d2phidx)
!
! Gaussian Quadrature loop
!
gausloop: do ig = 1,mgaus
!
! Calculate value of flow variables at Gaussian Point
!
call evaldom(nequa,ndimn,nnode,ig,vloc,Eloc,Tloc,Uloc, &
&
Floc,shap,dshpdx,d2phidx,velo,E,T,unkn, &
&
dudx,dtdx,dundx,cflux,dfjdxj,d2tdx2,d2udx2)
!
! Calculate viscosity, thermal Conductivity, and stress tensor
!
if(T<1.0e-12) then
vis = 1.0
else
vis = (1.0 + csuth)/(T + csuth)*T**1.5
endif
!
hk = vis/gm1m2pr
!
vkk = 0.0
do idimn = 1,ndimn
vkk = vkk + dudx(idimn,idimn)
enddo
!
do idimn = 1,ndimn
do jdimn = 1,ndimn
tau(idimn,jdimn) = vis*(dudx(idimn,jdimn) + &
dudx(jdimn,idimn))
if(idimn==jdimn) &
tau(idimn,jdimn) = tau(idimn,jdimn) -2./3.*vis &
enddo
enddo
!
! Calculate Jacobians and Viscous Flux
!
call ajacob(velo,E,gamma,gamm1,gm3d2,gm1d2,gamm3,aj)
!
call viscflx(reinv,tau,hk,vis,dudx,dtdx,velo,d2tdx2, &
d2udx2,G,dgjdxj)
!
call bjacob(reinv,cv,vis,hk,tau,dundx,unkn,velo,E,bj)
!
call cjacob(reinv,cv,vis,hk,unkn,cj)
!
! Calculate Right-Hand-Side Vector
!
detww = detjac(ig)*ww(ig)
!
do ir = 1,nequa
xjac_flux(ir) = 0.0
yjac_flux(ir) = 0.0
enddo
!
do is = 1,nequa
dfluxsum = dfjdxj(is) + dgjdxj(is)
do ir = 1,nequa
axpbx = aj(1,ir,is) + bj(1,ir,is)
aypby = aj(2,ir,is) + bj(2,ir,is)
xjac_flux(ir) = xjac_flux(ir) + axpbx*dfluxsum
yjac_flux(ir) = yjac_flux(ir) + aypby*dfluxsum
enddo
enddo
!
do nal = 1,nnode
ipoin = iel_nod(nal)
do ir = 1,nequa
iordr = nequa*(ipoin-1) + ir
!
xfluxsum = cflux(1,ir) + G(1,ir)
yfluxsum = cflux(2,ir) + G(2,ir)
term1 = xfluxsum*dshpdx(1,nal,ig) + yfluxsum* &
&dshpdx(2,nal,ig)
term2 = xjac_flux(ir)*dshpdx(1,nal,ig) +
&
yjac_flux(ir)*dshpdx(2,nal,ig)
!
rhs(iordr) = rhs(iordr) + (dt*term1 - dt2ov2*term2) &
*detww
enddo
enddo
!
! Calculate LHS Matrix
!
call matxmult(ndimn,nequa,aj,aj,aa)
call matxmult(ndimn,nequa,bj,aj,ba)
call matxmult(ndimn,nequa,aj,bj,ab)
call matxmult(ndimn,nequa,bj,bj,bb)
!
do i = 1,ndimn
do ir = 1,nequa
do is = 1,nequa
e1(i,ir,is) = dt*(s1imp(ir)*aj(i,ir,is) &
+ s3imp(ir)*bj(i,ir,is))
aapba = aa(i,1,ir,is) + ba(i,1,ir,is)
abpbb = ab(i,1,ir,is) + bb(i,1,ir,is)
e2(i,1,ir,is) = dt*s3imp(ir)*cj(i,1,ir,is) &
- dt2ov2*(s2imp(ir)*aapba &
+ s4imp(ir)*abpbb)
!
aapba = aa(i,2,ir,is) + ba(i,2,ir,is)
22
IMplicit None
abpbb = ab(i,2,ir,is) + bb(i,2,ir,is)
e2(i,2,ir,is) = dt*s3imp(ir)*cj(i,2,ir,is) &
- dt2ov2*(s2imp(ir)*aapba &
+ s4imp(ir)*abpbb)
enddo
enddo
enddo
!
integer,intent(in) :: nelem,nequa,nnode,ndimn,neleq,nvisc,imppa
integer,intent(in) :: nordr,nblock
real,intent(in) :: dt
LOGICAL,intent(in) :: ADAP, artvis
!
integer :: i,iblock,icol,idimn,iel,iel0,ielno,iequa
integer :: ig,igaus,inode,iordr,ipoin,ir,irow,is,iv
integer :: j,jdimn
integer :: nal,na,nb,nvec
integer,dimension(nnode) :: iel_nod
!
do na = 1,nnode
do nb = 1,nnode
pipj = shap(na,ig)*shap(nb,ig)*detww
dpixpj = dshpdx(1,na,ig)*shap(nb,ig)*detww
dpiypj = dshpdx(2,na,ig)*shap(nb,ig)*detww
dpixdpjx = dshpdx(1,na,ig)*dshpdx(1,nb,ig)*detww
dpixdpjy = dshpdx(1,na,ig)*dshpdx(2,nb,ig)*detww
dpiydpjx = dshpdx(2,na,ig)*dshpdx(1,nb,ig)*detww
dpiydpjy = dshpdx(2,na,ig)*dshpdx(2,nb,ig)*detww
!
real :: dt2ov2,E,reinv,T,vis,vkk,hk
real,dimension(nequa) :: s1imp,s2imp,s3imp,s4imp
real,dimension(nnode,mgaus) :: shap
real,dimension(mgaus) :: detjac
real,dimension(nnode) :: Eloc,Tloc
real,dimension(nnode,ndimn,nequa) :: Floc
real,dimension(nnode,nequa) :: Uloc
real,dimension(ndimn,nnode) :: vloc,xloc
real,dimension(nequa) :: dfjdxj,dgjdxj,unkn
real,dimension(ndimn,nequa) :: cflux,dundx,G
real,dimension(ndimn) :: dtdx,d2tdx2,velo
real,dimension(ndimn,ndimn) :: dudx,tau
real,dimension(ndimn,ndimn,ndimn) :: d2udx2
real,dimension(ndimn,nnode,mgaus) :: dshpdx
real,dimension(ndimn,ndimn,nnode,mgaus) :: d2phidx
real,dimension(ndimn,nequa,nequa) :: aj,bj,e1
real,dimension(ndimn,ndimn,nequa,nequa) :: cj,aa,ba,ab,bb,e2
real :: detww,term1,term2
real :: aapba,abpbb,pipj,dpixpj,dpiypj,dpizpj,dpixdpjx,dpixdpjy
real :: dpixdpjz,dpiydpjx,dpiydpjy,dpiydpjz,dpizdpjx,dpizdpjy
real :: dpizdpjz
real ::
axpbx,aypby,azpbz,dfluxsum,xfluxsum,yfluxsum,zfluxsum
real,dimension(nequa) :: xjac_flux,yjac_flux,zjac_flux
!
dt2ov2 = dt*dt/2.
reinv = 1./creyn
!
blocklp: do iblock = 1,nblock
iel = lblock(iblock)
iel0 = iel - 1
nvec = lblock(iblock+1) - iel
!
eleloop: do iv = 1,nvec
ielno = iel0 + iv
!
! Variation Parameters
!
do iequa = 1,nequa
if(imppa>0) then
s1imp(iequa) = s1ele(ielno)
s2imp(iequa) = s2ele(ielno)
s3imp(iequa) = s3ele(ielno)
s4imp(iequa) = s4ele(ielno)
else
s1imp(iequa) = s1
s2imp(iequa) = s2
s3imp(iequa) = s3
s4imp(iequa) = s4
endif
enddo
! Zero element stiffness matrix
!
Bel(ielno,1:neleq,1:neleq) = 0.0
!
do inode = 1,nnode
iel_nod(inode) = lnod(inode,ielno)
!
do ir = 1,nequa
do is = 1,nequa
irow = nequa*(na-1) + ir
icol = nequa*(nb-1) + is
!
term1 = e1(1,ir,is)*dpixpj + e1(2,ir,is)* &
dpiypj
term2 = e2(1,1,ir,is)*dpixdpjx + &
e2(1,2,ir,is)*dpixdpjy + &
e2(2,1,ir,is)*dpiydpjx + &
e2(2,2,ir,is)*dpiydpjy
!
Bel(ielno,irow,icol) = Bel(ielno,irow,icol) &
&- term1 - term2
if(ir==is) &
Bel(ielno,irow,icol) = Bel(ielno,irow,icol) &
+ pipj
!
enddo
enddo
enddo
enddo
!
enddo gausloop
enddo eleloop
!
enddo blocklp
!
return
end subroutine domingrl
!
!
*******************************************************
*************
! Subroutine to calculate domain integrals for the FDV Equations
!
Subroutine
DOMINGRL3D(NELEM,nblock,NEQUA,NNODE,NDIMN,neleq,n
ordr,&
&
NVISC,DT,IMPPA,adap,artvis)
!
Use param_var
Use grid_info
Use flow_var
Use thermo_propt
Use Gaus_quad
Use shap_fcns
Use Shap3d_fcns
Use FDV_coef
Use Conv_flux
Use Var_parm
!
23
call viscflx_3d(reinv,tau,hk,vis,dudx,dtdx,velo, &
d2tdx2,d2udx2,G,dgjdxj)
ipoin = lnod(inode,ielno)
Eloc(inode) = energ(ipoin)
Tloc(inode) = tempr(ipoin)
!
call bjacob_3d(reinv,cv,vis,hk,tau,dundx,unkn,velo, &
E,bj)
!
do idimn = 1,ndimn
vloc(idimn,inode) = vel(idimn,ipoin)
xloc(idimn,inode) = x(idimn,iel_nod(inode))
do iequa = 1,nequa
Floc(inode,idimn,iequa) = F(ipoin,idimn,iequa)
enddo
enddo
!
call cjacob_3d(reinv,cv,vis,hk,unkn,cj)
!
endif
!
!
!
!
Calculate Right-Hand-Side Vector
detww = detjac(ig)*ww(ig)
do iequa = 1,nequa
iordr = nequa*(ipoin-1) + iequa
Uloc(inode,iequa) = U(iordr)
enddo
enddo
!
do ir = 1,nequa
xjac_flux(ir) = 0.0
yjac_flux(ir) = 0.0
zjac_flux(ir) = 0.0
enddo
!
shap = phi
!
! Calculate spatial derivatives of shape functions
!
call dersha_3d(nnode,ndimn,xloc,dpxi,d2phidxde,d2phidxdz,
&
&
d2phidedz,1,0,dshpdx,detjac,d2phidx)
!
!
! Gaussian Quadrature loop
!
gausloop: do ig = 1,mgaus
!
! Calculate value of flow variables at Gaussian Point
!
call evaldom(nequa,ndimn,nnode,ig,vloc,Eloc,Tloc,Uloc, &
&
Floc,shap,dshpdx,d2phidx,velo,E,T,unkn, &
&
dudx,dtdx,dundx,cflux,dfjdxj,d2tdx2,d2udx2)
!
! Calculate Convection Jacobian
!
call
ajacob_3d(velo,E,gamma,gamm1,gm3d2,gm1d2,gamm3,aj)
!
! For Viscous Flow,
!
Calculate viscosity, thermal Conductivity, and stress tensor
!
if(nvisc==1) then
if(T<1.0e-12) then
vis = 1.0
else
vis = (1.0 + csuth)/(T + csuth)*T**1.5
endif
!
hk = vis/gm1m2pr
!
vkk = 0.0
do idimn = 1,ndimn
vkk = vkk + dudx(idimn,idimn)
enddo
!
do idimn = 1,ndimn
do jdimn = 1,ndimn
tau(idimn,jdimn) = vis*(dudx(idimn,jdimn) + &
dudx(jdimn,idimn))
if(idimn==jdimn) &
tau(idimn,jdimn) = tau(idimn,jdimn) -2./3.*vis &
&*vkk
enddo
enddo
! Calculate Viscous Flux and Diffusion Jacobians
!
!
if(nvisc/=1) then
do is = 1,nequa
do ir = 1,nequa
xjac_flux(ir) = xjac_flux(ir) + aj(1,ir,is)*dfjdxj(is)
yjac_flux(ir) = yjac_flux(ir) + aj(2,ir,is)*dfjdxj(is)
zjac_flux(ir) = zjac_flux(ir) + aj(3,ir,is)*dfjdxj(is)
enddo
enddo
!
do nal = 1,nnode
ipoin = iel_nod(nal)
do ir = 1,nequa
iordr = nequa*(ipoin-1) + ir
term1 = cflux(1,ir)*dshpdx(1,nal,ig) + &
cflux(2,ir)*dshpdx(2,nal,ig) + &
cflux(3,ir)*dshpdx(3,nal,ig)
term2 = xjac_flux(ir)*dshpdx(1,nal,ig) +
&
yjac_flux(ir)*dshpdx(2,nal,ig) +
&
zjac_flux(ir)*dshpdx(3,nal,ig)
!
rhs(iordr) = rhs(iordr) + (dt*term1 - &
dt2ov2*term2)*detww
enddo
enddo
!
else
!
do is = 1,nequa
dfluxsum = dfjdxj(is) + dgjdxj(is)
do ir = 1,nequa
axpbx = aj(1,ir,is) + bj(1,ir,is)
aypby = aj(2,ir,is) + bj(2,ir,is)
azpbz = aj(3,ir,is) + bj(3,ir,is)
xjac_flux(ir) = xjac_flux(ir) + axpbx*dfluxsum
yjac_flux(ir) = yjac_flux(ir) + aypby*dfluxsum
zjac_flux(ir) = zjac_flux(ir) + azpbz*dfluxsum
enddo
enddo
!
do nal = 1,nnode
ipoin = iel_nod(nal)
do ir = 1,nequa
iordr = nequa*(ipoin-1) + ir
!
xfluxsum = cflux(1,ir) + G(1,ir)
yfluxsum = cflux(2,ir) + G(2,ir)
zfluxsum = cflux(3,ir) + G(3,ir)
term1 = xfluxsum*dshpdx(1,nal,ig) + yfluxsum* &
&dshpdx(2,nal,ig) + zfluxsum*dshpdx(3,nal,ig)
24
dpizdpjx = dshpdx(3,na,ig)*dshpdx(1,nb,ig)*detww
dpizdpjy = dshpdx(3,na,ig)*dshpdx(2,nb,ig)*detww
dpizdpjz = dshpdx(3,na,ig)*dshpdx(3,nb,ig)*detww
term2 = xjac_flux(ir)*dshpdx(1,nal,ig) +
&
yjac_flux(ir)*dshpdx(2,nal,ig) +
&
zjac_flux(ir)*dshpdx(3,nal,ig)
!
!
do ir = 1,nequa
do is = 1,nequa
irow = nequa*(na-1) + ir
icol = nequa*(nb-1) + is
rhs(iordr) = rhs(iordr) + (dt*term1 - dt2ov2*term2) &
*detww
enddo
enddo
endif
!
term1 = e1(1,ir,is)*dpixpj + e1(2,ir,is)* &
dpiypj + e1(3,ir,is)*dpizpj
term2 = e2(1,1,ir,is)*dpixdpjx + &
e2(1,2,ir,is)*dpixdpjy + &
e2(1,3,ir,is)*dpixdpjz + &
e2(2,1,ir,is)*dpiydpjx + &
e2(2,2,ir,is)*dpiydpjy + &
e2(2,3,ir,is)*dpiydpjz + &
e2(3,1,ir,is)*dpizdpjx + &
e2(3,2,ir,is)*dpizdpjy + &
e2(3,3,ir,is)*dpizdpjz
!
! Calculate LHS Matrix
!
call matxmult(ndimn,nequa,aj,aj,aa)
!
if(nvisc/=1) then
do i = 1,ndimn
do ir = 1,nequa
do is = 1,nequa
e1(i,ir,is) = dt*s1imp(ir)*aj(i,ir,is)
e2(i,1,ir,is) = -dt2ov2*s2imp(ir)*aa(i,1,ir,is)
e2(i,2,ir,is) = -dt2ov2*s2imp(ir)*aa(i,2,ir,is)
e2(i,3,ir,is) = -dt2ov2*s2imp(ir)*aa(i,3,ir,is)
enddo
enddo
enddo
!
else
call matxmult(ndimn,nequa,bj,aj,ba)
call matxmult(ndimn,nequa,aj,bj,ab)
call matxmult(ndimn,nequa,bj,bj,bb)
!
do i = 1,ndimn
do ir = 1,nequa
do is = 1,nequa
e1(i,ir,is) = dt*(s1imp(ir)*aj(i,ir,is) &
+ s3imp(ir)*bj(i,ir,is))
aapba = aa(i,1,ir,is) + ba(i,1,ir,is)
abpbb = ab(i,1,ir,is) + bb(i,1,ir,is)
e2(i,1,ir,is) = dt*s3imp(ir)*cj(i,1,ir,is) &
- dt2ov2*(s2imp(ir)*aapba &
+ s4imp(ir)*abpbb)
!
aapba = aa(i,2,ir,is) + ba(i,2,ir,is)
abpbb = ab(i,2,ir,is) + bb(i,2,ir,is)
e2(i,2,ir,is) = dt*s3imp(ir)*cj(i,2,ir,is) &
- dt2ov2*(s2imp(ir)*aapba &
+ s4imp(ir)*abpbb)
!
aapba = aa(i,3,ir,is) + ba(i,3,ir,is)
abpbb = ab(i,3,ir,is) + bb(i,3,ir,is)
e2(i,3,ir,is) = dt*s3imp(ir)*cj(i,3,ir,is) &
- dt2ov2*(s2imp(ir)*aapba &
+ s4imp(ir)*abpbb)
enddo
enddo
enddo
endif
!
do na = 1,nnode
do nb = 1,nnode
pipj = shap(na,ig)*shap(nb,ig)*detww
dpixpj = dshpdx(1,na,ig)*shap(nb,ig)*detww
dpiypj = dshpdx(2,na,ig)*shap(nb,ig)*detww
dpizpj = dshpdx(3,na,ig)*shap(nb,ig)*detww
dpixdpjx = dshpdx(1,na,ig)*dshpdx(1,nb,ig)*detww
dpixdpjy = dshpdx(1,na,ig)*dshpdx(2,nb,ig)*detww
dpixdpjz = dshpdx(1,na,ig)*dshpdx(3,nb,ig)*detww
dpiydpjx = dshpdx(2,na,ig)*dshpdx(1,nb,ig)*detww
dpiydpjy = dshpdx(2,na,ig)*dshpdx(2,nb,ig)*detww
dpiydpjz = dshpdx(2,na,ig)*dshpdx(3,nb,ig)*detww
!
Bel(ielno,irow,icol) = Bel(ielno,irow,icol) &
&- term1 - term2
if(ir==is) &
Bel(ielno,irow,icol) = Bel(ielno,irow,icol) &
+ pipj
!
enddo
enddo
enddo
enddo
!
enddo gausloop
enddo eleloop
!
enddo blocklp
!
return
end subroutine domingrl3d
!
!
*******************************************************
***********
! Subroutine to evaluate the boundary integrals for a three-D
problem
SUBROUTINE
BOUINGRL3d(NFACE,DT,nnode,NEQUA,NDIMN,neleq,NVISC,
&
&
ndbou,IMPPA,itime)
!
Use param_var
Use thermo_propt
Use grid_info
Use flow_var
Use Conv_flux
Use Bface_info
Use Bnd_cnd
Use Gaus_quad
Use shapbou_3d
Use FDV_coef
Use Var_parm
!
Implicit None
!
integer,intent(in) :: ndbou
!
integer,intent(in) :: nface,nnode,nequa,ndimn,neleq,ndbou
integer,intent(in) :: nvisc,imppa,itime
real,intent(in) :: dt
25
!
!
!
!
logical :: adiabatic
integer :: iface,ielno,ibndcnd,ifacdir,iequa,inode,ig
integer :: idimn,jdimn,ipoin,iordr,i,ir,is,j,na,nb
integer :: ia,ib,irow,icol
integer,dimension(ndbou) :: iel_nod
Calculate Convective Jacobian
call
ajacob_3d(velo,E,gamma,gamm1,gm3d2,gm1d2,gamm3,aj)
!
! For Viscous Flow, Calculate viscosity, thermal conductivity
!
and stress tensor
if(nvisc==1) then
if(T<1.0e-12) then
vis = 1.0
else
vis = (1.0 + csuth)/(T + csuth)*T**1.5
endif
!
hk = vis/gm1m2pr
!
vkk = 0.0
do idimn = 1,ndimn
vkk = vkk + dudx(idimn,idimn)
enddo
!
do idimn = 1,ndimn
do jdimn = 1,ndimn
tau(idimn,jdimn) = vis*(dudx(idimn,jdimn) + &
dudx(jdimn,idimn))
if(idimn==jdimn) &
tau(idimn,jdimn) = tau(idimn,jdimn) -2./3.*vis &
&*vkk
enddo
enddo
!
! Calculate viscous flux and diffusion Jacobians
call viscflx_3d(reinv,tau,hk,vis,dudx,dtdx,velo, &
d2tdx2,d2udx2,G,dgjdxj)
call bjacob_3d(reinv,cv,vis,hk,tau,dundx,unkn,velo,E,bj)
call cjacob_3d(reinv,cv,vis,hk,unkn,cj)
endif
!
! Apply boundary conditions to Jacobians
!
call jacbndcnd(ndimn,nequa,ibndcnd,adiabatic,hk,vis,unkn,
&
&dundx,E,reinv,tau,velo,aj,bj,cj)
!
! Calculate Right-Hand-Side Vector
!
do ir = 1,nequa
xjac_flux(ir) = 0.0
yjac_flux(ir) = 0.0
zjac_flux(ir) = 0.0
enddo
!
if(nvisc/=1) then
!
do is = 1,nequa
dfluxsum = dfxdx(1,is) + dfxdx(2,is) + dfxdx(3,is)
do ir = 1,nequa
xjac_flux(ir) = xjac_flux(ir) + aj(1,ir,is)*dfluxsum
yjac_flux(ir) = yjac_flux(ir) + aj(2,ir,is)*dfluxsum
zjac_flux(ir) = zjac_flux(ir) + aj(3,ir,is)*dfluxsum
enddo
enddo
!
do na = 1,ndbou
ipoin = iel_nod(na)
do ir = 1,nequa
iordr = nequa*(ipoin-1) + ir
!
term1 = cflux(1,ir)*en(1,ig) + cflux(2,ir)*en(2,ig) + &
!
real :: dt2ov2,E,reinv,T
real,dimension(nequa) :: s1imp,s2imp,s3imp,s4imp
real,dimension(ndimn) :: dtdx,d2tdx2,enorm,velo
real,dimension(ndimn,ngsurf) :: en
real,dimension(nequa) :: dgjdxj,unkn
real,dimension(ndimn,ndimn) :: dudx,tau
real,dimension(ndimn,ndimn,ndimn) :: d2udx2
real,dimension(ndimn,nequa) :: cflux,dfxdx,dundx,G
real :: hk,vis,vkk
real,dimension(ndimn,nequa,nequa) :: aj,bj,e1
real,dimension(ndimn,ndimn,nequa,nequa) :: cj,e2,aa,ab,ba,bb
real :: aapba,abpbb,dfluxsum,term1,term2
real :: pipj,pidpjx,pidpjy,pidpjz
real,dimension(nequa) :: xjac_flux,yjac_flux,zjac_flux
!
dt2ov2 = dt*dt/2.
reinv = 1./creyn
!
faceloop: do iface = 1,nface
ielno = lface(7,iface) ! Element containing boundary face
ibndcnd = lface(8,iface) ! Boundary type of face
ifacdir = lface(6,iface) ! Direction of unit normal to face
!
! Element Variation Parameters
!
do iequa = 1,nequa
if(imppa>0) then
s1imp(iequa) = s1ele(ielno)
s2imp(iequa) = s2ele(ielno)
s3imp(iequa) = s3ele(ielno)
s4imp(iequa) = s4ele(ielno)
else
s1imp(iequa) = s1
s2imp(iequa) = s2
s3imp(iequa) = s3
s4imp(iequa) = s4
endif
enddo
!
do inode = 1,ndbou
iel_nod(inode) = lface(inode,iface)
enddo
!
! Calculate spatial derivatives of shape functions and normal vector
!
call calnorm3(ndimn,ndbou,ifacdir,iel_nod,enorm,en)
!
! Gaussian Quadrature loop
!
gausloop: do ig = 1,ngsurf
!
! Calculate value of flow variables at Gaussian point
!
call
EVALBOU3D(NDIMN,NEQUA,iel_nod,dshpdx,IG,VELO, &
&
E,T,unkn,DUDX,dtdx,dundx,cflux,dfxdx,&
&
d2tdx2,d2udx2)
!
! Apply boundary conditions
!
call aplbndcnd(ndimn,nequa,ndbou,iface,ielno,ibndcnd, &
&iel_nod,ig,adiabatic,E,T,unkn,velo,dtdx,&
&d2tdx2,dudx,d2udx2,dundx,dfxdx,enorm)
26
+ s3imp(ir)*bj(i,ir,is))
aapba = aa(i,1,ir,is) + ba(i,1,ir,is)
abpbb = ab(i,1,ir,is) + bb(i,1,ir,is)
e2(i,1,ir,is) = dt*s3imp(ir)*cj(i,1,ir,is) &
- dt2ov2*(s2imp(ir)*aapba &
+ s4imp(ir)*abpbb)
aapba = aa(i,2,ir,is) + ba(i,2,ir,is)
abpbb = ab(i,2,ir,is) + bb(i,2,ir,is)
e2(i,2,ir,is) = dt*s3imp(ir)*cj(i,2,ir,is) &
- dt2ov2*(s2imp(ir)*aapba &
+ s4imp(ir)*abpbb)
aapba = aa(i,3,ir,is) + ba(i,3,ir,is)
abpbb = ab(i,3,ir,is) + bb(i,3,ir,is)
e2(i,3,ir,is) = dt*s3imp(ir)*cj(i,3,ir,is) &
- dt2ov2*(s2imp(ir)*aapba &
+ s4imp(ir)*abpbb)
enddo
enddo
enddo
endif
cflux(3,ir)*en(3,ig)
term2 = xjac_flux(ir)*en(1,ig) + yjac_flux(ir)*&
&en(2,ig) + zjac_flux(ir)*en(3,ig)
!
rhs(iordr) = rhs(iordr) + (-dt*term1 + dt2ov2*term2) &
&*phi(na,ig)
enddo
enddo
!
else
!
do is = 1,nequa
dfluxsum = dfxdx(1,is) + dfxdx(2,is) + dfxdx(3,is) + &
dgjdxj(is)
do ir = 1,nequa
xjac_flux(ir) = xjac_flux(ir) + (aj(1,ir,is) + &
bj(1,ir,is))*dfluxsum
yjac_flux(ir) = yjac_flux(ir) + (aj(2,ir,is) + &
bj(2,ir,is))*dfluxsum
zjac_flux(ir) = zjac_flux(ir) + (aj(3,ir,is) + &
bj(3,ir,is))*dfluxsum
enddo
enddo
!
do na = 1,ndbou
ia = lfacnode(na,iface)
do nb = 1,ndbou
ib = lfacnode(nb,iface)
pipj = phi(na,ig)*phi(nb,ig)
pidpjx = phi(na,ig)*dshpdx(1,nb,ig)
pidpjy = phi(na,ig)*dshpdx(2,nb,ig)
pidpjz = phi(na,ig)*dshpdx(3,nb,ig)
do ir = 1,nequa
irow = nequa*(ia-1) + ir
do is = 1,nequa
icol = nequa*(ib-1) + is
!
do na = 1,ndbou
ipoin = iel_nod(na)
do ir = 1,nequa
iordr = nequa*(ipoin-1) + ir
!
term1 = (cflux(1,ir) + G(1,ir))*en(1,ig) + &
(cflux(2,ir) + G(2,ir))*en(2,ig) + &
(cflux(3,ir) + G(3,ir))*en(3,ig)
term2 = xjac_flux(ir)*en(1,ig) + yjac_flux(ir)*&
&en(2,ig) + zjac_flux(ir)*en(3,ig)
!
term1 = (e1(1,ir,is)*en(1,ig) + e1(2,ir,is)* &
en(2,ig) + e1(3,ir,is)*en(3,ig))*pipj
term2 = (e2(1,1,ir,is)*en(1,ig) + e2(2,1,ir,is)*&
en(2,ig) + e2(3,1,ir,is)*en(3,ig))* &
pidpjx +(e2(1,2,ir,is)*en(1,ig) + &
e2(2,2,ir,is)*en(2,ig) + e2(3,2,ir,is)&
*en(3,ig))*pidpjy + (e2(1,3,ir,is)* &
en(1,ig) + e2(2,3,ir,is)*en(2,ig) + &
e2(3,3,ir,is)*en(3,ig))*pidpjz
!
rhs(iordr) = rhs(iordr) + (-dt*term1 + dt2ov2*term2) &
&*phi(na,ig)
enddo
enddo
endif
!
if(ibndcnd<0) cycle ! No boundary conditions applied to
! LHS for inflow
!
!
! Calculate LHS Matrix
!
call matxmult(ndimn,nequa,aj,aj,aa)
if(nvisc/=1) then
!
do i = 1,ndimn
do ir = 1,nequa
do is = 1,nequa
e1(i,ir,is) = dt*s1imp(ir)*aj(i,ir,is)
e2(i,1,ir,is) = -dt2ov2*s2imp(ir)*aa(i,1,ir,is)
e2(i,2,ir,is) = -dt2ov2*s2imp(ir)*aa(i,2,ir,is)
e2(i,3,ir,is) = -dt2ov2*s2imp(ir)*aa(i,3,ir,is)
enddo
enddo
enddo
!
else
!
call matxmult(ndimn,nequa,bj,aj,ba)
call matxmult(ndimn,nequa,aj,bj,ab)
call matxmult(ndimn,nequa,bj,bj,bb)
!
do i = 1,ndimn
do ir = 1,nequa
do is = 1,nequa
e1(i,ir,is) = dt*(s1imp(ir)*aj(i,ir,is) &
Bel(ielno,irow,icol) = Bel(ielno,irow,icol) &
& + term1 + term2
enddo
enddo
enddo
enddo
!
enddo gausloop
enddo faceloop
!
return
end subroutine bouingrl3d
!
!
*******************************************************
*****
! THE FOLLOWING SUBROUTINE CALCULATES
SURFACE INTEGRAL "N SUB
! ALPHA R AT TIME STEP N"
!
SUBROUTINE
BOUINGRL(NFACE,DT,NEQUA,NDIMN,ndbou,neleq,NVISC,IM
PPA)
!
Use param_var
Use thermo_propt
27
if(kequa.eq.nequa) s4imp(kequa) = s4pec(ielem)
enddo
ELSE
do kequa=1,nequa
S1IMP(kequa) = S1
S2IMP(kequa) = S2
S3IMP(kequa) = S3
S4IMP(kequa) = S4
enddo
ENDIF
Use grid_info
Use flow_var
Use Conv_flux
Use var_parm
Use Gaus_quad
Use Shapbou_2d,phi=>phibou
Use FDV_coef
Use bnd_cnd
Use Bface_info
!
!
Implicit None
DO INODE = 1, 2
iel_nod(INODE) = LFACE(inode,IFACE)
enddo
!
integer,intent(in) :: ndbou,nface,nequa,ndimn,neleq,nvisc,imppa
real,intent(in) :: dt
real :: dt2ov2,reinv,re2inv
integer :: ibndcnd,iface,ielem,iequa,jequa,ipp1,ig
integer :: ipoin,inode,iordr,jordr,idimn,jdimn,iboun
integer :: kequa,lnode,lnod1,jpoin
real :: E,T
real :: dy,x1,y1,tan_a
real :: dprdy,u1,v1,t1,p1,P
real :: cos_a,sin_a,en1,en2,tan_n
real :: enum,denom,dprdx
real :: rh1,re1,dx
integer :: ir,is,nal,i
integer,dimension(mnode) :: iel_nod
real :: dfluxsum,term1,term2
real :: vis,hk,vkk,axpbx,aypby
real :: xfluxsum,yfluxsum,ckor2cv,cvisr
integer :: mb,ia,ib,irow,icol
real :: pipj,dpixpj,dpiypj,e1n,termb1,termb2
real :: aaba,abbb
real,dimension(ndimn,nequa,nequa) :: aj,bj
real,dimension(ndimn,ndimn,nequa,nequa) :: cj
!
CALL CALNORM(iel_nod,DPIDX,W,EN)
!
gausloop: DO IG=1,NGAUS
!
CALL
EVALBOU(NDIMN,NEQUA,DPIDX,IG,iel_nod,VELO,
&
&
E,T,Unkn,DUDX,DTDX,DUNDX,CFLUX,DFXDX, &
&
d2tdx2,d2udx2)
!
CALL
AJACOB(velo,E,gamma,gamm1,gm3d2,gm1d2,gamm3,aj)
!
! Appy boundary conditions
!
call aplbncn2d(ndimn,nequa,ndbou,iface,ielem,ibndcnd, &
&
iel_nod,ig,adiabatic,E,T,unkn,velo,dtdx,&
&
dudx,dundx,dfxdx)
!
!
IF(NVISC.NE.1) THEN
real :: DGJDXJ(nequa)
real :: DPIDX(nDIMN,2,NGAUS),EN(2,NGAUS)
REAL :: DUNDX(nDIMN,nEQUA),unkn(nequa),velo(ndimn)
REAL :: CFLUX(NDIMN,NEQUA),DFXDX(NDIMN,NEQUA)
REAL :: G(NDIMN,NEQUA),tau(ndimn,ndimn)
REAL :: DUDX(NDIMN,NDIMN),DTDX(NDIMN)
real :: d2tdx2(ndimn),d2udx2(ndimn,ndimn,ndimn)
REAL :: dfxdy(nequa)
REAL :: e1(ndimn,nequa,nequa), e2(ndimn,ndimn,nequa,nequa)
real :: s1imp(nequa),s2imp(nequa),s3imp(nequa),s4imp(nequa)
!
do ir = 1,nequa
xjac_flux(ir) = 0.0
yjac_flux(ir) = 0.0
enddo
!
do is = 1,nequa
dfluxsum = DFXDX(1,IS)+DFXDX(2,IS)
do ir = 1,nequa
xjac_flux(ir) = xjac_flux(ir) + aj(1,ir,is)*dfluxsum
yjac_flux(ir) = yjac_flux(ir) + aj(2,ir,is)*dfluxsum
enddo
enddo
!
real :: xjac_flux(nequa),yjac_flux(nequa)
real :: aa(ndimn,ndimn,nequa,nequa)
real :: ab(ndimn,ndimn,nequa,nequa)
real :: ba(ndimn,ndimn,nequa,nequa)
real :: bb(ndimn,ndimn,nequa,nequa)
!
DO NAL=1,2
DO IR=1,nequa
!
iordr=nequa*(iel_nod(nal)-1)+ir
logical :: adiabatic
!
!
DT2OV2 = DT*DT/2.
reinv = 1./creyn
re2inv = reinv/creyn
TERM1=PHI(NAL,IG)*(CFLUX(1,IR)*EN(1,IG) + cflux(2,ir)* &
&
en(2,ig))
!
TERM2 = PHI(NAL,IG)*(xjac_flux(ir)*en(1,ig) +
&
&
yjac_flux(ir)*en(2,ig))
!
RHS(iordr) = RHS(iordr) - (DT*TERM1 &
&
DT2OV2*TERM2)
enddo
enddo
!
ELSE
!
!
ifaceloop: DO IFACE = 1, NFACE
!
IELEM=LFACE(7,IFACE)
ibndcnd=LFACE(8,IFACE)
!
IF(IMPPA.GE.1) THEN
do kequa = 1,nequa
S1IMP(kequa) = S1ELE(IELEM)
S2IMP(kequa) = S2ELE(IELEM)
S3IMP(kequa) = S3ELE(IELEM)
if(kequa.eq.nequa) s3imp(kequa) = s3pec(ielem)
S4IMP(kequa) = S4ELE(IELEM)
28
! CALCULATE VISCOUS TERMS ASSOCIATED WITH THE
NAVIER-STOKES
! EQUATIONS
!
! CALCULATE THE VISCOSITY USING SUTHERLAND'S
RELATIONSHIP
!
IF(T<1.E-12) THEN
VIS=1.0
ELSE
VIS = (1.0 +CSUTH)/(T + CSUTH)*T**1.5
ENDIF
!
HK = VIS/GM1M2PR
!
vkk = 0.0
do idimn = 1,ndimn
vkk = vkk + dudx(idimn,idimn)
enddo
!
do idimn = 1,ndimn
do jdimn = 1,ndimn
tau(idimn,jdimn) = vis*(dudx(idimn,jdimn) +
&
&
dudx(jdimn,idimn))
if(idimn.eq.jdimn)
&
&
tau(idimn,jdimn) = tau(idimn,jdimn) - 2.*vis/3.*vkk
enddo
enddo
!
! CALCULATE VISCOUS FLUX
!
CALL
VISCFLX(reinv,TAU,HK,vis,dudx,dtdx,velo,d2tdx2,d2udx2, &
&
G,dgjdxj)
!
! CALCULATE "B" JACOBIAN
CALL
BJACOB(reinv,cv,VIS,HK,TAU,DUNDX,Unkn,velo,E,bj)
!
! CALCULATE "C" JACOBIAN
CALL CJACOB(reinv,cv,VIS,HK,Unkn,cj)
!
do ir = 1,nequa
xjac_flux(ir) = 0.0
yjac_flux(ir) = 0.0
enddo
!
do is = 1,nequa
dfluxsum = DFXDX(1,IS) + DFXDX(2,IS) + dgjdxj(is)
do ir = 1,nequa
axpbx = aj(1,ir,is) + bj(1,ir,is)
aypby = aj(2,ir,is) + bj(2,ir,is)
xjac_flux(ir) = xjac_flux(ir) + axpbx*dfluxsum
yjac_flux(ir) = yjac_flux(ir) + aypby*dfluxsum
enddo
enddo
!
DO NAL=1,2
DO IR=1,nequa
iordr=nequa*(iel_nod(nal)-1)+ir
!
xfluxsum = cflux(1,ir) + g(1,ir)
yfluxsum = cflux(2,ir) + g(2,ir)
!
TERM1 = (xfluxsum*en(1,ig) + yfluxsum*en(2,ig))* &
&
PHI(NAL,ig)
!
TERM2 = phi(nal,ig)*(xjac_flux(ir)*en(1,ig) +
&
&
yjac_flux(ir)*en(2,ig))
!
&
RHS(iordr) = RHS(iordr) - (DT*TERM1 DT2OV2*TERM2)
enddo
enddo
&
!
ENDIF
!
!
!
CALCULATED LHS MATRIX
IF(NVISC.NE.1) THEN
!
call matxmult(ndimn,nequa,aj,aj,aa)
!
do i = 1,ndimn
do ir = 1,nequa
do is = 1,nequa
e1(i,ir,is) = dt*s1imp(ir)*aj(i,ir,is)
e2(i,1,ir,is) = -dt2ov2*s2imp(ir)*aa(i,1,ir,is)
e2(i,2,ir,is) = -dt2ov2*s2imp(ir)*aa(i,2,ir,is)
enddo
enddo
enddo
!
ELSE
if(ibndcnd<0) goto 8000
!
! Apply boundary conditions to Jacobians
!
call jacbnc2d(ndimn,nequa,ibndcnd,adiabatic,hk,vis, &
&unkn,dundx,E,reinv,tau,velo,aj,bj,cj)
!
call matxmult(ndimn,nequa,aj,aj,aa)
call matxmult(ndimn,nequa,aj,bj,ab)
call matxmult(ndimn,nequa,bj,aj,ba)
call matxmult(ndimn,nequa,bj,bj,bb)
!
&
do i = 1,ndimn
do ir = 1,nequa
do is = 1,nequa
e1(i,ir,is) = dt*(s1imp(ir)*aj(i,ir,is)+ &
s3imp(ir)*bj(i,ir,is))
!
&
&
aaba = aa(i,1,ir,is) + ba(i,1,ir,is)
abbb = ab(i,1,ir,is) + bb(i,1,ir,is)
e2(i,1,ir,is) = dt*s3imp(ir)*cj(i,1,ir,is) &
-dt2ov2*(s2imp(ir)*aaba
&
+s4imp(ir)*abbb)
!
&
&
aaba = aa(i,2,ir,is) + ba(i,2,ir,is)
abbb = ab(i,2,ir,is) + bb(i,2,ir,is)
e2(i,2,ir,is) = dt*s3imp(ir)*cj(i,2,ir,is) &
-dt2ov2*(s2imp(ir)*aaba
&
+s4imp(ir)*abbb)
enddo
enddo
enddo
!
DO NAL = 1, 2
DO MB = 1, 2
!
pipj = phi(nal,ig)*phi(mb,ig)
dpixpj = dpidx(1,mb,ig)*phi(nal,ig)
dpiypj = dpidx(2,mb,ig)*phi(nal,ig)
!
DO IR = 1, nequa
DO IS = 1,nequa
!
e1n = e1(1,ir,is)*en(1,ig) + e1(2,ir,is)*en(2,ig)
!
29
T = 0.0
E=0.0
TERMB1 = pipj*e1n
!
&
&
!
TERMB2 = (e2(1,1,ir,is)*en(1,ig) + e2(2,1,ir,is)* &
en(2,ig))*dpixpj + (e2(1,2,ir,is)*en(1,ig) &
+ e2(2,2,ir,is)*en(2,ig))*dpiypj
do idimn = 1, ndimn
velo(idimn) = 0.0
DTDX(IDIMN) = 0.0
d2tdx2(idimn) = 0.0
do jdimn = 1,ndimn
dudx(idimn,jdimn) = 0.0
do kdimn = 1,ndimn
d2udx2(idimn,jdimn,kdimn) = 0.0
enddo
enddo
enddo
DO IEQUA = 1, NEQUA
unkn(iequa) = 0.00
DO JDIMN = 1,NDIMN
DUNDX(JDIMN,IEQUA) = 0.0
DFXDX(JDIMN,IEQUA) = 0.0
CFLUX(JDIMN,IEQUA) = 0.0
ENDDO
ENDDO
!
ia = lface(nal+4,iface)
ib = lface(mb+4,iface)
irow = nequa*(ia-1) + ir
icol = nequa*(ib-1) + is
!
&
BEL(ielem,irow,icol)=BEL(ielem,irow,icol) +
(TERMB1+TERMB2)
enddo
enddo
enddo
enddo
ENDIF
&
!
8000 CONTINUE
!
enddo gausloop
!
!
!
!
!
!
DO I=1,2
L=ILBOU(I)
iordr = nequa*(L-1)
E=E+ENERG(L)*PHIBOU(I,IG)
T = T + TEMPR(L)*PHIBOU(I,IG)
ASSEMBLE ELEMENT MATRIX INTO GLOBAL MATRIX
CALL ebe_vec(2,NEQUA,Delu,Fbar,Diag)
!
do idimn = 1, ndimn
VELO(idimn)=VELO(idimn)+VEL(idimn,L)*PHIBOU(I,IG)
DTDX(IDIMN) = DTDX(IDIMN) +
DPIDX(IDIMN,I,IG)*TEMPR(L)
DO JDIMN = 1,NDIMN
enddo ifaceloop
!
RETURN
end subroutine bouingrl
!
!
*******************************************************
*******
! THE FOLLOWING SUBROUTINE CALCULATES THE "U"
VECTOR AND
! JACOBIANS AT THE GAUSSIAN POINT OF INTEREST
FOR THE
! BOUNDARY TERMS
!
SUBROUTINE
EVALBOU(NDIMN,NEQUA,DPIDX,IG,ilbou,VELO,
&
&
E,T,unkn,DUDX,DTDX,DUNDX,CFLUX,DFXDX, &
d2tdx2,d2udx2)
!
Use param_var
Use flow_var
Use thermo_propt
Use conv_flux
Use shapbou_2d
!
implicit none
!
integer,intent(in) :: ndimn,nequa,ig
integer,intent(in) :: ILBOU(MNODE)
real,intent(out) :: e,T
real,intent(in) :: DPIDX(MDIMN,2,NGAUS)
REAL,intent(out) ::
CFLUX(MDIMN,MEQUA),DFXDX(MDIMN,MEQUA)
real,intent(out) ::
DUNDX(MDIMN,MEQUA),unkn(mequa),velo(mdimn)
REAL,intent(out) ::
DUDX(MDIMN,MDIMN),DTDX(MDIMN)
real,intent(out) :: d2tdx2(mdimn),d2udx2(mdimn,mdimn,mdimn)
integer :: idimn,jdimn,kdimn,iequa,i,L,iordr,ipoin
!
DUDX(IDIMN,JDIMN)=DUDX(IDIMN,JDIMN)+DPIDX(JDIMN,
I,IG)* &
&
VEL(IDIMN,L)
enddo
enddo
!
DO IEQUA = 1, NEQUA
Unkn(iequa)=Unkn(iequa)+U(iordr+iequa)*PHIBOU(I,IG)
DO JDIMN = 1,NDIMN
DUNDX(JDIMN,IEQUA) = DUNDX(JDIMN,IEQUA) +
DPIDX(JDIMN,I,IG)* &
&
U(iordr+IEQUA)
ENDDO
ENDDO
enddo
!
DO IEQUA = 1, NEQUA
DO I = 1, 2
IPOIN = ILBOU(I)
DO JDIMN = 1,NDIMN
DFXDX(JDIMN,IEQUA) = DFXDX(JDIMN,IEQUA)
+ DPIDX(JDIMN,I,IG)* &
&
F(IPOIN,JDIMN,IEQUA)
CFLUX(JDIMN,IEQUA) =
CFLUX(JDIMN,IEQUA)+PHIBOU(I,IG)*
&
&
F(IPOIN,JDIMN,IEQUA)
ENDDO
enddo
enddo
!
RETURN
end subroutine evalbou
!
30
dfxdx(2,iequa)=0.0
enddo
do inode=1,2
ipoin=iel_nod(inode)
if(inode.eq.1) then
ipp1=lnod(4,ielno)
if(lface(5,iface).eq.3) ipp1 = lnod(2,ielno)
elseif(inode.eq.2) then
ipp1=lnod(3,ielno)
if(lface(6,iface).eq.4) ipp1 = lnod(1,ielno)
endif
dy=x(2,ipp1)-x(2,ipoin)
dudx(1,2)=dudx(1,2)+phi(inode,IG)*vel(1,ipp1)/dy
dudx(2,2)=dudx(2,2)+phi(inode,IG)*vel(2,ipp1)/dy
! --- for constant wall temperature.
if(indbd(ipoin).ne.2) then
adiabatic=.false.
dtdx(2)=dtdx(2)+phi(inode,IG)*(tempr(ipp1)-tempr(ipoin))/dy
do iequa=1,nequa
dundx(2,iequa)=dundx(2,iequa) &
& +phi(inode,IG)*(u(NEQUA*(ipp1-1)+iequa)&
& u(NEQUA*(ipoin-1)+iequa))/dy
dfxdx(2,iequa)=dfxdx(2,iequa)+phi(inode,IG) &
&
*(f(ipp1,2,iequa)-f(ipoin,2,iequa))/dy
enddo
! --- for adiabatic wall boundary condition.
else
adiabatic=.true.
P = cgas*unkn(1)*T
dtdx(2)=0.0
dundx(2,1) = 0.0
dundx(2,2)=dundx(2,2) + phi(inode,ig)*
&
&
unkn(1)*vel(1,ipp1)/dy
dundx(2,3) = dundx(2,3) + phi(inode,ig)*unkn(1)* &
&
vel(2,ipp1)/dy
dundx(2,4)= 0.0
!
dfxdx(2,1)=dfxdx(2,1)+phi(inode,IG)*unkn(1)*
&
&
vel(2,ipp1)/dy
dfxdx(2,2) = 0.0
dfxdx(2,3) = 0.0
dfxdx(2,4)=dfxdx(2,4)+phi(inode,IG)
&
&
*(unkn(4) + P)*vel(2,ipp1)/dy
endif
enddo
!
Case(4) ! No-slip compression corner
dudx(1,2)=0.0
dudx(2,2)=0.0
dtdx(2)=0.0
dprdy = 0.0
x1 = 0.0
y1 = 0.0
tan_a = 0.0
tan_a = -1./tan(alpa)
do iequa=1,nequa
dundx(2,iequa)=0.0
dfxdx(2,iequa)=0.0
enddo
do inode=1,2
ipoin=iel_nod(inode)
iboun = lface(inode+2,iface)
if(inode.eq.1) then
ipp1=lnod(4,ielno)
if(lface(5,iface).eq.3) ipp1 = lnod(2,ielno)
elseif(inode.eq.2) then
ipp1=lnod(3,ielno)
if(lface(6,iface).eq.4) ipp1 = lnod(1,ielno)
endif
x1 = x1 + phi(inode,ig)*x(1,ipoin)
!
*******************************************************
*************
! Subroutine to apply boundary conditions to FDV surface
integrals
!
Subroutine aplbncn2d(ndimn,nequa,ndbou,iface,ielno,ibndcnd,
&
&
iel_nod,ig,adiabatic,E,T,unkn,velo,dtdx,&
&
dudx,dundx,dfxdx)
!
!DIR$ INLINEALWAYS aplbncn2d
!
Use Conv_Flux
Use bface_info
Use Bnd_cnd
Use flow_var
Use grid_info
Use shapbou_3d
Use thermo_propt
!
Implicit None
!
integer,intent(in) :: ndbou,ndimn,nequa,iface,ielno,ibndcnd,ig
integer,intent(in),dimension(ndbou) :: iel_nod
logical,intent(out) :: adiabatic
real,intent(in) :: E,T,unkn(nequa)
real,intent(inout),dimension(ndimn) :: dtdx,velo
real,intent(inout),dimension(ndimn,ndimn) :: dudx
real,intent(inout),dimension(ndimn,nequa) :: dundx,dfxdx
!
integer :: iboun,idimn,iequa,inode,ipoin,lnode,lnod1
integer :: iordr,ipp1,jordr
!
real :: dx,dy
real,dimension(nequa) :: dfxdy
real :: P,dprdx,dprdy,tan_a
real :: p1,t1,u1,v1
real :: x1,y1
!
Select Case(ibndcnd)
Case(2,12) ! Symmetry Condition, v=tau12=q2=0
dudx(1,2)=0.0
dudx(2,2)=0.0
dtdx(2)=0.0
do iequa=1,nequa
dundx(2,iequa)=0.0
dfxdx(2,iequa)=0.0
enddo
if(indbc(iel_nod(2)).eq.1.or.indbc(iel_nod(2)).eq.4) then
ipoin=iel_nod(2)
ipp1=lnod(3,ielno)
dy=x(2,ipp1)-x(2,ipoin)
dudx(1,2)=phi(2,IG)*(vel(1,ipp1)-vel(1,ipoin))/dy
dudx(2,2)=phi(2,IG)*(vel(2,ipp1)-vel(2,ipoin))/dy
dtdx(2)=phi(2,IG)*(tempr(ipp1)-tempr(ipoin))/dy
do iequa=1,nequa
dundx(2,iequa)=phi(2,IG)*(u(NEQUA*(ipp1-1)+iequa) &
&
-u(NEQUA*(ipoin-1)+iequa))/dy
dfxdx(2,iequa)=phi(2,IG)*(f(ipp1,2,iequa)
&
&
-f(ipoin,2,iequa))/dy
enddo
endif
!
Case(1) ! No-slip wall, u=v=0, T=Twall or dTdn=0
dudx(1,2)=0.0
dudx(2,2)=0.0
dtdx(2)=0.0
do iequa=1,nequa
dundx(2,iequa)=0.0
31
!
do iequa = 1,nequa
dundx(2,iequa) = 0.0
dfxdx(2,iequa) = 0.0
enddo
y1 = y1 + phi(inode,ig)*x(2,ipoin)
tan_a = tan_a + phi(inode,ig)*rbcon(2,iboun)/(-rbcon(1,iboun))
dy=x(2,ipp1)-x(2,ipoin)
dudx(1,2)=dudx(1,2)+phi(inode,IG)*vel(1,ipp1)/dy
dudx(2,2)=dudx(2,2)+phi(inode,IG)*vel(2,ipp1)/dy
dprdy = dprdy + phi(inode,ig)*(press(ipp1)-press(ipoin))/dy
dtdx(2)=dtdx(2)+phi(inode,IG)*(tempr(ipp1)-tempr(ipoin))/dy
!
do inode = 1,2
ipoin = iel_nod(inode)
if(inode.eq.1) ipp1 = lnod(2,ielno)
if(inode.eq.2) ipp1 = lnod(1,ielno)
dy = x(2,ipp1) - x(2,ipoin)
do idimn = 1,ndimn
!
do iequa=1,nequa
dundx(2,iequa)=dundx(2,iequa)
&
& +phi(inode,IG)*(u(NEQUA*(ipp1-1)+iequa)- &
& u(NEQUA*(ipoin-1)+iequa))/dy
dfxdx(2,iequa)=dfxdx(2,iequa)+phi(inode,IG)
&
&
*(f(ipp1,2,iequa)-f(ipoin,2,iequa))/dy
enddo
dudx(idimn,2) = dudx(idimn,2) + phi(inode,ig)* &
(vel(idimn,ipp1) - vel(idimn,ipoin))/dy
enddo
dtdx(2) = dtdx(2) + phi(inode,ig)*(tempr(ipp1) - &
tempr(ipoin))/dy
!
enddo
!
!
do iequa = 1,nequa
iordr = nequa*(ipoin-1) + iequa
jordr = nequa*(ipp1-1) + iequa
dundx(2,iequa) = dundx(2,iequa) + phi(inode,ig)* &
(U(jordr) - U(iordr))/dy
dfxdx(2,iequa) = dfxdx(2,iequa) + phi(inode,ig)* &
(f(ipp1,2,iequa) - f(ipoin,2,iequa))/dy
enddo
ipoin = iel_nod(1)
ipp1 = lnod(4,ielno)
dx = x1 - x(1,ipoin)
u1 = vel(1,ipoin) + (y1-x(2,ipoin))*(vel(1,ipp1)-vel(1,ipoin))/ &
& (x(2,ipp1)-x(2,ipoin))
v1 = vel(2,ipoin) + (y1-x(2,ipoin))*(vel(2,ipp1)-vel(2,ipoin))/ &
& (x(2,ipp1)-x(2,ipoin))
t1 = tempr(ipoin) + (y1-x(2,ipoin))*(tempr(ipp1)-tempr(ipoin))/
!
&
enddo
& (x(2,ipp1)-x(2,ipoin))
p1 = press(ipoin) + (y1-x(2,ipoin))*(press(ipp1)-press(ipoin))/
!
!
&
Case(11,21) ! Side wall of driven cavity
dudx(1,1)=0.0
dudx(2,1)=0.0
dtdx(1)=0.0
do iequa=1,nequa
dundx(1,iequa)=0.0
dfxdx(1,iequa)=0.0
enddo
do inode=1,2
ipoin=iel_nod(inode)
lnode=lface(inode+4,iface)
lnod1=lnode+1
if(ibndcnd.eq.11) then
if(lnode.eq.4) lnod1 = 3
elseif(ibndcnd.eq.21) then
if(lnode.eq.2) lnod1 = 1
endif
ipp1 = lnod(lnod1,ielno)
dx=x(1,ipp1)-x(1,ipoin)
dudx(1,1)=dudx(1,1)+phi(inode,ig)*vel(1,ipp1)/dx
dudx(2,1)=dudx(2,1)+phi(inode,ig)*vel(2,ipp1)/dx
! --- for constant wall temperature.
if(indbd(ipoin).ne.2) then
adiabatic=.false.
dtdx(1)=dtdx(1)+phi(inode,ig)*(tempr(ipp1)-tempr(ipoin))/dx
do iequa=1,nequa
dundx(1,iequa)=dundx(1,iequa)
&
& +phi(inode,ig)*(u(nequa*(ipp1-1)+iequa)- &
& u(nequa*(ipoin-1)+iequa))/dx
dfxdx(1,iequa)=dfxdx(1,iequa)+phi(inode,ig) &
&
*(f(ipp1,1,iequa)-f(ipoin,1,iequa))/dx
enddo
! --- for adiabatic wall boundary condition.
else
adiabatic=.true.
P = cgas*unkn(1)*T
dtdx(1)=0.0
dundx(1,1) = 0.0
dundx(1,2)=dundx(1,2) + phi(inode,ig)*unkn(1)* &
&
(vel(1,ipp1) - vel(1,ipoin))/dx
& (x(2,ipp1)-x(2,ipoin))
P = unkn(1)*cgas*T
dudx(1,1) = (velo(1)-u1)/dx
dudx(2,1) = (velo(2)-v1)/dx
dtdx(1) = (T - t1)/dx
dprdx = (P - p1)/dx
!
! --- for constant wall temperature.
if(indbd(ipoin).ne.2) then
adiabatic=.false.
dundx(1,2) = unkn(1)*dudx(1,1)
dundx(1,3) = unkn(1)*dudx(2,1)
dundx(1,4) = E*dundx(1,1) + unkn(1)*cv*dtdx(1)
else
!
! --- for adiabatic wall boundary condition.
!
adiabatic=.true.
dundx(1,1) = -dundx(2,1)*tan_a
dundx(1,2) = unkn(1)*dudx(1,1)
dundx(1,3) = unkn(1)*dudx(2,1)
dundx(1,4) = E*dundx(1,1) + unkn(1)*cv*dtdx(1)
dtdx(1) = -dtdx(2)*tan_a
dprdx = -dprdy*tan_a
endif
!
dfxdx(1,1) = dundx(1,2)
dfxdx(1,2) = dprdx
dfxdx(1,3) = 0.0
dfxdx(1,4) = (unkn(4)+P)*dudx(1,1)
!
Case(-12) ! Top surface of driven cavity
! Dirichlet on Flow Variables
! Flow Gradients Non-Zero
dudx(1,2) = 0.0
dudx(2,2) = 0.0
dtdx(2) = 0.0
velo(2) = 0.0
!
32
!
!
*******************************************************
*************
! Subroutine to apply boundary conditions to FDV surface
integrals
!
Subroutine aplbndcnd(ndimn,nequa,ndbou,iface,ielno,ibndcnd,
&
&
iel_nod,ig,adiabatic,E,T,unkn,velo,dtdx,&
&
d2tdx2,dudx,d2udx2,dundx,dfxdx,enorm)
!
!DIR$ INLINEALWAYS aplbndcnd
!
Use Conv_Flux
Use bface_info
Use Bnd_cnd
Use flow_var
Use grid_info
Use shapbou_3d
Use thermo_propt
!
Implicit None
!
integer,intent(in) :: ndimn,nequa,ndbou,iface,ielno,ibndcnd,ig
integer,intent(in),dimension(ndbou) :: iel_nod
logical,intent(out) :: adiabatic
real,intent(in),dimension(ndimn) :: enorm,velo
real,intent(in) :: E,T,unkn(nequa)
real,intent(inout),dimension(ndimn) :: dtdx,d2tdx2
real,intent(inout),dimension(ndimn,ndimn) :: dudx
real,intent(inout),dimension(ndimn,ndimn,ndimn) :: d2udx2
real,intent(inout),dimension(ndimn,nequa) :: dundx,dfxdx
!
integer :: idimn,iequa,inode,inod1,ipoin,lnode,lnod1
integer :: iordr,jordr,ipoin1,ipoin2,ipoin3,ipoin4
integer :: ipp1,ipp2,ipp3,ipp4,iordr1,iordr2,iordr3,iordr4
integer :: jnode,jordr1,jordr2,jordr3,jordr4,jpoin,jpp1
!
real :: beta,dx,dx1,dx2,dx3,dx4,dy,dz,dz1,dz2,delx,dely
real :: dx1a,dx1b,dx2a,dx2b,drdy,r1,rho1a,rho1b
real :: dprdx,dprdy,dprdz,angl_b,tan_a,tan_b,pi
real :: P,p1a,p1b,p1,t1a,t1b,t1,u1a,u1b,u1,v1a,v1b,v1
real :: w1a,w1b,w1,x1,y1,z1
real,dimension(nequa) :: dfydx,dfydz
!
Select Case(ibndcnd)
Case(2,12) ! Symmetry in x-y plane, w=tau13=tau23=q3=0
dudx(1,3) = 0.0
dudx(2,3) = 0.0
dudx(3,3) = 0.0
dtdx(3) = 0.0
d2tdx2(3) = 0.0
do idimn = 1,ndimn
d2udx2(1,idimn,3) = 0.0
d2udx2(2,idimn,3) = 0.0
d2udx2(3,idimn,3) = 0.0
d2udx2(1,3,idimn) = 0.0
d2udx2(2,3,idimn) = 0.0
d2udx2(3,3,idimn) = 0.0
enddo
!
do iequa = 1,nequa
dundx(3,iequa) = 0.0
dfxdx(3,iequa) = 0.0
enddo
!
do inode = 1,ndbou
ipoin = iel_nod(inode)
lnode = lfacnode(inode,iface)
dundx(1,3) = dundx(1,3) + phi(inode,ig)*unkn(1)* &
&
(vel(2,ipp1) - vel(2,ipoin))/dx
dundx(1,4) = 0.0
!
dfxdx(1,1)=dfxdx(1,1)+phi(inode,ig)*unkn(1)
&
*(vel(1,ipp1) - vel(1,ipoin))/dx
dfxdx(1,2)= 0.0
dfxdx(1,3)= 0.0
dfxdx(1,4)=dfxdx(1,4)+phi(inode,ig)
& *(unkn(4) + P)*vel(1,ipp1)/dx
endif
enddo
&
&
!
Case(-1,6) ! Inlet or Exit, normal derivatives = 0
dudx(1,1)=0.0
dudx(2,1)=0.0
dtdx(1)=0.0
do iequa=1,nequa
dundx(1,iequa)=0.0
dfxdx(1,iequa)=0.0
enddo
!
Case(7) ! Top surface, normal derivatives = 0
dudx(1,2)=0.0
dudx(2,2)=0.0
dtdx(2)=0.0
do iequa=1,nequa
dundx(2,iequa)=0.0
dfxdx(2,iequa)=0.0
enddo
!
!
Case(8) ! Exit for compression corner, Derivatives normal
! to flow direction = 0
dudx(1,1)=0.0
dudx(2,1)=0.0
dtdx(1)=0.0
tan_a=tan(alpa)
tan_a = velo(2)/velo(1)
do iequa=1,nequa
dundx(1,iequa)=0.0
dfxdx(1,iequa)=0.0
dfxdy(iequa)=0.0
enddo
!
do inode = 1, 2
ipoin = iel_nod(inode)
if(inode.eq.1) lnode=1
if(inode.eq.2) lnode=4
ipp1=lnod(lnode,ielno)
!
tan_a=tan_a + phi(inode,ig)*
! &
(x(2,ipp1)-x(2,ipoin))/(x(1,ipp1)-x(1,ipoin))
do iequa=1,nequa
dfxdy(iequa)=dfxdy(iequa)+dshpdx(2,inode,ig)*
&
f(ipoin,1,iequa)
enddo
enddo
!
dudx(1,1)=-dudx(1,2)*tan_a
dudx(2,1)=-dudx(2,2)*tan_a
dtdx(1)=-dtdx(2)*tan_a
!
do iequa=1,nequa
dundx(1,iequa)=-dundx(2,iequa)*tan_a
dfxdx(1,iequa)=-dfxdy(iequa)*tan_a
enddo
!
End Select
!
return
end subroutine aplbncn2d
&
33
ipp2 = lnod(3,ielno)
ipp3 = lnod(7,ielno)
ipp4 = lnod(6,ielno)
elseif(lnode==2) then
ipp1 = lnod(1,ielno)
ipp2 = lnod(4,ielno)
ipp3 = lnod(8,ielno)
ipp4 = lnod(5,ielno)
endif
inod1 = lnode + ndbou
if(ibndcnd==12) inod1 = lnode - ndbou
ipp1 = lnod(inod1,ielno)
dz = x(3,ipp1) - x(3,ipoin)
dudx(3,3) = dudx(3,3) + phi(inode,ig)*vel(3,ipp1)/dz
enddo
!
p = unkn(1)*cgas*T
dfxdx(3,5) = (unkn(5) + P)*dudx(3,3)
!
!
dx1 = x(1,ipp1) - x(1,ipoin1)
dx2 = x(1,ipp2) - x(1,ipoin2)
dx3 = x(1,ipp3) - x(1,ipoin3)
dx4 = x(1,ipp4) - x(1,ipoin4)
dudx(1,1) = phi(1,ig)*vel(1,ipp1)/dx1 +
phi(2,ig)*vel(1,ipp2)/dx2 &
&+ phi(3,ig)*vel(1,ipp3)/dx3 +
phi(4,ig)*vel(1,ipp4)/dx4
!
p = unkn(1)*cgas*T
dfxdx(1,5) = (unkn(5) + P)*dudx(1,1)
!
if(indbc(iel_nod(3))==14) then ! Interface with no-slip wall
if(indbd(iel_nod(3))/=2)
&
dtdx(1) = phi(2,ig)*(tempr(ipp2) - tempr(ipoin2))/dx2 &
+ phi(3,ig)*(tempr(ipp3) - tempr(ipoin3))/dx3
do idimn = 2,3
dudx(idimn,1) = phi(2,ig)*(vel(idimn,ipp2)&
&vel(idimn,ipoin2))/dx2+ phi(3,ig)*&
(vel(idimn,ipp3) - vel(idimn,ipoin3))/dx3
enddo
!
do iequa = 1,nequa
iordr2 = nequa*(ipoin2-1) + iequa
jordr2 = nequa*(ipp2-1) + iequa
iordr3 = nequa*(ipoin3-1) + iequa
jordr3 = nequa*(ipp3-1) + iequa
dundx(1,iequa) = phi(2,ig)*(u(jordr2) - u(iordr2))/dx2 &
+ phi(3,ig)*(u(jordr3) - u(iordr3))/dx3
dfxdx(1,iequa) = phi(2,ig)*(F(ipp2,1,iequa)
&
&- F(ipoin2,1,iequa))/dx2 + phi(3,ig)* &
&(F(ipp3,1,iequa) - F(ipoin3,1,iequa))/dx3
enddo
endif
!
Case(1) ! No slip wall, u=v=w=0
dudx(1,3) = 0.0
dudx(2,3) = 0.0
dudx(3,3) = 0.0
dtdx(3) = 0.0
d2tdx2(3) = 0.0
do idimn = 1,ndimn
d2udx2(1,idimn,3) = 0.0
d2udx2(2,idimn,3) = 0.0
d2udx2(3,idimn,3) = 0.0
d2udx2(1,3,idimn) = 0.0
d2udx2(2,3,idimn) = 0.0
d2udx2(3,3,idimn) = 0.0
enddo
!
do iequa = 1,nequa
dundx(3,iequa) = 0.0
dfxdx(3,iequa) = 0.0
enddo
!
p = unkn(1)*cgas*T
!
do inode = 1,ndbou
ipoin = iel_nod(inode)
lnode = lfacnode(inode,iface)
if(indbc(iel_nod(3))==1) then ! Interface with no-slip wall
do inode = 3,4
ipoin = iel_nod(inode)
lnode = lfacnode(inode,iface)
inod1 = lnode + ndbou
if(ibndcnd==12) inod1 = lnode - ndbou
ipp1 = lnod(inod1,ielno)
dz = x(3,ipp1) - x(3,ipoin)
if(indbd(iel_nod(3))/=2)
&
dtdx(3) = dtdx(3) + phi(inode,ig)*(tempr(ipp1) - &
tempr(ipoin))/dz
do idimn = 1,2
dudx(idimn,3) = dudx(idimn,3) + phi(inode,ig)* &
(vel(idimn,ipp1) - vel(idimn,ipoin))&
&/dz
enddo
!
dfxdx(3,1:nequa) = 0.0
!
do iequa = 1,nequa
iordr = nequa*(ipoin-1) + iequa
jordr = nequa*(ipp1-1) + iequa
dundx(3,iequa) = dundx(3,iequa) + phi(inode,ig)* &
(u(jordr) - u(iordr))/dz
dfxdx(3,iequa) = dfxdx(3,iequa) + phi(inode,ig)* &
(F(ipp1,3,iequa) - F(ipoin,3,iequa))&
&/dz
enddo
enddo
endif
!
Case(22) ! Symmetry in y-z plane, u=tau12=tau13=q1=0
dudx(1,1) = 0.0
dudx(2,1) = 0.0
dudx(3,1) = 0.0
dtdx(1) = 0.0
d2tdx2(1) = 0.0
do idimn = 1,ndimn
d2udx2(1,idimn,1) = 0.0
d2udx2(2,idimn,1) = 0.0
d2udx2(3,idimn,1) = 0.0
d2udx2(1,1,idimn) = 0.0
d2udx2(2,1,idimn) = 0.0
d2udx2(3,1,idimn) = 0.0
enddo
!
do iequa = 1,nequa
dundx(1,iequa) = 0.0
dfxdx(1,iequa) = 0.0
enddo
!
lnode = lfacnode(1,iface)
!
ipoin1 = iel_nod(1)
ipoin2 = iel_nod(2)
ipoin3 = iel_nod(3)
ipoin4 = iel_nod(4)
!
if(lnode==1) then
ipp1 = lnod(2,ielno)
34
dudx(3,3) = dudx(3,3) + phi(inode,ig)*vel(3,ipp1)/dz
dprdz = dprdz + phi(inode,ig)*(press(ipp1)-press(ipoin))/dz
dtdx(3)=dtdx(3)+phi(inode,IG)*(tempr(ipp1)-tempr(ipoin))/dz
dprdx = dprdx + dshpdx(1,inode,ig)*press(ipoin)
dprdy = dprdy + dshpdx(2,inode,ig)*press(ipoin)
inod1 = lnode + ndbou
ipp1 = lnod(inod1,ielno)
dz = x(3,ipp1) - x(3,ipoin)
do idimn = 1,ndimn
dudx(idimn,3) = dudx(idimn,3) + phi(inode,ig)* &
&vel(idimn,ipp1)/dz
enddo
! For constant wall temperature
if(indbd(ipoin)/=2) then
adiabatic = .false.
dtdx(3) = dtdx(3) + phi(inode,ig)*(tempr(ipp1) - &
&tempr(ipoin))/dz
do iequa = 1,nequa
iordr = nequa*(ipoin-1) + iequa
jordr = nequa*(ipp1-1) + iequa
dundx(3,iequa) = dundx(3,iequa) + phi(inode,ig)* &
&(u(jordr) - u(iordr))/dz
dfxdx(3,iequa) = dfxdx(3,iequa) + phi(inode,ig)* &
&(f(ipp1,3,iequa) - f(ipoin,3,iequa))/dz
enddo
! for adiabatic wall condition
else
adiabatic = .true.
dtdx(3) = 0.0
dundx(3,1) = 0.0
dundx(3,2) = dundx(3,2) + phi(inode,ig)*unkn(1)* &
&vel(1,ipp1)/dz
dundx(3,3) = dundx(3,3) + phi(inode,ig)*unkn(1)* &
&vel(2,ipp1)/dz
dundx(3,4) = dundx(3,4) + phi(inode,ig)*unkn(1)* &
!
do iequa=1,nequa
dundx(3,iequa)=dundx(3,iequa)
&
& +phi(inode,IG)*(u(NEQUA*(ipp1-1)+iequa)& u(NEQUA*(ipoin-1)+iequa))/dz
dfxdx(3,iequa)=dfxdx(3,iequa)+phi(inode,IG)
&
*(f(ipp1,3,iequa)-f(ipoin,3,iequa))/dz
enddo
&
&
!
enddo
!
ipoin = iel_nod(1)
ipp1 = lnod(5,ielno)
if(ipoin==ipp1) ipp1 = lnod(1,ielno)
jpoin = iel_nod(2)
jpp1 = lnod(6,ielno)
if(jpoin==jpp1) jpp1 = lnod(2,ielno)
dy = y1 - x(2,ipoin)
dx = abs(x(1,jpoin) - x(1,ipoin))
dx1 = abs(x1 - x(1,ipoin))
dx2 = abs(x1 - x(1,jpoin))
u1a = vel(1,ipoin) + (z1-x(3,ipoin))*(vel(1,ipp1)-vel(1,ipoin))/ &
& (x(3,ipp1)-x(3,ipoin))
u1b = vel(1,jpoin) + (z1-x(3,jpoin))*(vel(1,jpp1)-vel(1,jpoin))/ &
& (x(3,jpp1)-x(3,jpoin))
v1a = vel(2,ipoin) + (z1-x(3,ipoin))*(vel(2,ipp1)-vel(2,ipoin))/ &
& (x(3,ipp1)-x(3,ipoin))
v1b = vel(2,jpoin) + (z1-x(3,jpoin))*(vel(2,jpp1)-vel(2,jpoin))/ &
& (x(3,jpp1)-x(3,jpoin))
w1a = vel(3,ipoin) + (z1-x(3,ipoin))*(vel(3,ipp1)-vel(3,ipoin))/
&vel(3,ipp1)/dz
dundx(3,5) = 0.0
dfxdx(3,1) = dfxdx(3,1) + phi(inode,ig)*unkn(1)* &
&vel(3,ipp1)/dz
dfxdx(3,2) = 0.0
dfxdx(3,3) = 0.0
dfxdx(3,4) = 0.0
dfxdx(3,5) = dfxdx(3,5) + phi(inode,ig)*(unkn(5) + &
&P)*vel(3,ipp1)/dz
endif
enddo
&
& (x(3,ipp1)-x(3,ipoin))
w1b = vel(3,jpoin) + (z1-x(3,jpoin))*(vel(3,jpp1)-vel(3,jpoin))/
&
& (x(3,jpp1)-x(3,jpoin))
t1a = tempr(ipoin) + (z1-x(3,ipoin))*(tempr(ipp1)-tempr(ipoin))/
&
& (x(3,ipp1)-x(3,ipoin))
t1b = tempr(jpoin) + (z1-x(3,jpoin))*(tempr(jpp1)-tempr(jpoin))/
!
Case(4) ! Compression Corner in x-y plane
dudx(1,3)=0.0
dudx(2,3)=0.0
dudx(3,3) = 0.0
dtdx(3)=0.0
dprdz = 0.0
dprdx = 0.0
dprdy = 0.0
x1 = 0.0
y1 = 0.0
z1 = 0.0
tan_a = -1./tan(alpa)
do iequa=1,nequa
dundx(3,iequa)=0.0
dfxdx(3,iequa)=0.0
enddo
do inode=1,ndbou
ipoin=iel_nod(inode)
lnode = lfacnode(inode,iface)
jnode = lnode + ndbou
ipp1 = lnod(jnode,ielno)
x1 = x1 + phi(inode,ig)*x(1,ipoin)
y1 = y1 + phi(inode,ig)*x(2,ipoin)
z1 = z1 + phi(inode,ig)*x(3,ipoin)
dz=x(3,ipp1)-x(3,ipoin)
dudx(1,3)=dudx(1,3)+phi(inode,IG)*vel(1,ipp1)/dz
dudx(2,3)=dudx(2,3)+phi(inode,IG)*vel(2,ipp1)/dz
&
& (x(3,jpp1)-x(3,jpoin))
p1a = press(ipoin) + (z1-x(3,ipoin))*(press(ipp1)-press(ipoin))/
&
& (x(3,ipp1)-x(3,ipoin))
p1b = press(jpoin) + (z1-x(3,jpoin))*(press(jpp1)-press(jpoin))/
&
& (x(3,jpp1)-x(3,jpoin))
u1 = (u1a*dx1 + u1b*dx2)/dx
v1 = (v1a*dx1 + v1b*dx2)/dx
w1 = (w1a*dx1 + w1b*dx2)/dx
p1 = (p1a*dx1 + p1b*dx2)/dx
t1 = (t1a*dx1 + t1b*dx2)/dx
P = unkn(1)*cgas*T
dudx(1,2) = (velo(1)-u1)/dy
dudx(2,2) = (velo(2)-v1)/dy
dudx(3,2) = (velo(3)-w1)/dy
dtdx(2) = (T - t1)/dy
dprdy = (P - p1)/dy
!
! --- for constant wall temperature.
if(indbd(ipoin).ne.2) then
adiabatic=.false.
dundx(2,2) = unkn(1)*dudx(1,2)
dundx(2,3) = unkn(1)*dudx(2,2)
dundx(2,4) = unkn(1)*dudx(3,2)
35
enddo
dundx(2,5) = E*dundx(2,1) + unkn(1)*cv*dtdx(2)
else
!
ipoin = iel_nod(1)
ipp1 = lnod(2,ielno)
if(ipoin==ipp1) ipp1 = lnod(1,ielno)
jpoin = iel_nod(4)
jpp1 = lnod(6,ielno)
if(jpoin==jpp1) jpp1 = lnod(5,ielno)
dy = y1 - x(2,ipoin)
dz = abs(x(3,jpoin) - x(3,ipoin))
dz1 = abs(z1 - x(3,ipoin))
dz2 = abs(z1 - x(3,jpoin))
u1a = vel(1,ipoin) + (x1-x(1,ipoin))*(vel(1,ipp1)-vel(1,ipoin))/ &
& (x(1,ipp1)-x(1,ipoin))
u1b = vel(1,jpoin) + (x1-x(1,jpoin))*(vel(1,jpp1)-vel(1,jpoin))/ &
& (x(1,jpp1)-x(1,jpoin))
v1a = vel(2,ipoin) + (x1-x(1,ipoin))*(vel(2,ipp1)-vel(2,ipoin))/ &
& (x(1,ipp1)-x(1,ipoin))
!
! --- for adiabatic wall boundary condition.
!
adiabatic=.true.
dundx(2,1) = -dundx(3,1)*tan_a
dundx(2,2) = unkn(1)*dudx(1,2)
dundx(2,3) = unkn(1)*dudx(2,2)
dundx(2,4) = unkn(1)*dudx(3,2)
dtdx(2) = - dtdx(3)*tan_a
dundx(2,5) = E*dundx(2,1) + unkn(1)*cv*dtdx(2)
dprdy = -dprdz*tan_a
endif
!
dfxdx(2,1) = dundx(2,3)
dfxdx(2,2) = 0.0
dfxdx(2,3) = dprdy
dfxdx(2,4) = 0.0
dfxdx(2,5) = (unkn(5)+P)*dudx(2,2)
!
Case(14) ! Compression Corner in y-z plane
dudx(1,1)=0.0
dudx(2,1)=0.0
dudx(3,1) = 0.0
dtdx(1)=0.0
dprdx = 0.0
dprdz = 0.0
x1 = 0.0
y1 = 0.0
z1 = 0.0
ipoin = iel_nod(1)
jpoin = iel_nod(2)
delx = x(1,jpoin) - x(1,ipoin)
dely = x(2,jpoin) - x(2,ipoin)
pi = acos(-1.)
beta = 15.*pi/180.
tan_a = -1./tan(beta)
do iequa=1,nequa
dundx(1,iequa)=0.0
dfxdx(1,iequa)=0.0
enddo
do inode=1,ndbou
ipoin=iel_nod(inode)
lnode = lfacnode(inode,iface)
if(inode==2.or.inode==3) then
jnode = lnode - 1
else
jnode = lnode + 1
endif
ipp1 = lnod(jnode,ielno)
x1 = x1 + phi(inode,ig)*x(1,ipoin)
y1 = y1 + phi(inode,ig)*x(2,ipoin)
z1 = z1 + phi(inode,ig)*x(3,ipoin)
dx=x(1,ipp1)-x(1,ipoin)
dudx(1,1)=dudx(1,1)+phi(inode,IG)*vel(1,ipp1)/dx
dudx(2,1)=dudx(2,1)+phi(inode,IG)*vel(2,ipp1)/dx
dudx(3,1) = dudx(3,1) + phi(inode,ig)*vel(3,ipp1)/dx
dprdx = dprdx + phi(inode,ig)*(press(ipp1)-press(ipoin))/dx
dtdx(1)=dtdx(1)+phi(inode,IG)*(tempr(ipp1)-tempr(ipoin))/dx
dprdz = dprdz + dshpdx(3,inode,ig)*press(ipoin)
!
do iequa=1,nequa
dundx(1,iequa)=dundx(1,iequa)
&
& +phi(inode,IG)*(u(NEQUA*(ipp1-1)+iequa)- &
& u(NEQUA*(ipoin-1)+iequa))/dx
dfxdx(1,iequa)=dfxdx(1,iequa)+phi(inode,IG)
&
&
*(f(ipp1,1,iequa)-f(ipoin,1,iequa))/dx
enddo
!
v1b = vel(2,jpoin) + (x1-x(1,jpoin))*(vel(2,jpp1)-vel(2,jpoin))/ &
& (x(1,jpp1)-x(1,jpoin))
w1a = vel(3,ipoin) + (x1-x(1,ipoin))*(vel(3,ipp1)-vel(3,ipoin))/
&
& (x(1,ipp1)-x(1,ipoin))
w1b = vel(3,jpoin) + (x1-x(1,jpoin))*(vel(3,jpp1)-vel(3,jpoin))/
&
& (x(1,jpp1)-x(1,jpoin))
t1a = tempr(ipoin) + (x1-x(1,ipoin))*(tempr(ipp1)-tempr(ipoin))/
&
& (x(1,ipp1)-x(1,ipoin))
t1b = tempr(jpoin) + (x1-x(1,jpoin))*(tempr(jpp1)-tempr(jpoin))/
&
& (x(1,jpp1)-x(1,jpoin))
p1a = press(ipoin) + (x1-x(1,ipoin))*(press(ipp1)-press(ipoin))/
&
& (x(1,ipp1)-x(1,ipoin))
p1b = press(jpoin) + (x1-x(1,jpoin))*(press(jpp1)-press(jpoin))/
&
& (x(1,jpp1)-x(1,jpoin))
u1 = (u1a*dz1 + u1b*dz2)/dz
v1 = (v1a*dz1 + v1b*dz2)/dz
w1 = (w1a*dz1 + w1b*dz2)/dz
p1 = (p1a*dz1 + p1b*dz2)/dz
t1 = (t1a*dz1 + t1b*dz2)/dz
P = unkn(1)*cgas*T
dudx(1,2) = (velo(1)-u1)/dy
dudx(2,2) = (velo(2)-v1)/dy
dudx(3,2) = (velo(3)-w1)/dy
dtdx(2) = (T - t1)/dy
dprdy = (P - p1)/dy
!
! --- for constant wall temperature.
if(indbd(ipoin).ne.2) then
adiabatic=.false.
dundx(2,2) = unkn(1)*dudx(1,2)
dundx(2,3) = unkn(1)*dudx(2,2)
dundx(2,4) = unkn(1)*dudx(3,2)
dundx(2,5) = E*dundx(2,1) + unkn(1)*cv*dtdx(2)
else
!
! --- for adiabatic wall boundary condition.
!
adiabatic=.true.
dundx(2,1) = -dundx(1,1)*tan_a
dundx(2,2) = unkn(1)*dudx(1,2)
dundx(2,3) = unkn(1)*dudx(2,2)
dundx(2,4) = unkn(1)*dudx(3,2)
dtdx(2) = -dtdx(1)*tan_a
dundx(2,5) = E*dundx(2,1) + unkn(1)*cv*dtdx(2)
dprdy = -dprdx*tan_a
36
dudx(2,2)=0.0
dudx(3,2) = 0.0
dtdx(2)=0.0
do iequa=1,nequa
dundx(2,iequa)=0.0
dfxdx(2,iequa)=0.0
enddo
do inode=1,ndbou
ipoin=iel_nod(inode)
lnode=lfacnode(inode,iface)
if(ibndcnd==31) then ! left side wall
lnod1=lnode+1
if(lnode==1) lnod1 = 4
if(lnode==5) lnod1 = 8
elseif(ibndcnd==41) then ! right side wall
lnod1=lnode-1
if(lnode==4) lnod1 = 1
if(lnode==8) lnod1 = 5
endif
ipp1 = lnod(lnod1,ielno)
dy=x(2,ipp1)-x(2,ipoin)
dudx(1,2)=dudx(1,2)+phi(inode,ig)*vel(1,ipp1)/dy
dudx(2,2)=dudx(2,2)+phi(inode,ig)*vel(2,ipp1)/dy
dudx(3,2)=dudx(3,2)+phi(inode,ig)*vel(3,ipp1)/dy
! --- for constant wall temperature.
if(indbd(ipoin).ne.2) then
adiabatic=.false.
dtdx(2)=dtdx(2)+phi(inode,ig)*(tempr(ipp1)-tempr(ipoin))/dy
do iequa=1,nequa
dundx(2,iequa)=dundx(2,iequa)
&
& +phi(inode,ig)*(u(nequa*(ipp1-1)+iequa)&
& u(nequa*(ipoin-1)+iequa))/dy
dfxdx(2,iequa)=dfxdx(2,iequa)+phi(inode,ig) &
&
*(f(ipp1,2,iequa)-f(ipoin,2,iequa))/dy
enddo
! --- for adiabatic wall boundary condition.
else
adiabatic=.true.
P = cgas*unkn(1)*T
dtdx(2)=0.0
dundx(2,1) = 0.0
dundx(2,2)=dundx(2,2) + phi(inode,ig)*unkn(1)* &
&
(vel(1,ipp1) - vel(1,ipoin))/dy
dundx(2,3) = dundx(2,3) + phi(inode,ig)*unkn(1)* &
&
(vel(2,ipp1) - vel(2,ipoin))/dy
dundx(2,4) = dundx(2,4) + phi(inode,ig)*unkn(1)* &
&
(vel(3,ipp1) - vel(3,ipoin))/dy
dundx(2,5)= 0.0
!
dfxdx(2,1)=dfxdx(2,1)+phi(inode,ig)*unkn(1)
&
&
*(vel(2,ipp1) - vel(2,ipoin))/dy
dfxdx(2,2)= 0.0
dfxdx(1,3)= 0.0
dfxdx(1,4)= 0.0
dfxdx(1,5)=dfxdx(1,5)+phi(inode,ig)
&
& *(unkn(5) + P)*vel(2,ipp1)/dy
endif
enddo
!
Case(-12) ! Top Surface of Lid-Driven Cavity
! Dirichlet on Flow variables
! Normal Gradients Non-zero
dudx(1:3,3) = 0.0
d2udx2(1:ndimn,1:ndimn,3) = 0.0
d2udx2(1:ndimn,3,1:ndimn) = 0.0
dtdx(3) = 0.0
d2tdx2(3) = 0.0
dundx(3,1:nequa) = 0.0
dfxdx(3,1:nequa) = 0.0
!
endif
!
dfxdx(2,1) = dundx(2,3)
dfxdx(2,2) = 0.0
dfxdx(2,3) = dprdy
dfxdx(2,4) = 0.0
dfxdx(2,5) = (unkn(5)+P)*dudx(2,2)
!
Case(11,21) ! No slip wall in y-z plane
dudx(1,1)=0.0
dudx(2,1)=0.0
dudx(3,1) = 0.0
dtdx(1)=0.0
do iequa=1,nequa
dundx(1,iequa)=0.0
dfxdx(1,iequa)=0.0
enddo
do inode=1,ndbou
ipoin=iel_nod(inode)
lnode=lfacnode(inode,iface)
lnod1=lnode+1
if(ibndcnd==11) then ! left side wall
if(lnode==8) lnod1 = 7
if(lnode==4) lnod1 = 3
elseif(ibndcnd==21) then ! right side wall
if(lnode==2) lnod1 = 1
if(lnode==6) lnod1 = 5
endif
ipp1 = lnod(lnod1,ielno)
dx=x(1,ipp1)-x(1,ipoin)
dudx(1,1)=dudx(1,1)+phi(inode,ig)*vel(1,ipp1)/dx
dudx(2,1)=dudx(2,1)+phi(inode,ig)*vel(2,ipp1)/dx
dudx(3,1)=dudx(3,1)+phi(inode,ig)*vel(3,ipp1)/dx
! --- for constant wall temperature.
if(indbd(ipoin).ne.2) then
adiabatic=.false.
dtdx(1)=dtdx(1)+phi(inode,ig)*(tempr(ipp1)-tempr(ipoin))/dx
do iequa=1,nequa
dundx(1,iequa)=dundx(1,iequa) &
& +phi(inode,ig)*(u(nequa*(ipp1-1)+iequa)- &
& u(nequa*(ipoin-1)+iequa))/dx
dfxdx(1,iequa)=dfxdx(1,iequa)+phi(inode,ig)
&
&
*(f(ipp1,1,iequa)-f(ipoin,1,iequa))/dx
enddo
! --- for adiabatic wall boundary condition.
else
adiabatic=.true.
P = cgas*unkn(1)*T
dtdx(1)=0.0
dundx(1,1) = 0.0
dundx(1,2)=dundx(1,2) + phi(inode,ig)*unkn(1)* &
&
(vel(1,ipp1) - vel(1,ipoin))/dx
dundx(1,3) = dundx(1,3) + phi(inode,ig)*unkn(1)* &
&
(vel(2,ipp1) - vel(2,ipoin))/dx
dundx(1,4) = dundx(1,4) + phi(inode,ig)*unkn(1)* &
&
(vel(3,ipp1) - vel(3,ipoin))/dx
dundx(1,5)= 0.0
!
dfxdx(1,1)=dfxdx(1,1)+phi(inode,ig)*unkn(1) &
&
*(vel(1,ipp1) - vel(1,ipoin))/dx
dfxdx(1,2) = 0.0
dfxdx(1,3) = 0.0
dfxdx(1,4) = 0.0
dfxdx(1,5)=dfxdx(1,5)+phi(inode,ig)
&
& *(unkn(5) + P)*vel(1,ipp1)/dx
endif
enddo
!
Case(31,41) ! No slip wall in x-z plane
dudx(1,2)=0.0
37
do iequa=1,nequa
dundx(2,iequa)=0.0
dfxdx(2,iequa)=0.0
dfydz(iequa)=0.0
enddo
do inode = 1,ndbou
ipoin = iel_nod(inode)
lnode = lfacnode(inode,iface)
inod1 = lnode - ndbou
ipp1 = lnod(inod1,ielno)
dz = x(3,ipp1) - x(3,ipoin)
do idimn = 1,ndimn
dudx(idimn,3) = dudx(idimn,3) + phi(inode,ig)* &
(vel(idimn,ipp1) - vel(idimn,ipoin))&
/dz
enddo
!
do inode = 1, ndbou
ipoin = iel_nod(inode)
if(inode==1) lnode=1
if(inode==2) lnode=2
if(inode==3) lnode=6
if(inode==4) lnode=5
ipp1=lnod(lnode,ielno)
!
tan_a=tan_a + phi(inode,ig)*
! &
(x(2,ipp1)-x(2,ipoin))/(x(1,ipp1)-x(1,ipoin))
do iequa=1,nequa
dfydz(iequa)=dfydz(iequa)+dshpdx(3,inode,ig)* &
&
f(ipoin,2,iequa)
enddo
enddo
!
dudx(1,2)=-dudx(1,3)*tan_a
dudx(2,2)=-dudx(2,3)*tan_a
dudx(3,2) = -dudx(3,3)*tan_a
dtdx(2)=-dtdx(3)*tan_a
!
do iequa=1,nequa
dundx(2,iequa)=-dundx(3,iequa)*tan_a
dfxdx(2,iequa)=-dfydz(iequa)*tan_a
enddo
!
!
Case(9) ! Triple Shock exit, derivatives in Flow Dir 0
dudx(1,2)=0.0
dudx(2,2)=0.0
dudx(3,2) = 0.0
dtdx(2)=0.0
pi= acos(-1.)
angl_b = 15.*pi/180.
tan_a=tan(alpa)
tan_b = tan(angl_b)
do iequa=1,nequa
dundx(2,iequa)=0.0
dfxdx(2,iequa)=0.0
dfydx(iequa) = 0.0
dfydz(iequa)=0.0
enddo
!
do inode = 1, ndbou
ipoin = iel_nod(inode)
if(inode==1) lnode=1
if(inode==2) lnode=2
if(inode==3) lnode=6
if(inode==4) lnode=5
ipp1=lnod(lnode,ielno)
do iequa=1,nequa
dfydx(iequa) = dfydx(iequa) + dshpdx(1,inode,ig)* &
f(ipoin,2,iequa)
dfydz(iequa)=dfydz(iequa)+dshpdx(3,inode,ig)* &
&
f(ipoin,2,iequa)
enddo
enddo
!
dudx(1,2) = -dudx(1,1)*tan_b - dudx(1,3)*tan_a
dudx(2,2) = -dudx(2,1)*tan_b - dudx(2,3)*tan_a
dudx(3,2) = -dudx(3,1)*tan_b - dudx(3,3)*tan_a
dtdx(2) = -dtdx(1)*tan_b - dtdx(3)*tan_a
!
do iequa=1,nequa
!
dtdx(3) = dtdx(3) + phi(inode,ig)*(tempr(ipp1) - &
tempr(ipoin))/dz
do iequa = 1,nequa
iordr = nequa*(ipoin-1) + iequa
jordr = nequa*(ipp1-1) + iequa
dundx(3,iequa) = dundx(3,iequa) + phi(inode,ig)* &
(u(jordr) - u(iordr))/dz
dfxdx(3,iequa) = dfxdx(3,iequa) + phi(inode,ig)* &
(f(ipp1,3,iequa) - f(ipoin,3,iequa))&
/dz
enddo
enddo
!
Case(-1,6) ! Inlet and Exit, normal derivatives = 0
dudx(1,2)=0.0
dudx(2,2)=0.0
dudx(3,2) = 0.0
dtdx(2)=0.0
d2tdx2(2) = 0.0
do idimn = 1,ndimn
d2udx2(1,idimn,2) = 0.0
d2udx2(2,idimn,2) = 0.0
d2udx2(3,idimn,2) = 0.0
d2udx2(1,2,idimn) = 0.0
d2udx2(2,2,idimn) = 0.0
d2udx2(3,2,idimn) = 0.0
enddo
do iequa=1,nequa
dundx(2,iequa)=0.0
dfxdx(2,iequa)=0.0
enddo
!
Case(7) ! Normal derivatives on top surface = 0
dudx(1,3)=0.0
dudx(2,3)=0.0
dudx(3,3) = 0.0
dtdx(3)=0.0
d2tdx2(3) = 0.0
do idimn = 1,ndimn
d2udx2(1,idimn,3) = 0.0
d2udx2(2,idimn,3) = 0.0
d2udx2(3,idimn,3) = 0.0
d2udx2(1,3,idimn) = 0.0
d2udx2(2,3,idimn) = 0.0
d2udx2(3,3,idimn) = 0.0
enddo
do iequa=1,nequa
dundx(3,iequa)=0.0
dfxdx(3,iequa)=0.0
enddo
!
!
Case(8) ! Compression Corner exit, derivatives in Flow Dir 0
dudx(1,2)=0.0
dudx(2,2)=0.0
dudx(3,2) = 0.0
dtdx(2)=0.0
tan_a=tan(alpa)
tan_a = velo(2)/velo(1)
38
!
dundx(2,iequa) = -dundx(1,iequa)*tan_b dundx(3,iequa)*tan_a
dfxdx(2,iequa) = -dfydx(iequa)*tan_b - dfydz(iequa)*tan_a
enddo
!
Case(5) ! Compression corner exit, non-zero gradients
!
x1 = 0.0
y1 = 0.0
z1 = 0.0
do inode = 1,ndbou
ipoin = iel_nod(inode)
x1 = x1 + phi(inode,ig)*x(1,ipoin)
y1 = y1 + phi(inode,ig)*x(2,ipoin)
z1 = z1 + phi(inode,ig)*x(3,ipoin)
enddo
ipp1 = lnod(1,ielno)
jpp1 = lnod(2,ielno)
dx1a = x1 - x(1,ipp1)
dx1b = x(1,jpp1) - x1
dx1 = x(1,jpp1) - x(1,ipp1)
u1a = (vel(1,ipp1)*dx1a + vel(1,jpp1)*dx1b)/dx1
v1a = (vel(2,ipp1)*dx1a + vel(2,jpp1)*dx1b)/dx1
w1a = (vel(3,ipp1)*dx1a + vel(3,jpp1)*dx1b)/dx1
rho1a = (dense(ipp1)*dx1a + dense(jpp1)*dx1b)/dx1
t1a = (tempr(ipp1)*dx1a + tempr(jpp1)*dx1b)/dx1
p1a = (press(ipp1)*dx1a + press(jpp1)*dx1b)/dx1
dfxdx(2,1) = dundx(2,3)
dfxdx(2,2) = velo(1)*velo(2)*drdy + unkn(1)*(velo(1)* &
dudx(2,2) + velo(2)*dudx(1,2))
dfxdx(2,3) = velo(2)*velo(2)*drdy + unkn(1)*2.*velo(2)*
&
dudx(2,2) + dprdy
dfxdx(2,4) = velo(2)*velo(3)*drdy + unkn(1)*(velo(2)* &
dudx(3,2) + velo(3)*dudx(2,2))
dfxdx(2,5) = (unkn(5) + P)*dudx(2,2) +
velo(2)*(dundx(2,5)&
+ dprdy)
!
End Select
!
return
end subroutine aplbndcnd
!
!
*******************************************************
************
! Subroutine to apply boundary conditions to 2-D Jacobians
!
Subroutine jacbnc2d(ndimn,nequa,ibndcnd,adiabatic,hk,vis, &
&unkn,dundx,E,reinv,tau,velo,aj,bj,cj)
!
!DIR$ INLINEALWAYS jacbnc2d
!
Use thermo_propt
!
Implicit None
!
integer,intent(in) :: ndimn,nequa,ibndcnd
logical,intent(in) :: adiabatic
real,intent(in) :: E,hk,reinv,vis
real,intent(in),dimension(ndimn,ndimn) :: tau
real,intent(in),dimension(nequa) :: unkn
real,intent(in),dimension(ndimn,nequa) :: dundx
real,intent(in),dimension(ndimn) :: velo
real,intent(inout),dimension(ndimn,nequa,nequa) :: aj,bj
real,intent(inout),dimension(ndimn,ndimn,nequa,nequa) :: cj
!
integer :: iequa,jequa
real :: r,ru,rv,re,ru2,rv2,uvel,vvel,u2,v2
real :: drdx,dldx,dmdx,dedx,drdy,dldy,dmdy,dedy
real :: rinv,r2inv,ckor2cv,cvisr
!
r = unkn(1)
ru = unkn(2)
rv = unkn(3)
re = unkn(4)
uvel = velo(1)
vvel = velo(2)
u2 = uvel*uvel
v2 = vvel*vvel
ru2 = ru*ru
!
ipp1 = lnod(5,ielno)
jpp1 = lnod(6,ielno)
dx2a = x1 - x(1,ipp1)
dx2b = x(1,jpp1) - x1
dx2 = x(1,jpp1) - x(1,ipp1)
u1b = (vel(1,ipp1)*dx2a + vel(1,jpp1)*dx2b)/dx2
v1b = (vel(2,ipp1)*dx2a + vel(2,jpp1)*dx2b)/dx2
w1b = (vel(3,ipp1)*dx2a + vel(3,jpp1)*dx2b)/dx2
rho1b = (dense(ipp1)*dx2a + dense(jpp1)*dx2b)/dx2
t1b = (tempr(ipp1)*dx2a + tempr(jpp1)*dx2b)/dx2
p1b = (press(ipp1)*dx2a + press(jpp1)*dx2b)/dx2
!
ipp1 = lnod(1,ielno)
jpp1 = lnod(5,ielno)
dz1 = z1 - x(3,ipp1)
dz2 = x(3,jpp1) - z1
dz = x(3,jpp1) - x(3,ipp1)
u1 = (u1a*dz1 + u1b*dz2)/dz
v1 = (v1a*dz1 + v1b*dz2)/dz
w1 = (w1a*dz1 + w1b*dz2)/dz
r1 = (rho1a*dz1 + rho1b*dz2)/dz
t1 = (t1a*dz1 + t1b*dz2)/dz
p1 = (p1a*dz1 + p1b*dz2)/dz
!
P = unkn(1)*cgas*T
ipoin = lnod(1,ielno)
dy = y1 - x(1,ipoin)
dudx(1,2) = (velo(1) - u1)/dy
dudx(2,2) = (velo(2) - v1)/dy
dudx(3,2) = (velo(3) - w1)/dy
dtdx(2) = (T - t1)/dy
drdy = (unkn(1) - r1)/dy
dprdy = (P -p1)/dy
rv2 = rv*rv
!
drdx = dundx(1,1)
dldx = dundx(1,2)
dmdx = dundx(1,3)
dedx = dundx(1,4)
drdy = dundx(2,1)
dldy = dundx(2,2)
dmdy = dundx(2,3)
dedy = dundx(2,4)
!
dundx(2,1) = drdy
dundx(2,2) = velo(1)*drdy + unkn(1)*dudx(1,2)
dundx(2,3) = velo(2)*drdy + unkn(1)*dudx(2,2)
dundx(2,4) = velo(3)*drdy + unkn(1)*dudx(3,2)
dundx(2,5) = E*drdy +unkn(1)*(cv*dtdx(2) + &
velo(1)*dudx(1,2) + velo(2)*dudx(2,2) + &
velo(3)*dudx(3,2))
!
rinv = 1./r
r2inv = rinv/r
39
BJ(1,4,2)=ckor2cv*dundx(1,2)*reinv
BJ(1,4,3)=ckor2cv*dundx(1,3)*reinv
BJ(1,4,4)=ckor2cv*dundx(1,1)*reinv
BJ(2,4,1)=-ckor2cv*(-dundx(2,4)+2*E*dundx(2,1))*reinv
BJ(2,4,2)=ckor2cv*dundx(2,2)*reinv
BJ(2,4,3)=ckor2cv*dundx(2,3)*reinv
BJ(2,4,4)=ckor2cv*dundx(2,1)*reinv
! -for no heat flux
if(adiabatic) then
do iequa=1,nequa
BJ(2,4,iequa)=0.0
enddo
endif
!
CJ(1,1,4,1)=HK*E/unkn(1)/cv*reinv
CJ(1,1,4,2)=0.0
CJ(1,1,4,3)=0.0
CJ(1,1,4,4)=-HK/Unkn(1)/cv*reinv
CJ(1,2,4,1)=0.0
CJ(1,2,4,2)=0.0
CJ(1,2,4,3)=0.0
CJ(2,1,4,1)=0.0
CJ(2,1,4,2)=0.0
CJ(2,1,4,3)=0.0
CJ(2,2,4,1)=CJ(1,1,4,1)
CJ(2,2,4,2)=0.0
CJ(2,2,4,3)=0.0
CJ(2,2,4,4)=CJ(1,1,4,4)
! -for no heat flux
if(adiabatic) then
CJ(2,2,4,1)=0.0
CJ(2,2,4,4)=0.0
endif
!
Case(4) ! No-slip compression corner, u=v=0, T=Twall or
dT/dn=0
do iequa=1,nequa
do jequa=1,nequa
AJ(1,iequa,jequa)=0.0
AJ(2,iequa,jequa)=0.0
enddo
enddo
AJ(1,2,4)=gamm1
AJ(2,3,4)=gamm1
BJ(1,4,1)=-ckor2cv*(-dundx(1,4)+2*E*dundx(1,1))*reinv
BJ(1,4,2)=ckor2cv*dundx(1,2)*reinv
BJ(1,4,3)=ckor2cv*dundx(1,3)*reinv
BJ(1,4,4)=ckor2cv*dundx(1,1)*reinv
BJ(2,4,1)=-ckor2cv*(-dundx(2,4)+2*E*dundx(2,1))*reinv
BJ(2,4,2)=ckor2cv*dundx(2,2)*reinv
BJ(2,4,3)=ckor2cv*dundx(2,3)*reinv
BJ(2,4,4)=ckor2cv*dundx(2,1)*reinv
!
CJ(1,1,4,1)=HK*E/unkn(1)/cv*reinv
CJ(1,1,4,2)=0.0
CJ(1,1,4,3)=0.0
CJ(1,1,4,4)=-HK/Unkn(1)/cv*reinv
CJ(1,2,4,1)=0.0
CJ(1,2,4,2)=0.0
CJ(1,2,4,3)=0.0
CJ(2,1,4,1)=0.0
CJ(2,1,4,2)=0.0
CJ(2,1,4,3)=0.0
CJ(2,2,4,1)=CJ(1,1,4,1)
CJ(2,2,4,2)=0.0
CJ(2,2,4,3)=0.0
CJ(2,2,4,4)=CJ(1,1,4,4)
!
Case(15) ! Top surface of Driven Cavity
AJ(1,3,1)=0.0
CKOR2CV = HK*r2inv/CV
CVISR = 4./3.*VIS
!
Select Case(ibndcnd)
Case(2,12) ! Symmetry, v=tau12=dT/dn=0
AJ(1,3,1)=0.0
AJ(1,3,2)=0.0
AJ(1,3,3)=0.0
AJ(2,1,3)=0.0
AJ(2,2,1)=0.0
AJ(2,2,2)=0.0
AJ(2,2,3)=0.0
AJ(2,3,1)=gamm1/2.*velo(1)*velo(1)
AJ(2,3,2)=-gamm1*velo(1)
AJ(2,3,3)=0.0
AJ(2,3,4)=gamm1
AJ(2,4,1)=0.0
AJ(2,4,2)=0.0
AJ(2,4,3)=0.0
AJ(2,4,4)=0.0
BJ(1,3,1)=0.0
BJ(1,3,2)=0.0
BJ(1,3,3)=0.0
BJ(1,4,1)=velo(1)*BJ(1,2,1)+(unkn(2)/unkn(1)**2*TAU(1,1)
&
&
-ckor2cv*(-dundx(1,4)+2*velo(1)*dundx(1,2)
&
&
+(2*E-3*velo(1)**2)*dundx(1,1)))*reinv
BJ(1,4,2)=velo(1)*BJ(1,2,2) + (-tau(1,1)/unkn(1)
&
&
-ckor2cv*(-dundx(1,2)+2.*velo(1)*dundx(1,1)))*reinv
BJ(1,4,3)=velo(1)*BJ(1,2,3)+ckor2cv*dundx(1,3)*reinv
BJ(1,4,4)=ckor2cv*dundx(1,1)*reinv
BJ(2,2,1)=0.0
BJ(2,2,2)=0.0
BJ(2,2,3)=0.0
BJ(2,4,1)=0.0
BJ(2,4,2)=0.0
BJ(2,4,3)=0.0
BJ(2,4,4)=0.0
CJ(1,1,3,1)=0.0
CJ(1,1,3,3)=0.0
CJ(1,1,4,1)=(cvisr*velo(1)*velo(1)/unkn(1)
&
&
-HK/cv*(-E/unkn(1)+velo(1)*velo(1)/unkn(1)))*reinv
CJ(1,1,4,3)=0.0
CJ(1,2,3,1)=0.0
CJ(1,2,3,2)=0.0
CJ(1,2,4,1)=0.0
CJ(1,2,4,2)=0.0
CJ(2,1,2,1)=0.0
CJ(2,1,2,3)=0.0
CJ(2,1,4,1)=0.0
CJ(2,1,4,2)=0.0
CJ(2,1,4,3)=0.0
CJ(2,2,2,1)=0.0
CJ(2,2,2,2)=0.0
CJ(2,2,4,1)=0.0
CJ(2,2,4,2)=0.0
CJ(2,2,4,3)=0.0
CJ(2,2,4,4)=0.0
!
Case(1) ! No-slip wall, u=v=0, T=Twall or dT/dn=0
do iequa=1,nequa
do jequa=1,nequa
AJ(1,iequa,jequa)=0.0
AJ(2,iequa,jequa)=0.0
enddo
enddo
AJ(1,2,4)=gamm1
AJ(2,3,4)=gamm1
BJ(1,4,1)=-ckor2cv*(-dundx(1,4)+2*E*dundx(1,1))*reinv
40
Subroutine jacbndcnd(ndimn,nequa,ibndcnd,adiabatic,hk,vis, &
&unkn,dundx,E,reinv,tau,velo,aj,bj,cj)
AJ(1,3,2)=0.0
AJ(1,3,3)=0.0
AJ(2,1,3)=0.0
AJ(2,2,1)=0.0
AJ(2,2,2)=0.0
AJ(2,2,3)=0.0
AJ(2,3,1)=gamm1/2.*velo(1)*velo(1)
AJ(2,3,2)=-gamm1*velo(1)
AJ(2,3,3)=0.0
AJ(2,3,4)=gamm1
AJ(2,4,1)=0.0
AJ(2,4,2)=0.0
AJ(2,4,3)=0.0
AJ(2,4,4)=0.0
!
!DIR$ INLINEALWAYS jacbndcnd
!
Use thermo_propt
!
Implicit None
!
integer,intent(in) :: ndimn,nequa,ibndcnd
logical,intent(in) :: adiabatic
real,intent(in) :: E,hk,reinv,vis
real,intent(in),dimension(ndimn,ndimn) :: tau
real,intent(in),dimension(nequa) :: unkn
real,intent(in),dimension(ndimn,nequa) :: dundx
real,intent(in),dimension(ndimn) :: velo
real,intent(inout),dimension(ndimn,nequa,nequa) :: aj,bj
real,intent(inout),dimension(ndimn,ndimn,nequa,nequa) :: cj
!
integer :: iequa,jequa
real :: r,ru,rv,rw,re,ru2,rv2,rw2,uvel,vvel,wvel,u2,v2,w2
real :: drdx,dldx,dmdx,dndx,dedx,drdy,dldy,dmdy,dndy,dedy
real :: drdz,dldz,dmdz,dndz,dedz,rinv,r2inv,ckor2cv,cvisr
!
r = unkn(1)
ru = unkn(2)
rv = unkn(3)
rw = unkn(4)
re = unkn(5)
uvel = velo(1)
vvel = velo(2)
wvel = velo(3)
u2 = uvel*uvel
v2 = vvel*vvel
w2 = wvel*wvel
ru2 = ru*ru
rv2 = rv*rv
rw2 = rw*rw
!
drdx = dundx(1,1)
dldx = dundx(1,2)
dmdx = dundx(1,3)
dndx = dundx(1,4)
dedx = dundx(1,5)
drdy = dundx(2,1)
dldy = dundx(2,2)
dmdy = dundx(2,3)
dndy = dundx(2,4)
dedy = dundx(2,5)
drdz = dundx(3,1)
dldz = dundx(3,2)
dmdz = dundx(3,3)
dndz = dundx(3,4)
dedz = dundx(3,5)
!
rinv = 1./r
!
Case(11,21) ! No-slip side walls on Driven Cavity
do iequa=1,nequa
do jequa=1,nequa
AJ(1,iequa,jequa)=0.0
AJ(2,iequa,jequa)=0.0
enddo
enddo
AJ(1,2,4)=gamm1
AJ(2,3,4)=gamm1
BJ(1,4,1)=-ckor2cv*(-dundx(1,4)+2*E*dundx(1,1))*reinv
BJ(1,4,2)=ckor2cv*dundx(1,2)*reinv
BJ(1,4,3)=ckor2cv*dundx(1,3)*reinv
BJ(1,4,4)=ckor2cv*dundx(1,1)*reinv
BJ(2,4,1)=-ckor2cv*(-dundx(2,4)+2*E*dundx(2,1))*reinv
BJ(2,4,2)=ckor2cv*dundx(2,2)*reinv
BJ(2,4,3)=ckor2cv*dundx(2,3)*reinv
BJ(2,4,4)=ckor2cv*dundx(2,1)*reinv
! -for no heat flux
if(adiabatic) then
do iequa=1,nequa
BJ(1,4,iequa)=0.0
enddo
endif
!
CJ(1,1,4,1)=HK*E/unkn(1)/cv*reinv
CJ(1,1,4,2)=0.0
CJ(1,1,4,3)=0.0
CJ(1,1,4,4)=-HK/Unkn(1)/cv*reinv
CJ(1,2,4,1)=0.0
CJ(1,2,4,2)=0.0
CJ(1,2,4,3)=0.0
CJ(2,1,4,1)=0.0
CJ(2,1,4,2)=0.0
CJ(2,1,4,3)=0.0
CJ(2,2,4,1)=CJ(1,1,4,1)
CJ(2,2,4,2)=0.0
CJ(2,2,4,3)=0.0
CJ(2,2,4,4)=CJ(1,1,4,4)
! -for no heat flux
if(adiabatic) then
CJ(1,1,4,1)=0.0
CJ(1,1,4,4)=0.0
endif
!
End Select
!
return
end subroutine jacbnc2d
!
!
*******************************************************
************
! Subroutine to apply boundary conditions to 3-D Jacobians
!
r2inv = rinv/r
CKOR2CV = HK*r2inv/CV
CVISR = 4./3.*VIS
!
Select Case(ibndcnd)
Case(2,12) ! Symmetry in x-y plane, w=0,tau13=tau23=q3=0
!
AJ(1,4,1)=0.0
AJ(1,4,2)=0.0
AJ(1,4,3)=0.0
AJ(1,4,4) = 0.0
AJ(2,4,1)=0.0
AJ(2,4,2)=0.0
41
CJ(1,3,4,1)=0.0
CJ(1,3,4,2)=0.0
CJ(1,3,4,3)=0.0
Cj(1,3,4,4)=0.0
CJ(1,3,5,1)=uvel*CJ(1,3,2,1)
CJ(1,3,5,2)=0.0
CJ(2,1,4,1)=0.0
CJ(2,1,4,2)=0.0
CJ(2,1,4,3)=0.0
CJ(2,1,4,4)=0.0
CJ(2,2,4,1)=0.0
CJ(2,2,4,2)=0.0
CJ(2,2,4,3)=0.0
CJ(2,2,4,4)=0.0
CJ(2,2,5,1)=uvel*CJ(2,2,2,1) + vvel*CJ(2,2,3,1) - ckor2cv* &
&
(-re + (ru2 + rv2)*rinv)*reinv
CJ(2,2,5,4)=0.0
CJ(2,3,4,1)=0.0
CJ(2,3,4,2)=0.0
CJ(2,3,4,3)=0.0
CJ(2,3,4,4)=0.0
CJ(2,3,5,1)=vvel*CJ(2,3,3,1)
CJ(2,3,5,3)=0.0
CJ(3,1,2,1)=0.0
CJ(3,1,2,2)=0.0
CJ(3,1,2,3)=0.0
CJ(3,1,2,4)=0.0
CJ(3,1,3,1)=0.0
CJ(3,1,3,2)=0.0
CJ(3,1,3,3)=0.0
CJ(3,1,3,4)=0.0
CJ(3,1,5,1)=0.0
CJ(3,1,5,2)=0.0
CJ(3,1,5,3)=0.0
CJ(3,1,5,4)=0.0
CJ(3,1,5,5)=0.0
CJ(3,2,2,1)=0.0
CJ(3,2,2,2)=0.0
CJ(3,2,2,3)=0.0
CJ(3,2,2,4)=0.0
CJ(3,2,3,1)=0.0
CJ(3,2,3,2)=0.0
CJ(3,2,3,3)=0.0
CJ(3,2,3,4)=0.0
CJ(3,2,5,1)=0.0
CJ(3,2,5,2)=0.0
CJ(3,2,5,3)=0.0
CJ(3,2,5,4)=0.0
CJ(3,2,5,5)=0.0
CJ(3,3,2,1)=0.0
CJ(3,3,2,2)=0.0
CJ(3,3,2,3)=0.0
CJ(3,3,2,4)=0.0
CJ(3,3,3,1)=0.0
CJ(3,3,3,2)=0.0
CJ(3,3,3,3)=0.0
CJ(3,3,3,4)=0.0
CJ(3,3,5,1)=0.0
CJ(3,3,5,2)=0.0
CJ(3,3,5,3)=0.0
CJ(3,3,5,4)=0.0
CJ(3,3,5,5)=0.0
AJ(2,4,3)=0.0
AJ(2,4,4) = 0.0
do iequa = 1,nequa
do jequa = 1,nequa
aj(3,iequa,jequa) = 0.0
enddo
enddo
!
aj(3,4,1) = gamm1/2*(u2 + v2)
aj(3,4,2) = -gamm1*uvel
aj(3,4,3) = -gamm1*vvel
aj(3,4,5) = gamm1
BJ(1,4,1)=0.0
BJ(1,4,2)=0.0
BJ(1,4,3)=0.0
BJ(1,4,4)=0.0
BJ(1,5,1)=uvel*BJ(1,2,1)+vvel*BJ(1,3,1)+(rinv*(uvel*tau(1,1) +
&
&
vvel*TAU(1,2))-ckor2cv*(-dedx + 2.*uvel*dldx +
2.*vvel*&
&
dmdx + (2.*E - 3.*u2 - 3.*v2)*drdx))*reinv
BJ(1,5,2)= uvel*BJ(1,2,2) + vvel*BJ(1,3,2) + &
&
(-tau(1,1)*rinv-ckor2cv*(-dldx + 2.*uvel*drdx))*reinv
BJ(1,5,3)=uvel*BJ(1,2,3) + vvel*BJ(1,3,3) + (-TAU(1,2)*rinv
&
&
-ckor2cv*(2.*vvel*drdx - dmdx))*reinv
BJ(1,5,4)=uvel*BJ(1,2,4) + vvel*BJ(1,3,4) +
ckor2cv*dndx*reinv
BJ(1,5,5)=ckor2cv*drdx*reinv
BJ(2,4,1)=0.0
BJ(2,4,2)=0.0
BJ(2,4,3)=0.0
BJ(2,4,4)=0.0
BJ(2,5,1)=uvel*BJ(2,2,1) + vvel*BJ(2,3,1)+(rinv*(uvel*tau(2,1)
&
&
+ vvel*TAU(2,2)) - ckor2cv*(-dedy + (2.*E-3.*u2 3.*v2)&
&
*drdy + 2.*uvel*dldy + 2.*vvel*dmdy))*reinv
BJ(2,5,2)=uvel*BJ(2,2,2) + vvel*BJ(2,3,2) + (-TAU(2,1)*rinv
&
&
- ckor2cv*(2.*uvel*drdy-dldy))*reinv
BJ(2,5,3)=uvel*BJ(2,2,3) + vvel*BJ(2,3,3) + (-TAU(2,2)*rinv
&
&
- ckor2cv*(2.*vvel*drdy - dmdy))*reinv
BJ(2,5,4)=uvel*BJ(2,2,4) + vvel*BJ(2,3,4) +
ckor2cv*dndy*reinv
BJ(3,2,1)=0.0
BJ(3,2,2)=0.0
BJ(3,2,3)=0.0
BJ(3,2,4)=0.0
BJ(3,3,1)=0.0
BJ(3,3,2)=0.0
BJ(3,3,3)=0.0
BJ(3,3,4)=0.0
BJ(3,5,1)=0.0
BJ(3,5,2)=0.0
BJ(3,5,3)=0.0
BJ(3,5,4)=0.0
BJ(3,5,5)=0.0
CJ(1,1,4,1)=0.0
CJ(1,1,4,3)=0.0
CJ(1,1,4,4)=0.0
CJ(1,1,5,1)=uvel*CJ(1,1,2,1) + vvel*CJ(1,1,3,1) - ckor2cv* &
&
(-re + (ru2 + rv2)*rinv)*reinv
CJ(1,1,5,4)=0.0
CJ(1,2,4,1)=0.0
CJ(1,2,4,2)=0.0
CJ(1,2,4,3)=0.0
CJ(1,2,4,4)=0.0
!
Case(22) ! Symmetry in y-z plane, u=0, tau21=tau31=q1=0
do iequa = 1,nequa
do jequa = 1,nequa
aj(1,iequa,jequa) = 0.0
enddo
enddo
!
42
AJ(1,2,1)=gamm1/2.*(v2 + w2)
AJ(1,2,2)=0.0
AJ(1,2,3)=-gamm1*vvel
AJ(1,2,4) = -gamm1*wvel
AJ(1,2,5) = gamm1
AJ(2,2,1)=0.0
AJ(2,2,2)=0.0
AJ(2,2,3)=0.0
AJ(2,2,4) = 0.0
aj(3,2,1) = 0.0
aj(3,2,2) = 0.0
aj(3,2,3) = 0.0
aj(3,2,4) = 0.0
BJ(1,3,1)=0.0
BJ(1,3,2)=0.0
BJ(1,3,3)=0.0
BJ(1,3,4) = 0.0
BJ(1,4,1)=0.0
BJ(1,4,2)=0.0
BJ(1,4,3)=0.0
BJ(1,4,4)=0.0
BJ(1,5,1)=0.0
BJ(1,5,2)=0.0
BJ(1,5,3)=0.0
BJ(1,5,4)=0.0
BJ(1,5,5)=0.0
BJ(2,2,1)=0.0
BJ(2,2,2)=0.0
BJ(2,2,3)=0.0
BJ(2,2,4)=0.0
BJ(2,5,1)=vvel*BJ(2,3,1)+wvel*BJ(2,4,1)+(rinv*(vvel*
&
TAU(2,2)+wvel*TAU(2,3))-ckor2cv*(-dedy +
CJ(1,1,5,3)=0.0
CJ(1,1,5,4)=0.0
CJ(1,1,5,5)=0.0
CJ(1,2,3,1)=0.0
CJ(1,2,3,2)=0.0
CJ(1,2,3,3)=0.0
CJ(1,2,3,4)=0.0
CJ(1,2,4,1)=0.0
CJ(1,2,4,2)=0.0
CJ(1,2,4,3)=0.0
CJ(1,2,4,4)=0.0
CJ(1,2,5,1)=0.0
CJ(1,2,5,2)=0.0
CJ(1,2,5,3)=0.0
CJ(1,2,5,4)=0.0
CJ(1,2,5,5)=0.0
CJ(1,3,3,1)=0.0
CJ(1,3,3,2)=0.0
CJ(1,3,3,3)=0.0
CJ(1,3,3,4)=0.0
CJ(1,3,4,1)=0.0
CJ(1,3,4,2)=0.0
CJ(1,3,4,3)=0.0
CJ(1,3,4,4)=0.0
CJ(1,3,5,1)=0.0
CJ(1,3,5,2)=0.0
CJ(1,3,5,3)=0.0
CJ(1,3,5,4)=0.0
CJ(1,3,5,5)=0.0
CJ(2,1,2,1)=0.0
CJ(2,1,2,2)=0.0
CJ(2,1,2,3)=0.0
CJ(2,1,2,4)=0.0
CJ(2,1,5,1)=vvel*CJ(2,1,3,1)
CJ(2,1,5,3)=0.0
CJ(2,2,2,1)=0.0
CJ(2,2,2,2)=0.0
CJ(2,2,2,3)=0.0
CJ(2,2,2,4)=0.0
CJ(2,2,5,1)=vvel*CJ(2,2,3,1) + wvel*CJ(2,2,4,1) - ckor2cv* &
&
(-re + (rv2 + rw2)*rinv)*reinv
CJ(2,2,5,2) = 0.0
CJ(2,3,2,1)=0.0
CJ(2,3,2,2)=0.0
CJ(2,3,2,3)=0.0
CJ(2,3,2,4)=0.0
CJ(3,1,2,1)=0.0
CJ(3,1,2,2)=0.0
CJ(3,1,2,3)=0.0
CJ(3,1,2,4)=0.0
CJ(3,1,5,1) = wvel*CJ(3,1,4,1)
CJ(3,1,5,4)=0.0
CJ(3,2,2,1)=0.0
CJ(3,2,2,2)=0.0
CJ(3,2,2,3)=0.0
CJ(3,2,2,4)=0.0
CJ(3,3,2,1)=0.0
CJ(3,3,2,2)=0.0
CJ(3,3,2,3)=0.0
CJ(3,3,2,4)=0.0
CJ(3,3,5,1)=vvel*CJ(3,3,3,1) + wvel*CJ(3,3,4,1) - ckor2cv* &
&
(-re + (rv2 + rw2)*rinv)*reinv
CJ(3,3,5,2)=0.0
&
&
&
(2.*E - 3.*v2 - 3.*w2)*drdy
&
&
+2.*vvel*dmdy + 2.*wvel*dndy))*reinv
BJ(2,5,2)=vvel*BJ(2,3,2) + wvel*BJ(2,4,2) +
ckor2cv*dldy*reinv
BJ(2,5,3)=vvel*BJ(2,3,3) + wvel*BJ(2,4,3) + (-TAU(2,2)*rinv
&
&
- ckor2cv*(2.*vvel*drdy - dmdy))*reinv
BJ(2,5,4)=vvel*BJ(2,3,4) + wvel*BJ(2,4,4) + (-TAU(2,3)*rinv
&
&
- ckor2cv*(2.*wvel*drdy - dndy))*reinv
BJ(3,2,1)=0.0
BJ(3,2,2)=0.0
BJ(3,2,3)=0.0
BJ(3,2,4)=0.0
BJ(3,5,1)=vvel*BJ(3,3,1) + wvel*BJ(3,4,1) + (rinv*(vvel
&
&
*TAU(3,2) + wvel*TAU(3,3)) - ckor2cv*(-dedz
&
&
+ (2.*E - 3.*v2 - 3.*w2)*drdz + 2.*vvel*dmdz +
2.*wvel*&
&
dndz))*reinv
BJ(3,5,2)=vvel*BJ(3,3,2)+wvel*BJ(3,4,2) + ckor2cv*dldz*reinv
BJ(3,5,3)= vvel*bj(3,3,3) + wvel*bj(3,4,3) + &
&
(-tau(2,3)*rinv - ckor2cv*(-dmdz + 2.*vvel*drdz))*reinv
BJ(3,5,4)=vvel*BJ(3,3,4) + wvel*BJ(3,4,4) + (-TAU(3,3)*rinv
&
&
- ckor2cv*(2.*wvel*drdz - dndz))*reinv
CJ(1,1,3,1)=0.0
CJ(1,1,3,2)=0.0
CJ(1,1,3,3)=0.0
CJ(1,1,3,4)=0.0
CJ(1,1,4,1)=0.0
CJ(1,1,4,2)=0.0
CJ(1,1,4,3)=0.0
CJ(1,1,4,4)=0.0
CJ(1,1,5,1)=0.0
CJ(1,1,5,2)=0.0
!
Case(1,11,21,31,41) ! No-slip wall,u=v=w=0,T=Twall or
dT/dn = 0
!
aj(1:ndimn,1:nequa,1:nequa) = 0.0
!
AJ(1,2,5)=gamm1
43
elseif(ibndcnd==31.or.ibndcnd==41) then
CJ(2,2,5,1)=0.0
CJ(2,2,5,5)=0.0
endif
endif
AJ(2,3,5)=gamm1
aj(3,4,5) = gamm1
BJ(1,5,1)=-ckor2cv*(-dedx+2*E*drdx)*reinv
BJ(1,5,2)=ckor2cv*dldx*reinv
BJ(1,5,3)=ckor2cv*dmdx*reinv
bj(1,5,4)=ckor2cv*dndx*reinv
BJ(1,5,5)=ckor2cv*drdx*reinv
BJ(2,5,1)=-ckor2cv*(-dedy+2*E*drdy)*reinv
BJ(2,5,2)=ckor2cv*dldy*reinv
BJ(2,5,3)=ckor2cv*dmdy*reinv
BJ(2,5,4)=ckor2cv*dndy*reinv
BJ(2,5,5)=ckor2cv*drdy*reinv
BJ(3,5,1)=-ckor2cv*(-dedz+2*E*drdz)*reinv
BJ(3,5,2)=ckor2cv*dldz*reinv
BJ(3,5,3)=ckor2cv*dmdz*reinv
BJ(3,5,4)=ckor2cv*dndz*reinv
BJ(3,5,5)=ckor2cv*drdz*reinv
! -for no heat flux
if(adiabatic) then
if(ibndcnd==1) bj(3,5,:) = 0.0 ! perpendicular to z-axis
if(ibndcnd==11.or.ibndcnd==21) &
& bj(1,5,:) = 0.0
! perpendicular to x-axis
if(ibndcnd==31.or.ibndcnd==41) &
&
bj(2,5,:) = 0.0
! perpendicular ot y-axis
endif
!
CJ(1,1,5,1)=ckor2cv*re*reinv
CJ(1,1,5,2)=0.0
CJ(1,1,5,3)=0.0
CJ(1,1,5,4)=0.0
CJ(1,1,5,5)=-ckor2cv*r*reinv
CJ(1,2,5,1)=0.0
CJ(1,2,5,2)=0.0
CJ(1,2,5,3)=0.0
CJ(1,2,5,4)=0.0
CJ(1,3,5,1)=0.0
CJ(1,3,5,2)=0.0
CJ(1,3,5,4)=0.0
CJ(2,1,5,1)=0.0
CJ(2,1,5,2)=0.0
CJ(2,1,5,3)=0.0
CJ(2,1,5,4)=0.0
CJ(2,2,5,1)=CJ(1,1,5,1)
CJ(2,2,5,2)=0.0
CJ(2,2,5,3)=0.0
CJ(2,2,5,4)=0.0
CJ(2,2,5,5)=CJ(1,1,5,5)
CJ(2,3,5,1)=0.0
CJ(2,3,5,2)=0.0
CJ(2,3,5,3)=0.0
CJ(2,3,5,4)=0.0
CJ(3,1,5,1)=0.0
CJ(3,1,5,2)=0.0
CJ(3,1,5,4)=0.0
CJ(3,2,5,1)=0.0
CJ(3,2,5,3)=0.0
CJ(3,2,5,4)=0.0
CJ(3,3,5,1)=cj(1,1,5,1)
CJ(3,3,5,2)=0.0
CJ(3,3,5,3)=0.0
CJ(3,3,5,4)=0.0
CJ(3,3,5,5)=CJ(1,1,5,5)
! -for no heat flux
if(adiabatic) then
if(ibndcnd==1) then
CJ(3,3,5,1)=0.0
CJ(3,3,5,5)=0.0
elseif(ibndcnd==11.or.ibndcnd==21) then
CJ(1,1,5,1)=0.0
CJ(1,1,5,5)=0.0
!
Case(4,14) ! No-slip compression corner
! u=v=w=0, T=Twall or dT/dn =0
!
aj(1:ndimn,1:nequa,1:nequa) = 0.0
!
AJ(1,2,5)=gamm1
AJ(2,3,5)=gamm1
aj(3,4,5) = gamm1
BJ(1,5,1)=-ckor2cv*(-dedx+2*E*drdx)*reinv
BJ(1,5,2)=ckor2cv*dldx*reinv
BJ(1,5,3)=ckor2cv*dmdx*reinv
bj(1,5,4)=ckor2cv*dndx*reinv
BJ(1,5,5)=ckor2cv*drdx*reinv
BJ(2,5,1)=-ckor2cv*(-dedy+2*E*drdy)*reinv
BJ(2,5,2)=ckor2cv*dldy*reinv
BJ(2,5,3)=ckor2cv*dmdy*reinv
BJ(2,5,4)=ckor2cv*dndy*reinv
BJ(2,5,5)=ckor2cv*drdy*reinv
BJ(3,5,1)=-ckor2cv*(-dedz+2*E*drdz)*reinv
BJ(3,5,2)=ckor2cv*dldz*reinv
BJ(3,5,3)=ckor2cv*dmdz*reinv
BJ(3,5,4)=ckor2cv*dndz*reinv
BJ(3,5,5)=ckor2cv*drdz*reinv
!
CJ(1,1,5,1)=ckor2cv*re*reinv
CJ(1,1,5,2)=0.0
CJ(1,1,5,3)=0.0
CJ(1,1,5,4)=0.0
CJ(1,1,5,5)=-ckor2cv*r*reinv
CJ(1,2,5,1)=0.0
CJ(1,2,5,2)=0.0
CJ(1,2,5,3)=0.0
CJ(1,2,5,4)=0.0
CJ(1,3,5,1)=0.0
CJ(1,3,5,2)=0.0
CJ(1,3,5,4)=0.0
CJ(2,1,5,1)=0.0
CJ(2,1,5,2)=0.0
CJ(2,1,5,3)=0.0
CJ(2,1,5,4)=0.0
CJ(2,2,5,1)=CJ(1,1,5,1)
CJ(2,2,5,2)=0.0
CJ(2,2,5,3)=0.0
CJ(2,2,5,4)=0.0
CJ(2,2,5,5)=CJ(1,1,5,5)
CJ(2,3,5,1)=0.0
CJ(2,3,5,2)=0.0
CJ(2,3,5,3)=0.0
CJ(2,3,5,4)=0.0
CJ(3,1,5,1)=0.0
CJ(3,1,5,2)=0.0
CJ(3,1,5,4)=0.0
CJ(3,2,5,1)=0.0
CJ(3,2,5,3)=0.0
CJ(3,2,5,4)=0.0
CJ(3,3,5,1)=cj(1,1,5,1)
CJ(3,3,5,2)=0.0
CJ(3,3,5,3)=0.0
CJ(3,3,5,4)=0.0
CJ(3,3,5,5)=cj(1,1,5,5)
!
End Select
!
44
elseif(ibouncnd(jordr).eq.100) then ! u=v=0, T = Twall
ia = locnode(inode)
ja = locnode(jnode)
irow = nequa*(ia-1) + ir
icol = nequa*(ja-1) + is
jcol = icol - (ndimn + 1)
if(irow.ne.icol) then
Bel(ielem,irow,jcol) = Bel(ielem,irow,jcol) +
&
&
Bel(ielem,irow,icol)*cv*Twall
Bel(ielem,irow,icol) = 0.0
else
do kcol = 1,neleq
Bel(ielem,irow,kcol) = 0.0
enddo
Bel(ielem,irow,jcol) = -cv*Twall
Bel(ielem,irow,icol) = 1.0
if(ndimn==2) Bel(ielem,irow,icol) = 0.5
if(ndimn==3) Bel(ielem,irow,icol) = 0.25
rhs(iordr) = 0.0
endif
elseif(ibouncnd(jordr).eq.5) then ! Inviscid slip wall
ia = locnode(inode)
ja = locnode(jnode)
irow = nequa*(ia-1) + ir
icol = nequa*(ja-1) + is
jcol = icol - 1
ibpnt = lface(jnode+2,iface)
en1oven2 = -rbcon(2,ibpnt)/rbcon(1,ibpnt)
if(irow.ne.icol) then
Bel(ielem,irow,jcol) = Bel(ielem,irow,jcol) +
&
&
Bel(ielem,irow,icol)*en1oven2
Bel(ielem,irow,icol) = 0.0
else
do kcol = 1,neleq
Bel(ielem,irow,kcol) = 0.0
enddo
Bel(ielem,irow,jcol) = en1oven2
Bel(ielem,irow,icol) = 1.0
rhs(iordr) = 0.0
endif
endif
enddo
enddo
return
end subroutine jacbndcnd
!
!
*******************************************************
*******
! Subroutine to apply boundary conditions
!
Subroutine bc
(nnode,nordr,ndimn,ndbou,nequa,nface,neleq,nblock)
!
Use bnd_cnd
Use thermo_propt
Use grid_info
Use FDV_coef
Use bface_info
Implicit None
!
integer,intent(in) :: nnode,nordr,ndimn,ndbou,nequa,nface
integer,intent(in) :: neleq,nblock
integer :: iface,inode,ielem,ipoin,iordr,ir,jnode
integer :: jpoin,jordr,is,ia,ja,irow,icol,kcol
integer :: iblock,iel,iel0,ielast,nvec,i,iv
integer :: ibpnt,jcol
real :: en1oven2
!
integer :: locnode(ndbou)
real :: dloc(mbsize,meleq)
!
if(ndimn/=1) then
!
do iface = 1,nface
!
do inode = 1,ndbou
if(ndimn.eq.2) then
locnode(inode) = lface(inode+4,iface)
elseif(ndimn.eq.3) then
locnode(inode) = lfacnode(inode,iface)
endif
enddo
!
! Apply boundary conditions
!
ielem = lface(7,iface)
!
do inode = 1,ndbou
ipoin = lface(inode,iface)
do ir = 1,nequa
iordr = nequa*(ipoin-1) + ir
do jnode = 1,ndbou
jpoin = lface(jnode,iface)
do is = 1,nequa
jordr = nequa*(jpoin-1) + is
if(ibouncnd(jordr).lt.0) then ! Dirichlet bc
ia = locnode(inode)
ja = locnode(jnode)
irow = nequa*(ia-1) + ir
icol = nequa*(ja-1) + is
!
rhs(iordr) = rhs(iordr) - bel(ielem,irow,icol)*
! &
delu(jordr)
bel(ielem,irow,icol) = 0.0
if(irow.eq.icol) then
do kcol = 1,neleq
Bel(ielem,irow,kcol) = 0.0 ! Zero column
enddo
Bel(ielem,irow,icol) = 1.0 ! Diagonal
if(ndimn==2) Bel(ielem,irow,icol) = 0.5
if(ndimn==3) Bel(ielem,irow,icol) = 0.25
rhs(iordr) = 0.0
endif
!
enddo
enddo
!
enddo
!
endif
!
return
end subroutine bc
!
!
*******************************************************
*********
! THE FOLLOWING SUBROUTINE CALCULATES THE
ONE-D JACOBIAN MATRICES
! "A SUB I" FOR A SAMPLE POINT
!
! THESE MATRICES ARE FOR THE NAVIER-STOKES
SYSTEM OF EQUATION
! WITHOUT PRESSURE CORRECTIONS
!
SUBROUTINE
AJACOB1(velo,E,gamma,gamm1,gm3d2,gm1d2,gamm3,aj)
!
!DIR$ INLINEALWAYS AJACOB1
!
45
!
!
aj(1,4,2) = gamma*e-gm1d2*(3.*v11 + v22)
aj(1,4,3) =-gamm1*v12
aj(1,4,4) = gamma*v1
Use param_var
Use thermo_propt
!
Implicit None
real,intent(in) :: velo(mdimn),E
real,intent(in) :: gamma,gamm1,gm3d2,gm1d2,gamm3
real,intent(out),dimension(mdimn,mequa,mequa) :: aj
real :: v1,v11
!
!
aj(2,1,3) = 1.0
aj(2,2,1) =-v12
aj(2,2,2) = v2
aj(2,2,3) = v1
aj(2,3,1) = gm1d2*v11+gm3d2*v22
aj(2,3,2) =-gamm1*v1
aj(2,3,3) =-gamm3*v2
aj(2,3,4) = gamm1
aj(2,4,1) =-gamma*e*v2+gamm1*v2*v11p22
aj(2,4,2) =-gamm1*v12
aj(2,4,3) = gamma*e-gm1d2*(v11+3.*v22)
aj(2,4,4) = gamma*v2
Zero jacobian
aj = 0.0
!
v1 = velo(1)
v11 = v1*v1
!
aj(1,1,2)=1.0
aj(1,2,1)=GM3D2*v11
aj(1,2,2)=-GAMM3*v1
aj(1,2,3)=GAMM1
aj(1,3,1)=-GAMMA*E*v1+GAMM1*v1*v11
aj(1,3,2)=GAMMA*E-GM1D2*(3.*v11)
aj(1,3,3)=GAMMA*v1
!
RETURN
end subroutine AJACOB
!
*******************************************************
*******
! THE FOLLOWING SUBROUTINE CALCULATES THE "U"
VECTOR AND
! JACOBIANS AT THE GAUSSIAN POINT OF INTEREST
!
SUBROUTINE
EVALDOM(NEQUA,NDIMN,NNODE,IG,vloc,Eloc,Tloc,&
&
Uloc,Floc,phi,dshpdx, &
&
d2phidx,VELO,E,T,UNKN,DUDX,DTDX,DUNDX,CFLUX,&
&
DFJDXJ,d2tdx2,d2udx2)
!
Use param_var
!
Use flow_var
!
Use thermo_propt
!
Use Conv_flux
!
Use shap_fcns
!
Implicit None
!
integer,intent(in) :: nequa,ndimn,nnode,ig
real,intent(in),dimension(ndimn,nnode) :: vloc
real,intent(in),dimension(nnode) :: Eloc,Tloc
real,intent(in) :: Uloc(nnode,nequa),Floc(nnode,ndimn,nequa)
real,intent(in) ::
dshpdx(mdimn,mnode,mgaus),phi(mnode,mgaus)
real,intent(in) :: d2phidx(mdimn,mdimn,mnode,mgaus)
real,intent(out) :: T,E
real,intent(out) :: CFLUX(nDIMN,nEQUA)
REAL,intent(out) ::
DUNDX(nDIMN,nEQUA),unkn(nequa),velo(ndimn)
REAL,intent(out) :: DUDX(nDIMN,nDIMN),DTDX(nDIMN)
real,intent(out) :: DFJDXJ(nEQUA)
real,intent(out) :: d2tdx2(ndimn),d2udx2(ndimn,ndimn,ndimn)
real :: DFXDX(ndimn,nEQUA)
integer :: iequa,idimn,jdimn,kdimn,i,L,iordr
integer :: ipoin
!
T = 0.0
E=0.0
!
DO IEQUA = 1, NEQUA
UNKN(IEQUA) = 0.0
do idimn = 1,ndimn
DUNDX(IDIMN,IEQUA) = 0.0
enddo
ENDDO
!
DO IDIMN = 1, NDIMN
!
RETURN
end subroutine AJACOB1
!
!
*******************************************************
*********
! THE FOLLOWING SUBROUTINE CALCULATES THE
TWO-D JACOBIAN MATRICES
! "A SUB I" FOR A SAMPLE POINT
!
! THESE MATRICES ARE FOR THE NAVIER-STOKES
SYSTEM OF EQUATION
! WITHOUT PRESSURE CORRECTIONS
!
SUBROUTINE
AJACOB(velo,E,gamma,gamm1,gm3d2,gm1d2,gamm3,aj)
!
!DIR$ INLINEALWAYS AJACOB
!
Use param_var
! Use thermo_propt
!
Implicit None
real,intent(in) :: velo(mdimn),E
real,intent(in) :: gamma,gamm1,gm3d2,gm1d2,gamm3
real,dimension(mdimn,mequa,mequa),intent(out) :: aj
real :: v1,v2,v11,v12,v22,v11p22
!
! Zero Jacobian
aj = 0.0
!
v1 = velo(1)
v2 = velo(2)
v11 = v1*v1
v12 = v1*v2
v22 = v2*v2
v11p22 = v11 + v22
!
aj(1,1,2) = 1.0
aj(1,2,1) = gm3d2*v11+gm1d2*v22
aj(1,2,2) =-gamm3*v1
aj(1,2,3) =-gamm1*v2
aj(1,2,4) = gamm1
aj(1,3,1) =-v12
aj(1,3,2) = v2
aj(1,3,3) = v1
aj(1,4,1) =-gamma*e*v1+gamm1*v1*v11p22
46
enddo
enddo
VELO(IDIMN) = 0.0
DTDX(IDIMN) = 0.0
D2TDX2(IDIMN) = 0.0
DO JDIMN = 1,NDIMN
DUDX(IDIMN,JDIMN) = 0.0
DO KDIMN = 1,NDIMN
D2UDX2(IDIMN,JDIMN,KDIMN) = 0.0
ENDDO
ENDDO
ENDDO
!
RETURN
!
end subroutine evaldom
!
!
*******************************************************
***********
! THE FOLLOWING SUBROUTINE CALCULATES THE
JACOBIAN "B SUB I"
! FOR A SAMPLE POINT
!
SUBROUTINE
BJACOB(reinv,cv,VIS,HK,TAU,DUNDX,UNKN,VELO,e,bj)
!
!DIR$ INLINEALWAYS BJACOB
!
Use param_var
! Use thermo_propt
!
Implicit None
!
real,intent(in) :: reinv,vis,hk,e,cv
real,intent(in) ::
DUNDX(mdimn,MEQUA),VELO(MDIMN),UNKN(MEQUA)
real,intent(in) :: tau(mdimn,mdimn)
real,dimension(mdimn,mequa,mequa),intent(out) :: bj
real :: vislam,visr,denom,term1
real :: r,v1,v2,v11,v22,v11p22
real :: drdx,dldx,dmdx,dedx,drdy,dldy,dmdy,dedy
!
! Zero Jacobian
bj = 0.0
!
VISLAM=-2.*VIS/3.
visr=2.*vis+vislam
DENOM=1./UNKN(1)**2
TERM1=HK*DENOM/CV
!
r = unkn(1)
v1 = velo(1)
v2 = velo(2)
v11 = v1*v1
v22 = v2*v2
v11p22 = v11 + v22
!
drdx = dundx(1,1)
dldx = dundx(1,2)
dmdx = dundx(1,3)
dedx = dundx(1,4)
drdy = dundx(2,1)
dldy = dundx(2,2)
dmdy = dundx(2,3)
dedy = dundx(2,4)
!
bj(1,2,1)=(DENOM*(VISR*Dldx+VISLAM*Dmdy-2.*(visr*
&
&
v1*drdx+vislam*v2*drdy)))*reinv
bj(1,2,2)=VISR*drdx*DENOM*reinv
bj(1,2,3)=VISLAM*drdy*DENOM*reinv
bj(1,3,1)=(VIS*DENOM*(dldy+dmdx-2.*(v1*drdy+
&
&
v2*drdx)))*reinv
bj(1,3,2)=VIS*Drdy*DENOM*reinv
bj(1,3,3)=VIS*Drdx*DENOM*reinv
DO IEQUA =1, NEQUA
do idimn = 1,ndimn
DFJDXJ(IEQUA) = dfjdxj(iequa) +
DFXDX(idimn,IEQUA)
bj(1,4,1)=v1*bj(1,2,1)+v2*bj(1,3,1)+((v1*TAU(1,1)+v2*TAU(2,1))
/r &
&
-TERM1*(-dedx+(2.*E-3.* &
!
DO I=1,NNODE
E= E + Eloc(I)*PHI(I,IG)
T = T + Tloc(I)*PHI(I,IG)
!
DO IDIMN = 1,NDIMN
DO JDIMN = 1,NDIMN
DUDX(IDIMN,JDIMN)=DUDX(IDIMN,JDIMN) +
DSHPDX(JDIMN,I,IG) &
&
*Vloc(IDIMN,I)
DO KDIMN = 1,NDIMN
d2udx2(IDIMN,JDIMN,KDIMN) =
d2udx2(IDIMN,JDIMN,KDIMN) + &
&
d2phidx(JDIMN,KDIMN,i,ig)*vloc(IDIMN,I)
ENDDO
ENDDO
VELO(IDIMN)=VELO(IDIMN)+Vloc(IDIMN,I)*PHI(I,IG)
d2tdx2(IDIMN) = d2tdx2(idimn) +
d2phidx(idimn,idimn,i,ig)* &
&
Tloc(I)
DTDX(IDIMN)=DTDX(IDIMN)+DSHPDX(IDIMN,I,IG)*Tloc(I)
ENDDO
!
DO IEQUA = 1, NEQUA
UNKN(IEQUA)=UNKN(IEQUA)+Uloc(I,IEQUA)*PHI(I,IG)
do idimn = 1,ndimn
DUNDX(idimn,IEQUA) = DUNDX(idimn,IEQUA) +
DSHPDX(idimn,I,IG) &
&
*Uloc(I,IEQUA)
enddo
ENDDO
enddo
!
DO IEQUA = 1,NEQUA
DO I = 1, NDIMN
CFLUX(I,IEQUA) = 0.0
DFXDX(I,IEQUA) = 0.0
enddo
dfjdxj(iequa) = 0.0
enddo
!
DO IEQUA = 1, NEQUA
DO I = 1, NNODE
do idimn = 1,ndimn
DFXDX(idimn,IEQUA) =DFXDX(idimn,IEQUA) +
DSHPDX(idimn,I,ig)* &
&
Floc(I,idimn,IEQUA)
CFLUX(idimn,IEQUA) =
CFLUX(idimn,IEQUA)+PHI(I,ig)* &
&
Floc(I,idimn,IEQUA)
enddo
enddo
enddo
47
hkocv = hk/cv
&
v11-3.*v22)*drdx+2.*v1*dldx+2.*v2*dmdx))*reinv
bj(1,4,2)=v1*bj(1,2,2)+v2*bj(1,3,2)+(-TAU(1,1)/r&
&
TERM1*(2.*v1*drdx-dldx))*reinv
bj(1,4,3)=v1*bj(1,2,3)+v2*bj(1,3,3)+(-TAU(2,1)/r&
&
TERM1*(-dmdx+2.*v2*drdx))*reinv
bj(1,4,4)=TERM1*drdx*reinv
!
cj(1,1,2,1) = visr*rv1*denom*reinv
cj(1,1,2,2) = -visr/r*reinv
cj(1,1,3,1) = vis*rv2*denom*reinv
cj(1,1,3,3) = -vis/r*reinv
cj(1,1,4,1) =((visr*rv11*denom2+vis*rv22*denom2)
&
&
-hkocv*(-re*denom+(rv11p22)*denom2))*reinv
cj(1,1,4,2) =(-visr+hkocv)*rv1*denom*reinv
cj(1,1,4,3) =(-vis +hkocv)*rv2*denom*reinv
cj(1,1,4,4) = -hkocv/r*reinv
!
bj(2,2,1)=bj(1,3,1)
bj(2,2,2)=bj(1,3,2)
bj(2,2,3)=bj(1,3,3)
bj(2,3,1)=(DENOM*(VISLAM*(dldx+4.*v2*drdy)+VISR*
!
&
cj(1,2,2,1) = vislam*rv2*denom*reinv
cj(1,2,2,3) =-vislam/r*reinv
cj(1,2,3,1) = vis*rv1*denom*reinv
cj(1,2,3,2) =-vis/r*reinv
cj(1,2,4,1) =(vislam+vis)*rv12*denom2*reinv
cj(1,2,4,2) =-vis*rv2*denom*reinv
cj(1,2,4,3) =-vislam*rv1*denom*reinv
&
(v1*drdx+dmdy)))*reinv
bj(2,3,2)=VISLAM*drdx*DENOM*reinv
bj(2,3,3)=VISR*drdy*DENOM*reinv
bj(2,4,1)=v1*bj(2,2,1)+v2*bj(2,3,1)+((v1*TAU(1,2)+v2*TAU(2,2))
/r &
&
-TERM1*(-dedy+(2.*E-3.* &
&
v11-3.*v22)*drdy+2.*v1
&
&
*dldy+2.*v2*dmdy))*reinv
bj(2,4,2)=v1*bj(2,2,2)+v2*bj(2,3,2)+(-TAU(2,1)/r &
&
TERM1*(-dldy+2.*v1*drdy))*reinv
bj(2,4,3)=v1*bj(2,2,3)+v2*bj(2,3,3)+(-TAU(2,2)/r&
&
TERM1*(2.*v2*drdy-dmdy))*reinv
bj(2,4,4)=TERM1*drdy*reinv
!
RETURN
end subroutine bjacob
!
!
*******************************************************
*******
! THE FOLLOWING SUBROUTINE CALCULATES THE
JACOBIAN "C SUB IJ"
! ON A SAMPLE POINT
!
SUBROUTINE CJACOB(reinv,cv,VIS,HK,UNKN,cj)
!
!DIR$ INLINEALWAYS CJACOB
!
Use param_var
!
!
!
cj(2,1,2,1) = vis*rv2*denom*reinv
cj(2,1,2,3) =-vis/r*reinv
cj(2,1,3,1) = vislam*rv1*denom*reinv
cj(2,1,3,2) =-vislam/r*reinv
cj(2,1,4,1) =(vis+vislam)*rv12*denom2*reinv
cj(2,1,4,2) =-vislam*rv2*denom*reinv
cj(2,1,4,3) =-vis*rv1*denom*reinv
!
cj(2,2,2,1) = vis*rv1*denom*reinv
cj(2,2,2,2) =-vis/r*reinv
cj(2,2,3,1) = visr*rv2*denom*reinv
cj(2,2,3,3) =-visr/r*reinv
cj(2,2,4,1) =((vis*rv11*denom2+visr*rv22*denom2)
&
&
-hkocv*(-re*denom+rv11p22*denom2))*reinv
cj(2,2,4,2) =(-vis +hkocv)*rv1*denom*reinv
cj(2,2,4,3) =(-visr+hkocv)*rv2*denom*reinv
cj(2,2,4,4) =-hkocv/r*reinv
!
RETURN
end subroutine cjacob
!
!
*******************************************************
*****
! THE FOLLOWING SUBROUTINE CALCULATES THE
VISCOUS FLUX AT A
! NODAL POINT
!
SUBROUTINE
VISCFLX(reinv,TAU,HK,VIS,DUDX,DTDX,VELO,d2tdx2,d2udx
2,&
&
G,dgjdxj)
!
!DIR$ INLINEALWAYS VISCFLX
!
Use param_var
!
Implicit None
!
real,intent(in) :: reinv,hk,vis
real,intent(out) :: g(mdimn,mequa),dgjdxj(mequa)
REAL,intent(in) :: velo(mdimn)
real,intent(in) :: dudx(mdimn,mdimn),dtdx(mdimn)
real,intent(in) :: tau(mdimn,mdimn)
real,intent(in) :: d2tdx2(mdimn),d2udx2(mdimn,mdimn,mdimn)
real :: DG1DX1(MEQUA),DG2DX2(MEQUA)
real :: vis43,vis23
!
vis43 = 4./3.*vis
vis23 = 2./3.*vis
Use thermo_propt
Implicit None
real,intent(in) :: reinv,vis,hk,cv
real,intent(in) :: unkn(mequa)
real,dimension(mdimn,mdimn,mequa,mequa),intent(out) :: cj
real :: vislam,visr
real :: r,denom,denom2
real :: rv1,rv2,re,rv11,rv12,rv22,rv11p22,hkocv
!
!
Zero Jacobian
cj = 0.0
!
VISLAM=-2.*VIS/3.
visr=2.*vis+vislam
!
r
= unkn(1)
denom = 1./r**2
denom2 = denom/r
!
rv1 = unkn(2)
rv2 = unkn(3)
re
= unkn(4)
rv11 = rv1 * rv1
rv12 = rv1 * rv2
rv22 = rv2 * rv2
rv11p22 = rv11 + rv22
48
!
!
*******************************************************
****
! THE FOLLOWING SUBROUTINE CALCULATES THE
DIRECTION COSINES
! OF THE NORMAL VECTOR TO A CONTROL SURFACE
!
SUBROUTINE CALNORM(ilbou,DPIDX,W,EN)
!
Use param_var
Use bface_info
Use shapbou_2d
Use grid_info
!
Implicit None
!
integer,intent(in) :: ilbou(mnode)
real,intent(in) :: w(ngaus)
real,intent(out) :: dpidx(mdimn,2,ngaus),en(2,ngaus)
real :: DPDX(2),DPDY(2)
real :: DXDS(NGAUS),DYDS(NGAUS)
real :: XELEM(2),YELEM(2)
integer :: inode,igaus ! Loop Counters
real :: delx,dely,dl
!
DO INODE = 1, 2
XELEM(INODE) = X(1,ilbou(inode))
YELEM(INODE) = X(2,ilbou(inode))
enddo
!
DELX = XELEM(2) - XELEM(1)
DELY = YELEM(2) - YELEM(1)
!
IF(ABS(DELX).LT.1.0E-12) THEN
DPDX(1) = 0.0
DPDX(2) = 0.0
ELSE
DPDX(1) = -1.0/DELX
DPDX(2) = 1.0/DELX
ENDIF
!
IF(ABS(DELY).LT.1.0E-12) THEN
DPDY(1) = 0.0
DPDY(2) = 0.0
ELSE
DPDY(1) = -1.0/DELY
DPDY(2) = 1.0/DELY
ENDIF
!
DO IGAUS = 1, NGAUS
DXDS(IGAUS) = 0.0
DYDS(IGAUS) = 0.0
!
DO INODE = 1, 2
G(1,1)=0.0
G(1,2)=-TAU(1,1)*reinv
G(1,3)=-TAU(1,2)*reinv
G(1,4)=(-TAU(1,1)*VELo(1) - TAU(1,2)*VELo(2) HK*DTDX(1))*reinv
G(2,1)=0.0
G(2,2)=-TAU(2,1)*reinv
G(2,3)=-TAU(2,2)*reinv
G(2,4)=(-TAU(2,1)*VELO(1) - TAU(2,2)*VELO(2) HK*DTDX(2))*reinv
!
dG1DX1(1) = 0.0
DG1DX1(2) = (vis43*D2UDX2(1,1,1)+vis23*D2UDX2(2,1,2))*reinv
DG1DX1(3) = -vis*(D2UDX2(1,1,2)+D2UDX2(2,1,1))*reinv
DG1DX1(4) =
DG1DX1(2)*VELO(1)+DG1DX1(3)*VELO(2)+G(1,2)*DUDX(1,1
) &
&
+G(1,3)*DUDX(2,1)-HK*D2TDX2(1)*reinv
!
DG2DX2(1) = 0.0
DG2DX2(2) = -vis*(D2UDX2(1,2,2)+D2UDX2(2,1,2))*reinv
DG2DX2(3) = (vis43*D2UDX2(2,2,2)+vis23*D2UDX2(1,1,2))*reinv
DG2DX2(4) =
DG2DX2(2)*VELO(1)+DG2DX2(3)*VELO(2)+G(2,2)*DUDX(1,2
) &
&
+G(2,3)*DUDX(2,2)-HK*D2TDX2(2)*reinv
!
DGJDXJ(1) = DG1DX1(1) + DG2DX2(1)
DGJDXJ(2) = DG1DX1(2) + DG2DX2(2)
DGJDXJ(3) = DG1DX1(3) + DG2DX2(3)
DGJDXJ(4) = DG1DX1(4) + DG2DX2(4)
!
RETURN
end subroutine viscflx
!
!
*******************************************************
****
! Subroutine to multiply Jacobian Matrices
!
subroutine matxmult(ndimn,nequa,a,b,c)
!
!DIR$ INLINEALWAYS matxmult
!
Implicit None
!
integer,intent(in) :: ndimn,nequa
real,intent(in) :: a(ndimn,nequa,nequa), b(ndimn,nequa,nequa)
real,intent(out) :: c(ndimn,ndimn,nequa,nequa)
integer :: i,j,ir,is,iq ! Loop counters
!
c = 0.0
!
do i = 1, ndimn
do j = 1, ndimn
do ir = 1, nequa
do is = 1, nequa
do iq = 1, nequa
c(i,j,ir,is) = c(i,j,ir,is) + a(i,ir,iq)* &
&
b(j,iq,is)
enddo
enddo
enddo
enddo
enddo
!
return
end subroutine matxmult
DXDS(IGAUS)=DXDS(IGAUS)+dpxi(INODE,IGAUS)*XELEM(I
NODE)
DYDS(IGAUS)=DYDS(IGAUS)+dpxi(INODE,IGAUS)*YELEM(I
NODE)
enddo
!
!
write(*,50)igaus,dxds(igaus),dyds(igaus)
! 50 format(i4,2e16.8)
!
DL=SQRT(DXDS(IGAUS)**2+DYDS(IGAUS)**2)
!
!
write(*,55)dl
! 55 format(' DL = ',e16.8)
49
end subroutine Solve
!
!
*******************************************************
********
! Element-by-Element GMRES Equation Solver
!
Subroutine
GMRES_ebe(nelem,nnode,nequa,nordr,neleq,ndimn,igmres, &
&
iprecnd,nblock,itmax,epstol,tol,itime,iunit,&
ierr)
!
Use param_var
Use thermo_propt
Use FDV_coef, only: rhs,delu
Use grid_info
Use GMRES_var
Use bnd_cnd
!
Implicit None
!
integer,intent(in) :: nelem,nnode,nequa,nordr,ndimn,igmres
integer,intent(in) :: iprecnd,nblock,itmax,itime,iunit
integer,intent(in) :: neleq
real,intent(in) :: epstol
real,intent(inout) :: tol
integer,intent(out) :: ierr
!
integer :: iblock
!
integer :: iordr,iter,lflag
integer :: i,jiter,j,ig,jordr,n
integer :: status
! Allocatable array status, = 0 for success
!
real,dimension(nordr) :: Diag,Fbar
real :: Diag_m12(nordr) ! Diagonal**(-0.5)
!
real :: uloc(neleq),Fbl(neleq)
real :: H(igmres+1,igmres),beta(igmres+1,igmres+1)
real :: Ebar(igmres+1)
real :: utemp(nordr),u1temp(nordr)
real :: c(igmres),s(igmres)
real :: Error(nordr,igmres+1)
real :: y(igmres)
real :: rhsnorm,epsilon,resid,hnorm,r
real :: CvTw
real :: h1temp,h2temp
!
! print *, 'nordr = ',nordr
!
! initialize UNEW
!
do iordr = 1,nordr
if(ibouncnd(iordr).ge.0) &
& delu(iordr) = 0.0
enddo
!
! Apply preconditioning to matrix
!
Select Case(iprecnd)
Case(0)
call Au_product(nblock,nnode,nordr,nequa,neleq,delu,Fbar)
!
Case(1)
allocate(alu(nelem,neleq,neleq),stat=status)
if(status/=0) write(*,101) status
101 format('ALLOCATION FAILED, STAT = ',i8)
call LU_precond(nelem,neleq,nordr,nequa,nnode,nblock,Fbar)
!
Case(2)
!
EN(1,IGAUS)=DYDS(IGAUS)/DL
EN(2,IGAUS)=-DXDS(IGAUS)/DL
!
EN(1,IGAUS) = EN(1,IGAUS)*DL*w(igaus)
EN(2,IGAUS) = EN(2,IGAUS)*DL*w(igaus)
!
DO INODE = 1, 2
DPIDX(1,INODE,IGAUS) = DPDX(INODE)
DPIDX(2,INODE,IGAUS) = DPDY(INODE)
enddo
enddo
!
RETURN
end subroutine calnorm
!
!
*******************************************************
*********
! Subroutine to initiate Equation Solver routines
!
Subroutine
Solve(nblock,nelem,nnode,nequa,ndimn,nordr,neleq,epstol, &
&
tol,iprecnd,igmres,itime,itmax,iunit,omega,isolve, &
&
ierr)
!
Use flow_var
Use FDV_coef
Use grid_info
Use bnd_cnd
!
Implicit None
!
! Routine ebe_jacb - Jacobian Element-by-Element Solver
! Routine ebe_cgm - Element-by-Element Conjugate Gradient
Solver
!
integer,intent(in) :: nblock,nelem,nnode,nequa,ndimn,nordr
integer,intent(in) :: neleq
real,intent(in) :: epstol,tol,omega
integer,intent(in) :: iprecnd,igmres,itime,itmax,iunit,isolve
integer,intent(out) :: ierr
integer :: iordr,locatn
real :: delumax
!
if(isolve.eq.4)
&
& call
GMRES_ebe(nelem,nnode,nequa,nordr,neleq,ndimn,igmres,iprecnd,
&
&
nblock,itmax,epstol,tol,itime,iunit,ierr)
!
delumax = 0.0
!
do iordr = 1,nordr
if(ibouncnd(iordr).ge.0) then
if(abs(delu(iordr)).ge.delumax) then
delumax = delu(iordr)
locatn = iordr
endif
uold(iordr) = u(iordr)
u(iordr) = u(iordr) + delu(iordr)
endif
enddo
!
write(53,1000) itime,delumax,locatn
1000 format(' At time step ',i6,' Max Delu is ',e16.8, &
&
' at Equation ',i8)
!
return
50
&
call Diag_precond(nblock,nordr,neleq,nelem,nequa,nnode,
nnode,Fbar,Fbar)
!
&
&
if(iprecnd==4) call
SOR_Precond(nblock,nelem,neleq,nordr, &
nequa,nnode,Fbar)
endif
!
! Calculate initial residual
!
do iordr = 1,nordr
if(ibouncnd(iordr).lt.0) then
Error(iordr,1) = 0.0
else
Error(iordr,1) = rhs(iordr) - Fbar(iordr)
endif
utemp(iordr) = Error(iordr,1)
enddo
!
call el2norm(nordr,utemp,Ebar(1))
!
do iordr = 1,nordr
Error(iordr,1) = utemp(iordr)/Ebar(1)
enddo
!
!
write(45,*)(Error(iordr,1),iordr=1,nordr)
!
print *,'Ebar(1) = ',Ebar(1)
!
! Start of GMRES iteration
!
gmresloop: do i = 1,igmres
!
jiter = (iter-1)*igmres + i
!
do iordr = 1,nordr
utemp(iordr) = Error(iordr,i)
u1temp(iordr) = 0.0
enddo
!
call Au_product(nblock,nnode,nordr,nequa,neleq,utemp, &
&
u1temp)
!
! Preconditioning - Error(i+1) = (L-Inverse)*A*(UInverse)*Errbar
!
if(iprecnd.eq.1.or.iprecnd.eq.2)
&
&
call precond(nblock,nelem,neleq,nordr,nequa,nnode,&
&
u1temp,u1temp)
!
if(iprecnd==4) call
SOR_Precond(nblock,nelem,neleq,nordr, &
nequa,nnode,u1temp)
!
do iordr = 1,nordr
Error(iordr,i+1) = u1temp(iordr)
enddo
!
!
write(45,*)i,(Error(iordr,i+1), iordr=1,nordr)
!
! Modified Gram-Schmidt Orthogonalization
!
beta(i+1,1) = 0.0
do n = 1,nordr
beta(i+1,1) = beta(i+1,1) + Error(n,i+1)*Error(n,1)
enddo
!
do j = 1,i
beta(i+1,j+1) = 0.0
!
do iordr = 1,nordr
Error(iordr,i+1) = Error(iordr,i+1) - beta(i+1,j)* &
ndimn,Diag,Diag_m12,Fbar)
allocate(alu(nelem,neleq,neleq),stat=status)
if(status/=0) write(*,101) status
call LU_precond(nelem,neleq,nordr,nequa,nnode,nblock,Fbar)
!
Case(3)
call Diag_precond(nblock,nordr,neleq,nelem,nequa,nnode,
&
&
ndimn,Diag,Diag_m12,Fbar)
!
Case(4)
call Diag_precond(nblock,nordr,neleq,nelem,nequa,nnode,
&
&
ndimn,Diag,Diag_m12,Fbar)
call
SOR_Precond(nblock,nelem,neleq,nordr,nequa,nnode,Fbar)
call SOR_Precond(nblock,nelem,neleq,nordr,nequa,nnode,rhs)
End Select
!
if(itime.eq.1) write(iunit,125)igmres
write(iunit,150) itime
!
!
write(47,5000)(Fbar(iordr),iordr=1,nordr)
5000 format(4e16.8)
!
call el2norm(nordr,rhs,rhsnorm)
! print *,' RHSNORM = ',rhsnorm
!
epsilon = epstol*rhsnorm
tol = epsilon
lflag = 0
resid = 1.0
ierr = 0
!
iterloop: do iter = 1,itmax
!
if(iter.gt.1) then
call Au_product(nblock,nnode,nordr,nequa,neleq,delu,Fbar)
!
if(iprecnd>=2) then
!
do iordr = 1,nordr
if(ibouncnd(iordr).eq.100) then
jordr = iordr - (ndimn+1)
Fbar(iordr) = Diag_m12(iordr)*Diag_m12(iordr)* &
&
delu(iordr) - Diag_m12(iordr)*Cv* &
&
Twall*Diag_m12(jordr)*delu(jordr)
elseif(ibouncnd(iordr).eq.101) then
jordr = iordr - 1
Fbar(iordr) = Diag_m12(iordr)*Diag_m12(iordr)* &
&
delu(iordr) - Diag_m12(iordr)*
&
&
Diag_m12(jordr)*delu(jordr)
endif
enddo
!
else
!
do iordr = 1,nordr
if(ibouncnd(iordr).eq.100) then
Fbar(iordr) = delu(iordr) - Cv*Twall*delu(iordr - &
&
(nequa-1))
endif
enddo
!
endif
!
if(iprecnd.eq.1.or.iprecnd.eq.2)
&
&
call precond(nblock,nelem,neleq,nordr,nequa, &
51
enddo gmresloop
&
Error(iordr,j)
beta(i+1,j+1) = beta(i+1,j+1) + Error(iordr,i+1)* &
&
Error(iordr,j+1)
enddo
enddo
!
ig = igmres
!
405 continue
!
!
!
!
!
beta(i+1,i+1) = sqrt(beta(i+1,i+1))
!
hnorm = beta(i+1,i+1)
!
!
!
Solve for y by back Substitution
y(ig) = Ebar(ig)/H(ig,ig)
!
Build ith column of h
do i = ig-1,1,-1
do j = i+1,ig
Ebar(i) = Ebar(i) - H(i,j)*y(j)
enddo
y(i) = Ebar(i)/H(i,i)
enddo
do j = 1,i+1
h(j,i) = beta(i+1,j)
enddo
!
!
!
!
!
print *,j,' H(j+1,j) = ',h(j+1,j)
!
!
!
Check for convergence
Update Solution
do j = 1,ig
do iordr = 1,nordr
if(ibouncnd(iordr).ge.0) then
if(ibouncnd(iordr).eq.100) then
jordr = iordr - (ndimn+1)
if(h(i+1,i).le.tol) then
lflag = 1
ig = i
goto 305
endif
!
!
!
if(iprecnd>=2) then
CvTw = Diag(iordr)*Diag_m12(jordr)*cv*Twall
else
CvTw = cv*Twall
endif
do iordr = 1,nordr
Error(iordr,i+1) = Error(iordr,i+1)/H(i+1,i)
enddo
305 continue
!
!
!
!
delu(iordr) = CvTw*delu(jordr)
elseif(ibouncnd(iordr).eq.101) then
jordr = iordr - 1
Q-R Algorithm (Givens Rotations)
!
if(i.gt.1) then
!
do j = 1,i-1
&
!
h1temp = c(j)*H(j,i) + s(j)*H(j+1,i)
h2temp = -s(j)*H(j,i) + c(j)*H(j+1,i)
H(j,i) = h1temp
H(j+1,i) = h2temp
!
else
delu(iordr) = delu(iordr) + y(j)*Error(iordr,j)
endif
endif
enddo
enddo
!
enddo
!
endif
!
r = sqrt(H(i,i)*H(i,i) + H(i+1,i)*H(i+1,i))
c(i) = H(i,i)/r
s(i) = H(i+1,i)/r
!
!
!
!
!
!
!
!
H(i,i) = r
H(i+1,i) = 0.0
!
Ebar(i+1) = -s(i)*Ebar(i)
Ebar(i) = c(i)*Ebar(i)
write(iunit,200) iter,Ebar(ig+1),H(ig+1,ig)
write(iunit,200) iter,h(ig+1,ig),resid
Convergence Check
if(lflag.eq.1) then
ierr = 0
goto 1005
endif
!
write(iunit,200) jiter,abs(Ebar(i+1)),hnorm
!
!
!
if(iprecnd>=2) then
delu(iordr) = Diag(iordr)*Diag_m12(jordr)*
delu(jordr)
else
delu(iordr) = delu(jordr)
endif
!
Convergence Check
if(iter.eq.itmax) then
ierr = 2
write(6,100) iter,Ebar(ig+1)
write(6,100) iter,resid
endif
if(abs(Ebar(i+1)).le.tol) then
lflag = 1
ig = i
goto 405
endif
!
if(lflag.eq.1) goto 405
enddo iterloop
1005 continue
!
!
!
!
52
&
!
!
if(iprecnd>=2) then
do iordr = 1,nordr
delu(iordr) = delu(iordr)*Diag_m12(iordr)
enddo
endif
!
!
!
!
Back Substitution
do iblock = nblock+1,2,-1
iel = lblock(iblock-1)
iel0 = iel - 1
ielast = lblock(iblock) - 1
nvec = lblock(iblock) - iel
deallocate (alu,stat=status) ! Deallocating ALU Matrix
!
!
!
print *,' Forward reduction (global)'
call local(nnode,nordr,nequa,neleq,iel,ielast,z,zloc, &
&
'globaliz')
enddo
write(35,*)(delu(iordr), iordr = 1,nordr)
100 format(' FAILED TO CONVERGE IN ',i8,' CURRENT
RESIDUAL IS ', &
&
e16.8)
125 format(' ELEMENT-BY-ELEMENT GMRES SOLVER','
GMRES PARAMETER ', &
&
i8)
150 format(' ITERATION
RESIDUAL FOR TIME STEP ',i8)
200 format(i8,2e16.8)
!
return
end subroutine GMRES_ebe
!
!
*******************************************************
*********
! Subroutine to apply preconditioning for Conjugate Gradient
Algorithm
!
Subroutine precond(nblock,nelem,neleq,nordr,nequa,nnode,R,Z)
!
Use param_var
Use grid_info
Use GMRES_var
Use bnd_cnd
!
Implicit None
!
integer,intent(in) :: nblock,nelem,neleq,nordr,nequa,nnode
real,intent(in) :: R(nordr)
real,intent(out) :: Z(nordr)
!
integer :: iordr,iblock,iel,iel0,ielast,nvec,iv,i,j
!
real :: zloc(mbsize,neleq)
!
do iordr = 1,nordr
Z(iordr) = R(iordr)
enddo
!
! Forward reduction
!
do iblock = 1,nblock
iel = lblock(iblock)
iel0 = iel - 1
ielast = lblock(iblock+1) - 1
nvec = lblock(iblock+1) - iel
!
! print *,' Forward reduction (local)'
call local(nnode,nordr,nequa,neleq,iel,ielast,z,zloc, &
&
'localize')
!
do iv = 1,nvec
do i = 1,neleq
do j = 1,i-1
zloc(iv,i) = zloc(iv,i) - alu(iel0+iv,i,j)*zloc(iv,j)
enddo
enddo
enddo
!
!
!
print *,' Back Substitution (local)'
call local(nnode,nordr,nequa,neleq,iel,ielast,z,zloc,
&
'localize')
&
!
do iv = nvec,1,-1
zloc(iv,neleq) = zloc(iv,neleq)/alu(iel0+iv,neleq,neleq)
enddo
!
do i = neleq-1,1,-1
do j = i+1,neleq
do iv = nvec,1,-1
zloc(iv,i) = zloc(iv,i) - alu(iel0+iv,i,j)*zloc(iv,j)
enddo
enddo
!
do iv = nvec,1,-1
zloc(iv,i) = zloc(iv,i)/alu(iel0+iv,i,i)
enddo
!
enddo
!
!
print *,' Back Substitution (global)'
call local(nnode,nordr,nequa,neleq,iel,ielast,z,zloc, &
&
'globaliz')
!
enddo
!
return
end subroutine precond
!
!
*******************************************************
*******
! Subroutine to apply Diagonal preconditioning to stiffness matrix
!
Subroutine
Diag_precond(nblock,nordr,neleq,nelem,nequa,nnode, &
&
ndimn,Diag,Diag_m12,Fbar)
!
Use param_var
Use thermo_propt
Use grid_info
Use flow_var
Use FDV_coef,only: Bel,Delu,rhs
!
Use GMRES_var
Use bnd_cnd
!
Implicit None
!
integer,intent(in) :: nblock,nordr,neleq,nelem,nequa,nnode,ndimn
real,intent(out),dimension(nordr) :: Diag,Diag_m12
real,intent(inout) :: Fbar(nordr)
!
real :: Dloc(mbsize,meleq)
integer :: iordr,ipoin,iblock,i,j,iv,jordr
integer :: idimn,iel,iel0,ielast,nvec
!
53
!
!
!
Extract Diagonal of stiffness matrix for use in preconditioning
Bel(iel0+iv,i ,j ) = Bel(iel0+iv,i ,j )*
&
Diag = 0.0
&
!
do iblock = 1,nblock
iel = lblock(iblock)
iel0 = iel - 1
ielast = lblock(iblock+1) - 1
nvec = lblock(iblock+1) - iel
&
&
&
!
Dloc(iv,i )*Dloc(iv,j )
Bel(iel0+iv,i+1,j ) = Bel(iel0+iv,i+1,j )*
&
Dloc(iv,i+1)*Dloc(iv,j )
Bel(iel0+iv,i ,j+1) = Bel(iel0+iv,i ,j+1)*
&
Dloc(iv,i )*Dloc(iv,j+1)
Bel(iel0+iv,i+1,j+1) = Bel(iel0+iv,i+1,j+1)*
&
Dloc(iv,i+1)*Dloc(iv,j+1)
!
do i = 1,neleq
do iv = 1,nvec
enddo
enddo
enddo
enddo
!
dloc(iv,i) = Bel(iel0+iv,i,i)
enddo
enddo
!
call Au_product(nblock,nnode,nordr,nequa,neleq,delu,Fbar)
!
!
call local(nnode,nordr,nequa,neleq,iel,ielast,Diag,dloc, &
&
'add glob')
!
enddo
!
do iordr = 1,nordr
if(ibouncnd(iordr).lt.0.or.ibouncnd(iordr).eq.100.or.
& ibouncnd(iordr).eq.101) then
Diag(iordr) = 1.0
endif
enddo
&
&
&
&
&
!
do iordr = 1,nordr
!
do iordr = 1,nordr
if(ibouncnd(iordr).eq.100) then
jordr = iordr - (ndimn+1)
Fbar(iordr) = Diag_m12(iordr)*Diag_m12(iordr)* &
delu(iordr) - Diag_m12(iordr)*Cv* &
Twall*Diag_m12(jordr)*delu(jordr)
elseif(ibouncnd(iordr).eq.101) then
jordr = iordr - 1
Fbar(iordr) = Diag_m12(iordr)*Diag_m12(iordr)* &
delu(iordr) - Diag_m12(iordr)
&
*Diag_m12(jordr)*delu(jordr)
endif
enddo
!
!
1000 format(' WARNING: DIAGONAL FOR EQUATION ',I8,'
MAY BE NEGATIVE')
1100 format(' OCCURING AT NODE ',I8)
1200 format(' VALUE OF DIAGONAL IS ',e16.8)
1550 format(' VALUES OF DENSITY AND VELOCITY ARE:
',4(e12.6,1x))
!
return
end subroutine Diag_precond
!
!
*******************************************************
*******
! Subroutine to recover the local element components of a
assembled
! global vector
!
Subroutine local(nnode,nordr,nequa,neleq,iel,ielast,a,aloc, &
&
task)
!
!DIR$ INLINEALWAYS local
!
Use param_var
Use grid_info
!
Implicit None
!
integer,intent(in) :: nnode,nordr,nequa,neleq,iel,ielast
real,intent(inout) :: a(nordr),aloc(mbsize,neleq)
character(len=8),intent(in) :: task
integer :: k,inode,iequa,ielem,kel,ipoin,iordr
integer :: ieleq
!
! print *,'LOCAL input variable:
nnode,nordr,nequa,neleq,iel,ielast'
! print *,nnode,nordr,nequa,neleq,iel,ielast
!
Fbar(iordr) = 0.0
!
if(Diag(iordr).lt.0.0) then
write(*,1000)iordr
ipoin = 1 + (iordr-1)/nequa
write(*,1100)ipoin
write(*,1200)Diag(iordr)
write(*,1550) dense(ipoin),(vel(idimn,ipoin), &
&
idimn=1,ndimn)
!
Diag(iordr)=abs(Diag(iordr))
endif
!
Diag(iordr) = sqrt(Diag(iordr))
Diag_m12(iordr) = 1./Diag(iordr)
enddo
!
do iordr = 1,nordr
delu(iordr) = delu(iordr)*Diag(iordr)
rhs(iordr) = rhs(iordr)*Diag_m12(iordr)
enddo
!
do iblock = 1,nblock
iel = lblock(iblock)
iel0 = iel - 1
ielast = lblock(iblock+1) - 1
nvec = lblock(iblock+1) - iel
!
!
write(47,1500)iblock,iel,ielast,nvec
1500 format(' Block No.: ',i4,' IEL: ',i8,' IELast: ',i8, &
&
' NVEC: ',i8)
!
! print *,' Diagonal Preconditioning'
call local(nnode,nordr,nequa,neleq,iel,ielast,
&
&
Diag_m12,Dloc,'localize')
!
!
do iv = 1,nvec
do i = 1,neleq,2
do j = 1,neleq,2
54
!
!
!
!
if(task.eq.'localize') then
k=0
!
do inode=1,nnode
do iequa = 1,nequa
kel = 0
k = k+1
!
!
!
!
Subroutine to solve a system of equations of the form Lx = B
by Forward Substitution where L is a unit lower triangular
matrix and x and B are column vectors
Subroutine Fwdsubstn(n,L,B)
!
!DIR$ INLINEALWAYS Fwdsubstn
!
Implicit None
!
integer,intent(in) :: n
real,intent(in) :: L(n,n)
real,intent(inout) :: B(n)
integer :: i,j
!
do i = 1,n
do j = 1,i-1
B(i) = B(i) - L(i,j)*B(j)
enddo
enddo
!
return
end subroutine Fwdsubstn
!
!
*******************************************************
*****
! Subroutine to solve the system of equations Uy = B by backward
! substitution where U is a upper triangular matrix and y and B
! are column vectors
!
Subroutine Backsubstn(n,U,B)
!
!DIR$ INLINEALWAYS Backsubstn
!
Implicit None
!
integer,intent(in) :: n
real,intent(in) :: U(n,n)
real,intent(inout) :: B(n)
integer i,j
!
B(n) = B(n)/U(n,n)
!
do i = n-1,1,-1
do j = i+1,n
B(i) = B(i) - U(i,j)*B(j)
enddo
!
B(i) = B(i)/U(i,i)
!
enddo
!
return
end subroutine Backsubstn
!
!
*******************************************************
****
! Subroutine to perform LU Preconditioning on the system of
! equations
!
Subroutine
LU_precond(nelem,neleq,nordr,nequa,nnode,nblock,Fbar)
!
Use FDV_coef, only: Bel,rhs
Use GMRES_var
Use grid_info
!
Implicit None
if(inode==1.and.iequa==1)
&
write(41,*)nnode,nordr,nequa,neleq,iel,ielast
do ielem = iel,ielast
kel = kel + 1
ipoin = lnod(inode,ielem)
iordr = nequa*(ipoin-1) + iequa
aloc(kel,k) = a(iordr)
enddo
enddo
!
enddo
!
return
!
endif
!
if(task.eq.'globaliz') then
!
do ieleq = 1,neleq
inode = 1 + (ieleq-1)/nequa
!
kel = 0
do ielem = iel,ielast
kel = kel + 1
ipoin = lnod(inode,ielem)
iordr = nequa*(ipoin-1) + ieleq -(ieleq-1)/nequa*nequa
!
a(iordr) = aloc(kel,ieleq)
!
enddo
!
enddo
return
endif
!
if(task.eq.'add glob')then
!
!
do ieleq = 1,neleq
inode = 1 + (ieleq-1)/nequa
kel = 0
!
do ielem = iel,ielast
kel = kel + 1
ipoin = lnod(inode,ielem)
iordr = nequa*(ipoin-1) + ieleq -(ieleq-1)/nequa*nequa
!
a(iordr) = a(iordr) + aloc(kel,ieleq)
!
enddo
!
enddo
!
return
endif
!
end subroutine local
!
!
*******************************************************
****
55
Use param_var
Use grid_info
Use FDV_coef, only: Bel
!
!
!
!
!
!
integer,intent(in) :: nelem,neleq,nordr,nequa,nnode,nblock
real,intent(inout) :: Fbar(nordr)
integer :: i,j,ielem,iblock,iel,ielast,k
real rhsloc(neleq),tmp(neleq),uloc(neleq)
!
Implicit None
!
integer,intent(in) :: nblock,nelem,neleq,nordr,nequa,nnode
real,intent(inout) :: z(nordr)
Initialize alu to Bel
!
integer :: iblock,iel,iel0,ielast,nvec,iv,i,j
real :: zloc(mbsize,neleq),omega
do ielem = 1,nelem
do j = 1,neleq
do i = 1,neleq
if(i/=j) then
alu(ielem,i,j) = Bel(ielem,i,j)
else
!
! Relaxation Factor, Omega
!
omega = 0.75
!
! Forward Reduction, I-wE
!
do iblock = 1,nblock
iel = lblock(iblock)
iel0 = iel - 1
ielast = lblock(iblock+1) - 1
nvec = lblock(iblock+1) - iel
!
call local(nnode,nordr,nequa,neleq,iel,ielast,Z,zloc, &
'localize')
!
do iv = 1,nvec
do i = 2,neleq
do j = 1,i-1
zloc(iv,i) = zloc(iv,i) - omega*Bel(iel0+iv,i,j)*&
&zloc(iv,j)
enddo
enddo
enddo
!
call local(nnode,nordr,nequa,neleq,iel,ielast,Z,zloc, &
'globaliz')
!
enddo
!
! Backward Substitution, I-wF
!
do iblock = nblock+1,2,-1
iel = lblock(iblock-1)
iel0 = iel - 1
ielast = lblock(iblock) - 1
nvec = lblock(iblock) - iel
!
call local(nnode,nordr,nequa,neleq,iel,ielast,Z,zloc, &
'localize')
!
do iv = nvec,1,-1
do i = neleq-1,1,-1
do j = i+1,neleq
zloc(iv,i) = zloc(iv,i) - omega*Bel(iel0+iv,i,j)*&
&zloc(iv,j)
enddo
enddo
enddo
!
call local(nnode,nordr,nequa,neleq,iel,ielast,Z,zloc, &
'globaliz')
!
enddo
!
return
end subroutine SOR_Precond
!
!
alu(ielem,i,i) = 1.0
endif
! Winget Regularization
!
enddo
enddo
enddo
!
!
!
Perform LU Factorization
do iblock = 1,nblock
iel = lblock(iblock)
ielast = lblock(iblock+1) - 1
!
do ielem = iel,ielast
do i = 2,neleq
do k = 1,i-1
!
alu(ielem,i,k) = alu(ielem,i,k)/alu(ielem,k,k)
!
do j = k+1, neleq
alu(ielem,i,j) = alu(ielem,i,j)
&
- alu(ielem,i,k)*alu(ielem,k,j)
&
!
enddo
!
enddo
enddo
enddo
!
enddo
!
!
!
Apply preconditioning to RHS and Fbar
call precond(nblock,nelem,neleq,nordr,nequa,nnode,rhs,rhs)
!
call precond(nblock,nelem,neleq,nordr,nequa,nnode,Fbar,Fbar)
!
500 format(' Element No. ',i8,' Nodes: ',4i8)
return
end subroutine LU_precond
!
!
*******************************************************
***********
! Subroutine to apply Successive Overrelaxation Preconditioning
!
! Preconditioning matrix, M = (I-wE)*D*(I-wF), where -E is the
! strict-lower part of the stiffness matrix, -F is the strict-upper
! part of the stiffness matrix, and w is a relaxation factor
!
Subroutine
SOR_Precond(nblock,nelem,neleq,nordr,nequa,nnode,Z)
!
56
do i = 1,istart
do j = 1,neleq,2
u2loc(iv,i) = u2loc(iv,i) +
&
&
Bel(iel0+iv,i,j )*uloc(iv,j ) + &
Bel(iel0+iv,i,j+1)*uloc(iv,j+1)
enddo
enddo
enddo
!
*******************************************************
*******
! Subroutine to perform LU Factorization of a dense matrix
!
Subroutine LU_Fact(n,a)
!
Implicit None
!
integer,intent(in) :: n
integer i,j,k
real,intent(inout) :: a(n,n)
!
do i = 2,n
do k = 1,i-1
!
a(i,k) = a(i,k)/a(k,k)
!
do j = k+1, n
a(i,j) = a(i,j) - a(i,k)*a(k,j)
!
enddo
enddo
enddo
!
return
end subroutine LU_Fact
!
!
*******************************************************
********
! Subroutine to construct the product of the element stiffness
! matrices with a vector
!
Subroutine Au_product(nblock,nnode,nordr,nequa,neleq,u,u2)
!
Use param_var
Use grid_info
Use FDV_coef
!
Implicit None
!
integer,intent(in) :: nblock,nnode,nordr,nequa,neleq
real,intent(in) :: u(nordr)
real,intent(out) :: u2(nordr)
real :: uloc(mbsize,neleq), u2loc(mbsize,neleq)
integer :: iblock,iel,iel0,nvec,ielast,i,j,iv
integer :: istart
!
u2 = 0.0
! Zero Array
!
! print *,'nordr = ',nordr
!
do iblock = 1,nblock
iel = lblock(iblock)
iel0 = iel - 1
nvec = lblock(iblock + 1) - iel
ielast = lblock(iblock+1) - 1
!
u2loc = 0.0
! Zero matrix
!
! print *,' Au_Product (local)'
call local(nnode,nordr,nequa,neleq,iel,ielast,u,uloc, &
&
'localize')
!
! Preconditioning loops for loop unrolling
!
istart = MOD(neleq,4)
!
do iv = 1,nvec
!
!
do iv = 1,nvec
do i = istart+1,neleq,4
do j = 1,neleq,2
!
&
&
u2loc(iv,i) = u2loc(iv,i)
&
+ Bel(iel0+iv,i ,j )*uloc(iv,j ) &
+ Bel(iel0+iv,i ,j+1)*uloc(iv,j+1)
&
&
u2loc(iv,i+1) = u2loc(iv,i+1)
&
+ Bel(iel0+iv,i+1,j )*uloc(iv,j ) &
+ Bel(iel0+iv,i+1,j+1)*uloc(iv,j+1)
&
&
u2loc(iv,i+2) = u2loc(iv,i+2)
&
+ Bel(iel0+iv,i+2,j )*uloc(iv,j ) &
+ Bel(iel0+iv,i+2,j+1)*uloc(iv,j+1)
&
&
u2loc(iv,i+3) = u2loc(iv,i+3)
&
+ Bel(iel0+iv,i+3,j )*uloc(iv,j ) &
+ Bel(iel0+iv,i+3,j+1)*uloc(iv,j+1)
!
!
!
!
enddo
enddo
enddo
!
!
!
print *,'Au_Product (global)'
call local(nnode,nordr,nequa,neleq,iel,ielast,u2,u2loc, &
&
'add glob')
!
enddo
!
return
end subroutine Au_product
!
!
*******************************************************
*******
! Subroutine to assemble element stiffness matrices into a
! column vector for element-by-element solver
!
Subroutine
matx_vec(ielem,Num_Nodes,Num_Eqs,neleq,nelem,nordr, &
&
ND_CNCDNC,Bel,Delu,Fbar)
!
Implicit None
!
integer,intent(in) :: ielem,Num_Nodes,Num_Eqs,nelem,nordr
integer,intent(in) :: neleq
integer,intent(in) :: ND_CNCDNC(Num_Nodes)
real,intent(in) :: Bel(nelem,neleq,neleq),Delu(nordr)
real,intent(inout) :: Fbar(nordr)
!
real :: uloc(neleq)
integer :: k,inode,ipoin,iequa,iordr,irow,inode
integer :: icol
real :: sum
!
! convert global vector to local vector
!
k=0
57
do i = 1,n
sum = sum + a(i)*b(i)
enddo
!
do inode = 1,Num_Nodes
ipoin = ND_CNCDNC(inode)
do iequa = 1,Num_Eqs
iordr = Num_Eqs*(ipoin-1) + iequa
k=k+1
uloc(k) = delu(iordr)
enddo
enddo
!
DotProd = sum
!
return
end function DotProd
!
!
*******************************************************
*********
!
subroutine cnstwltmp(nboun,nface,nequa)
!
Use thermo_propt
Use grid_info
Use Bface_info
Use bnd_cnd
Use Flow_var
!
Implicit None
!
integer,intent(in) :: nboun,nface,nequa
integer :: iface,ielem,ibidx,inode,ibnod,ipoin,jordr
integer :: iordr
integer :: iboun
real :: cvtemp
!
! --- NO SLIP WALL BOUNDARY CONDITIONS.
!
do iface=1,nface
ielem=lface(7,iface)
ibidx=lface(8,iface)
!
!
! ... CONSTANT WALL TEMPERATURE B.C.
!
if(ibidx.eq.1.or.ibidx.eq.4) then
do inode=1,2
ibnod=lface(inode+2,iface)
ipoin=ibcon(1,ibnod)
jordr = nequa*(ipoin-1)
!
if(indbd(ipoin).ne.2) then
cvtemp = cv*twall
!
cvtemp=cv*2.6245
u(jordr+4)=u(jordr+1)*cvtemp
endif
!
enddo
endif
enddo
!
do iboun = 1,nboun
if(indbc(iboun).eq.15) then
ipoin = ibcon(1,iboun)
iordr = nequa*(ipoin-1) + 1
jordr = nequa*(ipoin-1) + 2
u(jordr) = u(iordr)
endif
enddo
!
return
end subroutine cnstwltmp
!
!
*******************************************************
******
! Subroutine to apply adiabatic wall boundary condition
!
do irow = 1,neleq
inode = 1 + (irow-1)/Num_Eqs
ipoin = ND_CNCDNC(inode)
iordr = Num_Eqs*(ipoin-1) + irow - (irow1)/Num_Eqs*Num_Eqs
sum = 0.0
do icol = 1,neleq
sum = sum + Bel(ielem,irow,icol)*uloc(icol)
!
enddo
!
Fbar(iordr) = Fbar(iordr) + sum
!
enddo
!
return
end subroutine matx_vec
!
!
*******************************************************
********
! Subroutine to calculate the L2NORM of a vector
!
Subroutine el2norm(n,a,b)
!
Implicit None
!
integer,intent(in) :: n
real,intent(in) :: a(n)
real,intent(out) :: b
integer :: i
real :: sum
!
sum = 0.0
!
do i = 1,n
sum = sum + a(i)*a(i)
enddo
!
b = sqrt(sum)
!
return
end subroutine el2norm
!
!
*******************************************************
*********
! Function to calculate the inner (or dot) product of two vectors
!
Real Function DotProd(n,a,b)
!
Implicit None
!
integer,intent(in) :: n
real,intent(in) :: a(n),b(n)
integer :: i
real :: sum
!
sum = 0.0
!
58
! THE FOLLOWING SUBROUTINE CHECKS FOR
CONVERGENCE AND CALCULATES
! THE RMS ERROR
!
SUBROUTINE RMSERR(npoin,nequa,dt,itime,ierr)
!
Use flow_var
Use FDV_coef
Use bnd_cnd
!
Implicit None
!
integer,intent(in) :: npoin,nequa,itime,ierr
real,intent(in) :: dt
real :: RMS(NEQUA)
real :: enum,denom
integer :: j,i,iordr,iequa
!
DO J=1,nequa
ENUM=0.0
DENOM=0.0
DO I=1,NPOIN
!
if(indbc(i).lt.0) cycle
iordr = nequa*(i-1)+j
if(ibouncnd(iordr).lt.0) cycle
ENUM=ENUM+delu(iordr)*delu(iordr)
DENOM=DENOM+Uold(iordr)*Uold(iordr)
enddo
!
if(denom.lt.1.0e-12) then
rms(j) = 0.0
else
RMS(J) = SQRT(ENUM/DENOM)
endif
!
enddo
PRINT 100, ITIME,IERR,dt
PRINT 200, (RMS(IEQUA), IEQUA = 1, NEQUA)
WRITE(21,300)ITIME,(RMS(IEQUA),IEQUA = 1, NEQUA)
!
if(ierr.ne.0) then
print 400, ierr
stop
endif
!
100 FORMAT(1X,'ITERATION NO. ',I8,2X, 'IERR = ',I8,' TIME
STEP = ', &
&
E14.6)
200 FORMAT(2X,6E12.4)
300 FORMAT(2X,I8,4(1X,E16.8))
400 format(1x,'POSSIBLE PROBLEM WITH SOLVER, IERR =
',i4)
RETURN
end subroutine rmserr
!
! -------------------------------------------------------------------!
subroutine
output(ifile,jfile,npoin,nelem,nboun,nface,nnode,nequa, &
&
ndimn,adap,ntime,ntstp,time,cfl,igmres,iprecnd, &
&
isolve,nvisc,ierrind,imppa,en,npold,artvis,
&
&
strem,nblock)
!
Use param_var
Use grid_info
Use flow_var
Use bface_info
Use bnd_cnd
Use thermo_propt
Use Var_parm
!
Subroutine aplboun(nface,nequa)
!
Use flow_var
Use grid_info
Use bface_info
Use bnd_cnd
!
Implicit None
!
integer,intent(in) :: nface,nequa
!
integer :: nodadj(2)
integer :: iface,ielem,ibidx,lnode,ibnod,ipoin
integer :: lnode1,ipp1,jordr,iordr,inode
real :: energy,cvtemp
!
do iface = 1,nface
ielem = lface(7,iface)
ibidx = lface(8,iface)
!
!
!
Determine adjacent nodes
lnode = lface(5,iface)
if(lnode.eq.1) then
nodadj(1) = 4
nodadj(2) = 3
elseif(lnode.eq.2) then
nodadj(1) = 1
nodadj(2) = 4
elseif(lnode.eq.3) then
nodadj(1) = 2
nodadj(2) = 1
elseif(lnode.eq.4) then
nodadj(1) = 3
nodadj(2) = 2
endif
!
&
if(ibidx.eq.1.or.ibidx.eq.11.or.ibidx.eq.21.or.ibidx.eq.2 &
.or.ibidx.eq.4) then
!
do inode = 1,2
ibnod = lface(inode+2,iface)
ipoin = ibcon(1,ibnod)
if(ibcon(2,ibnod).lt.0) cycle
if(ibcon(2,ibnod).ne.2.and.ibcon(3,ibnod).ne.2) cycle
lnode = lface(inode+4,iface)
lnode1 = nodadj(inode)
ipp1 = lnod(lnode1,ielem)
!
jordr = nequa*(ipp1-1)
iordr = nequa*(ipoin-1)
!
u(iordr+1) = u(jordr+1)
energy = u(jordr+4) - 0.5*(u(jordr+2)*u(jordr+2) &
+ u(jordr+3)*u(jordr+3))/u(jordr+1)
cvtemp = energy/u(jordr+1)
u(iordr+4) = u(iordr+1)*cvtemp
&
!
enddo
endif
!
enddo
!
return
end subroutine aplboun
!
!
*******************************************************
******
59
enddo
!
!
Implicit None
if(ndimn.gt.1) then
write(ifile,2080)
do iface=1,nface
write(ifile,1080) (lface(j,iface),j=1,8)
if(ndimn.eq.3) write(ifile,1080) (lfacnode(j,iface),j=1,8)
enddo
endif
!
integer,intent(in) :: ifile,jfile,npoin,nelem,nboun,nface,nnode
integer,intent(in) :: nequa,ndimn,ntime,igmres,iprecnd,isolve
integer,intent(in) :: nvisc,ierrind,imppa,npold,nblock
integer,intent(in) :: ntstp
real,intent(in) :: time,cfl,en
logical,intent(in) :: adap,artvis,strem
integer :: ielem,ipoin,iordr,idimn,iboun,j,iface,iblock
integer :: inode,jpoin
integer :: lflag
!
!
!
!
!
!
!
write(ifile,3000)
write(ifile,1020) nblock,(lblock(iblock),iblock=1,nblock+1)
!
write(ifile,2001)
write(ifile,1001)ntstp,adap,remesh,incom,artvis
write(ifile,2003)
write(ifile,1060)nvisc,isolve,ierrind,iprecnd,artvis,imppa
write(ifile,2000)
write(ifile,1000) ntime,ntstp,time,adap,igmres
write(ifile,2090)
write(ifile,1090) cfl,s1,s2,s3,s4
write(ifile,2002)
write(ifile,1002) igeom, dimcorn,endcorn,alpa
write(ifile,2095)
write(ifile,1095) cmach,creyn,tinf,twall
write(ifile,2096)
write(ifile,1096) en,strem,alpa
write(ifile,2005)
write(ifile,1005) nnode, nequa, ndimn
write(ifile,2010)
if(ndimn.ne.3) then
write(ifile,1010) nelem,npoin,nboun,nface,imax,jmax
else
write(ifile,1011) nelem,npoin,nboun,nface,imax,jmax,kmax
endif
if(iacnt.eq.1.or.iacnt.eq.2) write(ifile,'(i10)') npold
close(ifile,status='keep')
!
! --- WRITE WALL PRESSURE, SKIN FRICTION
COEFFICIENT, AND HEAT TRANSFER
!
if(ndimn.eq.2) then
!
call wallpropt(jfile,nelem,nface,nboun,npoin,lnod)
endif
!
if(ndimn.eq.3) then
call wallpres3d(jfile,nboun)
!
!
call skinfric3d(nface,nboun,npoin,lnod)
endif
!
close(jfile,status='keep')
!
1000 format(2i8,e20.10,L7,i8)
1001 format(i7,4L7)
1002 format(i10,3e18.8)
1005 format(3i8)
1010 format(6i8)
1011 format(7i8)
1020 format(9i8)
1030 format(i8,3e18.8)
1040 format(i8,5e18.8)
1050 format(3i8,3e18.8)
1060 format(4i8,L7,i8)
1070 format(8i8)
1080 format(8i9)
1090 format(5f12.6)
1095 format(e16.8,3e18.8)
1096 format(f10.6,L7,e16.8)
6005 format(' x
P/Pinf
Pressure Coefficient')
6010 format(f10.5,f10.5,f10.6)
6500 format(6f10.5)
!
2000 format('ntime ntstp time adap igmres ')
2001 format(' ntstp adap remesh incom artvis')
2002 format(' igeom dimcorn endcorn angle')
2003 format('nvisc isolve ierrind iprecnd artvis imppa')
2005 format(' nnode nequa ndimn')
2010 format('nelem npoin nboun nface imax jmax')
2020 format('element and nodes distribution')
2030 format('x & y coordinates of each point')
2040 format('calculated unknown variables')
2050 format(' boundary conditions')
2060 format(' Adaptive Mesh Information')
2070 format(' hanging nodes')
2080 format(' boundary surfaces information')
2090 format(' cfl# s1 s2 s3 s4')
2095 format(' mach# Reynolds# Temp(inf) Twall')
2096 format(' Exponent for Implicitness Parameters
strm ')
3000 format(' Element Block Information')
if(adap) write(ifile,'(i10)') npold
!
write(ifile,2020)
do ielem=1,nelem
write(ifile,1020) ielem,(lnod(inode,ielem),inode=1,nnode)
enddo
!
write(ifile,2030)
do ipoin=1,npoin
write(ifile,1030) ipoin,(X(idimn,ipoin),idimn=1,ndimn)
enddo
!
write(ifile,2040)
do ipoin=1,npoin
iordr = nequa*(ipoin-1) + 1
dense(ipoin)=u(iordr)
do idimn = 1,ndimn
vel(idimn,ipoin)=u(iordr+idimn)/u(iordr)
enddo
energ(ipoin)=u(iordr+ndimn+1)/u(iordr)
write(ifile,1040) ipoin,dense(ipoin),(vel(idimn,ipoin),
&
idimn=1,ndimn),energ(ipoin)
enddo
&
!
write(ifile,2050)
do iboun=1,nboun
if(ndimn.lt.3) then
&
write(ifile,1050) (ibcon(j,iboun),j=1,3),
(rbcon(j,iboun),j=1,ndimn)
else
write(ifile,1005) (ibcon(j,iboun),j=1,3)
endif
&
60
s4poi(ipoin)=s4poi(ipoin)/float(npnum(ipoin))
s3pcoi(ipoin)=s3pcoi(ipoin)/float(npnum(ipoin))
s4pcoi(ipoin)=s4pcoi(ipoin)/float(npnum(ipoin))
write(ifile,1000)ipoin,s1poi(ipoin),s2poi(ipoin), &
&
s3poi(ipoin),s4poi(ipoin)
if(ifile.eq.11)
&
& write(51,1000)ipoin,s3poi(ipoin),s4poi(ipoin), &
&
s3pcoi(ipoin),s4pcoi(ipoin)
enddo
!
return
end subroutine output
!
! -------------------------------------------------------------------!
subroutine outimp(ifile,nelem,npoin,nnode,npold,adap)
!
Use grid_info
Use Var_parm
!
Implicit None
!
integer,intent(in) :: ifile,nelem,npoin,nnode,npold
!
logical,intent(in) :: adap
integer,allocatable,dimension(:) :: npnum
real,allocatable,dimension(:) :: s1poi,s3poi
real,allocatable,dimension(:) :: s2poi,s4poi
real,allocatable,dimension(:) :: s3pcoi,s4pcoi
integer :: npoi1,ipoin,ielem,jnode
integer :: status
!
npoi1 = npoin
if(adap.and.mdimn>1) npoi1 = npold
!
allocate(npnum(npoi1),STAT=status)
allocate(s1poi(npoi1),s2poi(npoi1),s3poi(npoi1),stat=status)
allocate(s4poi(npoi1),s3pcoi(npoi1),s4pcoi(npoi1),stat=status)
!
do ipoin=1,npoi1
npnum(ipoin)=0
s1poi(ipoin)=0.0
s3poi(ipoin)=0.0
s2poi(ipoin)=0.0
s4poi(ipoin)=0.0
s3pcoi(ipoin) = 0.0
s4pcoi(ipoin) = 0.0
enddo
!
if(ifile.eq.11)
&
& open(unit=31,file='imp_ele.out')
if(ifile.eq.11)
&
& open(unit=51,file='diff_var.out')
do ielem=1,nelem
if(ifile.eq.11) then
write(31,1000)ielem, s1ele(ielem), s2ele(ielem), &
&
s3ele(ielem), s4ele(ielem)
endif
!
do jnode=1,nnode
ipoin=lnod(jnode,ielem)
npnum(ipoin)=npnum(ipoin)+1
s1poi(ipoin)=s1poi(ipoin)+s1ele(ielem)
s2poi(ipoin)=s2poi(ipoin)+s2ele(ielem)
s3poi(ipoin)=s3poi(ipoin)+s3ele(ielem)
s4poi(ipoin)=s4poi(ipoin)+s4ele(ielem)
s3pcoi(ipoin) = s3pcoi(ipoin)+s3pec(ielem)
s4pcoi(ipoin) = s4pcoi(ipoin)+s4pec(ielem)
enddo
enddo
!
npoi1 = npoin
if(adap.and.mdimn>1) npoi1 = npold
do ipoin=1,npoi1
if(npnum(ipoin).eq.0) write(*,1100) ipoin
s1poi(ipoin)=s1poi(ipoin)/float(npnum(ipoin))
s2poi(ipoin)=s2poi(ipoin)/float(npnum(ipoin))
s3poi(ipoin)=s3poi(ipoin)/float(npnum(ipoin))
!
deallocate(npnum,STAT=status)
deallocate(s1poi,s2poi,s3poi,s4poi,s3pcoi,s4pcoi,stat=status)
!
1000 format(i8,2x,4f16.8)
1100 format(' NPNUM at point ',i8,' is zero')
!
close(ifile,status='keep')
!
return
end subroutine outimp
!
!
*******************************************************
********
! Subroutine to print wall pressure for Three-Dimensional
Problems
!
Subroutine wallpres3d(jfile,nboun)
!
Use grid_info
Use bnd_cnd
Use flow_var
!
Implicit None
!
integer,intent(in) :: jfile,nboun
integer :: iboun,ipoin,kpoin
real,dimension(nboun) :: relx,rely,relp,cp
!
write(jfile,1000)
!
kpoin = 0
!
do iboun = 1,nboun
if(ibcon(2,iboun).eq.1.or.ibcon(2,iboun).eq.4) then
ipoin = ibcon(1,iboun)
kpoin = kpoin + 1
relx(kpoin) = x(1,ipoin)
rely(kpoin) = x(2,ipoin)
relp(kpoin) = press(ipoin)/press(1)
cp(kpoin) = 2.*(press(ipoin) - press(1))
endif
enddo
!
call quick_sort_2d(kpoin,relx,rely,relp,cp)
!
do ipoin = 1,kpoin
write(jfile,1005) relx(ipoin),rely(ipoin),relp(ipoin),cp(ipoin)
enddo
!
close(jfile,status='keep')
!
1000 format(' X
Y
P/Pinf Pressure Coefficient' &
&
)
1005 format(4(f12.8,1x))
!
return
end subroutine wallpres3d
!
61
DO
j=j-1
IF (x(j) <= reference) EXIT
END DO
!
*******************************************************
**********
! Subroutine to sort the output for WALLPRES3D (sorted along Y
at
!
constant x)
!
Recursive Subroutine quick_Sort_2d(npoin,x,y,a1,a2)
!
Implicit None
!
integer,intent(in) :: npoin
real,dimension(npoin),intent(inout) :: x,y,a1,a2
integer :: icoun,ipoin,ip1
!
! sort in X-direction first
!
! Local variable
!
integer :: icoun,icoun1,j,left,right
real :: xref
!
CALL quick_sort_x(1, npoin)
!
! Sort in Y-direction
!
icoun = 0
do
icoun = icoun + 1
if(icoun>=npoin) exit
xref = x(icoun)
left = icoun
icoun1 = icoun + 1
do j = icoun1,npoin
if(abs(x(j)-xref)>1.0e-08) exit
icoun = icoun + 1
enddo
right = icoun
call quick_sort_y(left,right)
!
end do
!
CONTAINS
!
RECURSIVE SUBROUTINE quick_sort_x(left_end, right_end)
!
INTEGER, INTENT(IN) :: left_end, right_end
!
! Local variables
INTEGER
:: i, j
REAL
:: reference
real :: xtemp,ytemp,a1temp,a2temp
INTEGER, PARAMETER :: max_simple_sort_size = 6
!
IF (right_end < left_end + max_simple_sort_size) THEN
! Use interchange sort for small lists
CALL interchange_sort_x(left_end, right_end)
!
ELSE
! Use partition ("quick") sort
reference = x((left_end + right_end)/2)
i = left_end - 1; j = right_end + 1
!
DO
! Scan list from left end until element >= reference is found
DO
i=i+1
IF (x(i) >= reference) EXIT
END DO
! Scan list from right end until element <= reference is found
!
IF (i < j) THEN
! Swap two out-of-order elements
xtemp = x(i); x(i) = x(j); x(j) = xtemp
ytemp = y(i); y(i) = y(j); y(j) = ytemp
a1temp = a1(i); a1(i) = a1(j); a1(j) = a1temp
a2temp = a2(i); a2(i) = a2(j); a2(j) = a2temp
ELSE IF (i == j) THEN
i=i+1
EXIT
ELSE
EXIT
END IF
END DO
!
IF (left_end < j) CALL quick_sort_x(left_end, j)
IF (i < right_end) CALL quick_sort_x(i, right_end)
END IF
END SUBROUTINE quick_sort_x
SUBROUTINE interchange_sort_x(left_end, right_end)
!
INTEGER, INTENT(IN) :: left_end, right_end
!
! Local variables
INTEGER
:: i, j
REAL
:: xtemp,ytemp,a1temp,a2temp
!
DO i = left_end, right_end - 1
DO j = i+1, right_end
IF (x(i) > x(j)) THEN
xtemp = x(i); x(i) = x(j); x(j) = xtemp
ytemp = y(i); y(i) = y(j); y(j) = ytemp
a1temp = a1(i); a1(i) = a1(j); a1(j) = a1temp
a2temp = a2(i); a2(i) = a2(j); a2(j) = a2temp
END IF
END DO
END DO
!
END SUBROUTINE interchange_sort_x
!
RECURSIVE SUBROUTINE quick_sort_y(left_end, right_end)
!
INTEGER, INTENT(IN) :: left_end, right_end
!
! Local variables
INTEGER
:: i, j
REAL
:: reference
real :: xtemp,ytemp,a1temp,a2temp
INTEGER, PARAMETER :: max_simple_sort_size = 6
!
IF (right_end < left_end + max_simple_sort_size) THEN
! Use interchange sort for small lists
CALL interchange_sort_x(left_end, right_end)
!
ELSE
! Use partition ("quick") sort
reference = y((left_end + right_end)/2)
i = left_end - 1; j = right_end + 1
!
DO
! Scan list from left end until element >= reference is found
DO
i=i+1
62
integer :: kflag(npoin)
real :: cf(nboun),heatrt(nboun)
real :: relx(nboun),relp(nboun),cp(nboun)
IF (y(i) >= reference) EXIT
END DO
! Scan list from right end until element <= reference is found
DO
j=j-1
IF (y(j) <= reference) EXIT
END DO
!
integer :: ipoin,kpoin,iface,ielem,ibidx,inode,ibnod,lnode
integer :: ipp1,jpp1,kpp1
real :: dy,dudy,dtdy,cvisc,ccond,en1,en2,tan_a
real :: dx,y1,ydiff1,ydiff2,udif,tdif,ucalc,tcalc
real :: dudn,dtdn,dudx,dtdx
!
IF (i < j) THEN
! Swap two out-of-order elements
xtemp = x(i); x(i) = x(j); x(j) = xtemp
ytemp = y(i); y(i) = y(j); y(j) = ytemp
a1temp = a1(i); a1(i) = a1(j); a1(j) = a1temp
a2temp = a2(i); a2(i) = a2(j); a2(j) = a2temp
ELSE IF (i == j) THEN
i=i+1
EXIT
ELSE
EXIT
END IF
END DO
!
do ipoin = 1, npoin
kflag(ipoin) = 0
enddo
!
kpoin = 0
!
do iface = 1,nface
ielem=lface(7,iface)
ibidx=lface(8,iface)
!
if(ibidx.eq.1) then
do inode=1,2
ibnod = lface(inode+2,iface)
ipoin = ibcon(1,ibnod)
if(kflag(ipoin).eq.0) then
kpoin = kpoin + 1
relx(kpoin) = x(1,ipoin)
relp(kpoin) = press(ipoin)/press(1)
cp(kpoin) = 2.*(press(ipoin) - press(1))
lnode=lface(inode+4,iface)
if(lnode.eq.1) ipp1=lpoin(4,ielem)
if(lnode.eq.2) ipp1=lpoin(3,ielem)
dy=x(2,ipp1)-x(2,ipoin)
dudy=(vel(1,ipp1)-vel(1,ipoin))/dy
dtdy=(tempr(ipp1)-tempr(ipoin))/dy
if(tempr(ipoin)<1.0e-12) then
cvisc = 1.0
else
cvisc=(1.0+csuth)/(tempr(ipoin)+csuth)* &
&
tempr(ipoin)**1.5
endif
ccond=cvisc/gm1m2pr
cf(kpoin)=2.*cvisc*dudy/creyn
heatrt(kpoin)=2.*ccond*dtdy/creyn
kflag(ipoin) = 1
!
IF (left_end < j) CALL quick_sort_y(left_end, j)
IF (i < right_end) CALL quick_sort_y(i, right_end)
END IF
END SUBROUTINE quick_sort_y
SUBROUTINE interchange_sort_y(left_end, right_end)
!
INTEGER, INTENT(IN) :: left_end, right_end
!
! Local variables
INTEGER
:: i, j
REAL
:: xtemp,ytemp,a1temp,a2temp
!
DO i = left_end, right_end - 1
DO j = i+1, right_end
IF (y(i) > y(j)) THEN
xtemp = x(i); x(i) = x(j); x(j) = xtemp
ytemp = y(i); y(i) = y(j); y(j) = ytemp
a1temp = a1(i); a1(i) = a1(j); a1(j) = a1temp
a2temp = a2(i); a2(i) = a2(j); a2(j) = a2temp
END IF
END DO
END DO
!
END SUBROUTINE interchange_sort_y
!
END SUBROUTINE quick_sort_2d
!
!
*******************************************************
********
! The following subroutine calculates the skin friction at the wall
!
subroutine wallpropt(jfile,nelem,nface,nboun,npoin,lpoin)
!
Use param_var
Use grid_info
Use thermo_propt
Use bnd_cnd
Use flow_var
Use bface_info
!
Implicit None
!
integer,intent(in) :: jfile,nelem,nface,nboun,npoin
integer,intent(in) :: lpoin(mnode,melem)
!
endif
!
enddo
!
elseif(ibidx.eq.4) then
inode = 2
ibnod = lface(inode+2,iface)
ipoin = ibcon(1,ibnod)
!
kpoin = kpoin + 1
relx(kpoin) = x(1,ipoin)
relp(kpoin) = press(ipoin)/press(1)
cp(kpoin) = 2.*(press(ipoin) - press(1))
!
ipp1=lpoin(3,ielem)
en1 = -rbcon(2,ibnod)
en2 = rbcon(1,ibnod)
tan_a = rbcon(1,ibnod)/rbcon(2,ibnod)
ipp1 = lpoin(3,ielem)
jpp1 = lpoin(4,ielem)
kpp1 = lpoin(1,ielem)
dy = x(2,ipp1) - x(2,ipoin)
dx = x(1,ipoin) - x(1,kpp1)
dudy=(vel(1,ipp1)-vel(1,ipoin))/dy
63
dtdy=(tempr(ipp1)-tempr(ipoin))/dy
if(tempr(ipoin)<1.0e-12) then
cvisc = 1.0
else
cvisc=(1.0+csuth)/(tempr(ipoin)+csuth)*
&
tempr(ipoin)**1.5
endif
ccond=cvisc/gm1m2pr
y1 = x(2,kpp1) + dx*tan_a
ydiff1 = y1 - x(2,kpp1)
ydiff2 = x(2,jpp1) - x(2,kpp1)
udif = vel(1,jpp1) - vel(1,kpp1)
tdif = tempr(jpp1) - tempr(kpp1)
ucalc = vel(1,kpp1) + ydiff1/ydiff2*udif
tcalc = tempr(kpp1) +ydiff1/ydiff2*tdif
dudx = (vel(1,ipoin) - ucalc)/dx
dtdx = (tempr(ipoin) - tcalc)/dx
dudn = dudx*en1 + dudy*en2
dtdn = dtdx*en1 + dtdy*en2
cf(kpoin) = 2.*cvisc*dudn/creyn
heatrt(kpoin) = 2.*ccond*dtdn/creyn
kflag(ipoin) = 1
endif
enddo
! Local variable
INTEGER :: i
CALL quick_sort_1(1, npoin)
&
CONTAINS
RECURSIVE SUBROUTINE quick_sort_1(left_end, right_end)
INTEGER, INTENT(IN) :: left_end, right_end
! Local variables
INTEGER
:: i, j
REAL
:: reference
real :: xtemp,a1temp,a2temp,a3temp,a4temp
INTEGER, PARAMETER :: max_simple_sort_size = 6
IF (right_end < left_end + max_simple_sort_size) THEN
! Use interchange sort for small lists
CALL interchange_sort(left_end, right_end)
ELSE
! Use partition ("quick") sort
reference = x((left_end + right_end)/2)
i = left_end - 1; j = right_end + 1
!
call quick_sort(kpoin,relx,relp,cp,cf,heatrt)
!
DO
! Scan list from left end until element >= reference is found
DO
i=i+1
IF (x(i) >= reference) EXIT
END DO
! Scan list from right end until element <= reference is found
DO
j=j-1
IF (x(j) <= reference) EXIT
END DO
write(jfile,2000)
write(jfile,1000) cmach,creyn,tinf,twall
write(jfile,2010)
write(jfile,1010) nelem,npoin,nboun,nface
!
write(jfile,2100)
!
do ipoin = 1,kpoin
write(jfile,1100) relx(ipoin),relp(ipoin),cp(ipoin),cf(ipoin), &
&
heatrt(ipoin)
enddo
!
close(jfile,status='keep')
!
1000 format(4e16.8)
1010 format(4i8)
1100 format(5e14.6)
!
2000 format(' cmach
creyn
tinf twall')
2010 format(' nelem npoin nboun nface')
2100 format('
X
Pressure
CP
Cf Heat Rate')
!
return
end subroutine wallpropt
!
!
*******************************************************
*********
! Subroutine to sort an array by ascending order
!
RECURSIVE SUBROUTINE quick_sort(npoin,x,a1,a2,a3,a4)
!
! Quick sort routine adapted from:
! Brainerd, W.S., Goldberg, C.H. & Adams, J.C. (1990)
"Programmer's Guide to
! Fortran 90", McGraw-Hill ISBN 0-07-000248-7, pages 149-150.
!
Implicit None
!
integer,intent(in) :: npoin
real,intent(inout) :: x(npoin),a1(npoin),a2(npoin)
real,intent(inout) :: a3(npoin),a4(npoin)
!
IF (i < j) THEN
! Swap two out-of-order elements
xtemp = x(i); x(i) = x(j); x(j) = xtemp
a1temp = a1(i); a1(i) = a1(j); a1(j) = a1temp
a2temp = a2(i); a2(i) = a2(j); a2(j) = a2temp
a3temp = a3(i); a3(i) = a3(j); a3(j) = a3temp
a4temp = a4(i); a4(i) = a4(j); a4(j) = a4temp
ELSE IF (i == j) THEN
i=i+1
EXIT
ELSE
EXIT
END IF
END DO
IF (left_end < j) CALL quick_sort_1(left_end, j)
IF (i < right_end) CALL quick_sort_1(i, right_end)
END IF
END SUBROUTINE quick_sort_1
SUBROUTINE interchange_sort(left_end, right_end)
INTEGER, INTENT(IN) :: left_end, right_end
! Local variables
INTEGER
:: i, j
REAL
:: xtemp,a1temp,a2temp,a3temp,a4temp
64
enddo
DO i = left_end, right_end - 1
DO j = i+1, right_end
IF (x(i) > x(j)) THEN
xtemp = x(i); x(i) = x(j); x(j) = xtemp
a1temp = a1(i); a1(i) = a1(j); a1(j) = a1temp
a2temp = a2(i); a2(i) = a2(j); a2(j) = a2temp
a3temp = a3(i); a3(i) = a3(j); a3(j) = a3temp
a4temp = a4(i); a4(i) = a4(j); a4(j) = a4temp
END IF
END DO
END DO
!
!
write(45,650) ielem,lbnode,(lnode(j),j=1,lbnode)
650 format(' Element No. ',i8,' lbnode: ',i4,' Nodes: ',7i4)
!
if(lbnode.eq.4) then ! One Boundary Face
nface = nface + 1
lface(7,nface) = ielem
msum = 0
do inod = 1,4
msum = msum + lnode(inod)
enddo
!
!
END SUBROUTINE interchange_sort
END SUBROUTINE quick_sort
!
!
*******************************************************
*********
! Subroutine to calculate boundary face connectivity for 3-D
! isoparametric element
!
subroutine genbfac3(nelem,nboun,nnode,nface)
!
Use grid_info
Use bnd_cnd
Use bface_info
!
Implicit None
!
integer,intent(in) :: nelem,nboun,nnode
integer,intent(inout) :: nface
integer :: lnode(7)
integer :: ielem,lbnode,inode,ipoin,lflag,inod
integer :: msum,ibc1,ibc2,iface,iboun,jpoin,kboun
integer :: j
!
! lface(1,iface) = point number of 1st boundary node
!
2
= point number of 2nd boundary node
!
3
= point number of 3rd boundary node
!
4
= point number of 4th boundary node
!
5
= orientation of boundary surface
!
1 - parallel to x-y plane
!
2 - parallel to y-z plane
!
3 - parallel to x-z plane
!
6
= direction of vector normal to surface
!
1 - positive direction
!
2 - negative direction
!
7
= element number
!
! lfacnode(1-4,iface) = local node number of boundary nodes
! lfacnode(5-8,iface) = Boundary point number of boundary nodes
!
nface = 0
!
elemntlp: do ielem = 1,nelem
!
lbnode = 0
do inode = 1, nnode
ipoin = lnod(inode,ielem)
lflag = 0
!
write(35,651) ipoin,indbc(ipoin)
! 651 format(' ipoin = ',i8,' Boundary Condition: ',i4)
if(indbc(ipoin).ne.0) then
lflag = 1
lbnode = lbnode + 1
goto 50
endif
50 continue
if(lflag.eq.1) lnode(lbnode) = inode
write(45,655) msum
655 format(' MSUM = ',i8)
!
if(msum.eq.10) then
! Bottom Face
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(3,ielem)
lface(4,nface) = lnod(4,ielem)
lface(5,nface) = 1
lface(6,nface) = 2
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 3
lfacnode(4,nface) = 4
!
ipoin = lnod(4,ielem)
ibc1 = indbc(ipoin)
ibc2 = indbc(lnod(1,ielem))
lface(8,nface) = ibc1
if(ibc2.eq.2) lface(8,nface) = ibc2
if(ibc1.eq.4) lface(8,nface) = ibc2
!
elseif(msum.eq.26) then
! Top Face
lface(1,nface) = lnod(5,ielem)
lface(2,nface) = lnod(6,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 1
lface(6,nface) = 1
ipoin = lnod(7,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 5
lfacnode(2,nface) = 6
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
elseif(msum.eq.18) then
! Left or Right Faces
if(lnode(1).eq.1) then
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(4,ielem)
lface(3,nface) = lnod(8,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 2
lface(6,nface) = 2
ipoin = lnod(1,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 4
lfacnode(3,nface) = 8
lfacnode(4,nface) = 5
else
lface(1,nface) = lnod(2,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(6,ielem)
lface(5,nface) = 2
lface(6,nface) = 1
ipoin = lnod(2,ielem)
65
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 3
lfacnode(4,nface) = 4
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 2
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 6
endif
elseif(msum.eq.22) then
! Back Face
lface(1,nface) = lnod(4,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 3
lface(6,nface) = 2
ipoin = lnod(4,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 4
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
elseif(msum.eq.14) then
! Front Face
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(6,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 3
lface(6,nface) = 1
ipoin = lnod(1,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 6
lfacnode(4,nface) = 5
endif
endif
!
elseif(msum.eq.24) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(6,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 3
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(5,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 6
lfacnode(4,nface) = 5
!
nface = nface + 1
lface(1,nface) = lnod(2,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(6,ielem)
lface(5,nface) = 2
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(7,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 2
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 6
!
if(lbnode.eq.6) then
!
! Two Boundary Faces
elseif(msum.eq.29) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(6,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 3
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(1,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 6
lfacnode(4,nface) = 5
!
msum = 0
do inod = 1,6
msum = msum + lnode(inod)
enddo
!
!
!
write(45,655) msum
if(msum.eq.21) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(6,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 3
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(6,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 6
lfacnode(4,nface) = 5
!
nface = nface + 1
lface(1,nface) = lnod(5,ielem)
lface(2,nface) = lnod(6,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 1
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(7,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 5
lfacnode(2,nface) = 6
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
!
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(3,ielem)
lface(4,nface) = lnod(4,ielem)
lface(5,nface) = 1
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(3,ielem)
lface(8,nface) = indbc(ipoin)
!
elseif(msum.eq.26) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
66
lface(7,nface) = ielem
ipoin = lnod(2,ielem)
lface(8,nface) = indbc(ipoin)
jpoin = lnod(8,ielem)
lface(8,nface-1) = indbc(jpoin)
lfacnode(1,nface) = 2
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 6
endif
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(6,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 3
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(6,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 6
lfacnode(4,nface) = 5
!
elseif(msum.eq.23) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(3,ielem)
lface(4,nface) = lnod(4,ielem)
lface(5,nface) = 1
lface(6,nface) = 2
lface(7,nface) = ielem
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 3
lfacnode(4,nface) = 4
!
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(4,ielem)
lface(3,nface) = lnod(8,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 2
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(8,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 4
lfacnode(3,nface) = 8
lfacnode(4,nface) = 5
!
if(lnode(5).eq.5) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(4,ielem)
lface(3,nface) = lnod(8,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 2
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(5,ielem)
lface(8,nface) = indbc(ipoin)
jpoin = lnod(2,ielem)
lface(8,nface-1) = indbc(jpoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 4
lfacnode(3,nface) = 8
lfacnode(4,nface) = 5
else
!
elseif(msum.eq.31) then
nface = nface + 1
lface(1,nface) = lnod(5,ielem)
lface(2,nface) = lnod(6,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 1
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(7,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 5
lfacnode(2,nface) = 6
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
!
!
nface = nface + 1
lface(1,nface) = lnod(2,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(6,ielem)
lface(5,nface) = 2
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(6,ielem)
lface(8,nface) = indbc(ipoin)
jpoin = lnod(1,ielem)
lface(8,nface-1) = indbc(jpoin)
lfacnode(1,nface) = 2
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 6
endif
elseif(msum.eq.33) then
nface = nface + 1
lface(1,nface) = lnod(5,ielem)
lface(2,nface) = lnod(6,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 1
lface(6,nface) = 1
lface(7,nface) = ielem
if(lnode(1).eq.1) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(4,ielem)
lface(3,nface) = lnod(8,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 2
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(1,ielem)
lface(8,nface) = indbc(ipoin)
jpoin = lnod(7,ielem)
lface(8,nface-1) = indbc(jpoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 4
lfacnode(3,nface) = 8
lfacnode(4,nface) = 5
else
!
nface = nface + 1
lface(1,nface) = lnod(2,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(6,ielem)
lface(5,nface) = 2
lface(6,nface) = 1
67
lface(1,nface) = lnod(4,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 3
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(7,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 4
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
ipoin = lnod(6,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 5
lfacnode(2,nface) = 6
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
!
nface = nface + 1
lface(1,nface) = lnod(4,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 3
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(3,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 4
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
!
elseif(msum.eq.30) then
nface = nface + 1
lface(1,nface) = lnod(2,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(6,ielem)
lface(5,nface) = 2
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(2,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 2
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 6
!
elseif(msum.eq.28) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(4,ielem)
lface(3,nface) = lnod(8,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 2
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(1,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 4
lfacnode(3,nface) = 8
lfacnode(4,nface) = 5
!
nface = nface + 1
lface(1,nface) = lnod(4,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 3
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(8,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 4
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
endif
endif
!
nface = nface + 1
lface(1,nface) = lnod(4,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 3
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(3,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 4
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
!
if(lbnode.eq.7) then
! Three Boundary Faces
!
msum = 0
do inod = 1,7
msum = msum +lnode(inod)
enddo
!
!
!
!
elseif(msum.eq.25) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(3,ielem)
lface(4,nface) = lnod(4,ielem)
lface(5,nface) = 1
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(1,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 3
lfacnode(4,nface) = 4
write(45,655)msum
if(msum.eq.33) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(6,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 3
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(2,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 6
!
nface = nface + 1
68
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(8,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 5
lfacnode(2,nface) = 6
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
lfacnode(4,nface) = 5
!
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(4,ielem)
lface(3,nface) = lnod(8,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 2
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(4,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 4
lfacnode(3,nface) = 8
lfacnode(4,nface) = 5
!
elseif(msum.eq.28) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(6,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 3
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(5,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
!
nface = nface + 1
lface(1,nface) = lnod(5,ielem)
lface(2,nface) = lnod(6,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 1
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(7,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 5
lfacnode(2,nface) = 6
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
lfacnode(2,nface) = 2
lfacnode(3,nface) = 6
lfacnode(4,nface) = 5
!
nface = nface + 1
lface(1,nface) = lnod(2,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(6,ielem)
lface(5,nface) = 2
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(7,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 2
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 6
!
elseif(msum.eq.32) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(6,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 3
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(1,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 6
lfacnode(4,nface) = 5
!
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(3,ielem)
lface(4,nface) = lnod(4,ielem)
lface(5,nface) = 1
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(4,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 3
lfacnode(4,nface) = 4
!
nface = nface + 1
lface(1,nface) = lnod(2,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(6,ielem)
lface(5,nface) = 2
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(3,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 2
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 6
!
elseif(msum.eq.29) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(6,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 3
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(6,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 6
!
nface = nface + 1
lface(1,nface) = lnod(5,ielem)
lface(2,nface) = lnod(6,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 1
69
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(3,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 4
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
lfacnode(4,nface) = 5
!
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(3,ielem)
lface(4,nface) = lnod(4,ielem)
lface(5,nface) = 1
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(3,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 3
lfacnode(4,nface) = 4
!
elseif(msum.eq.35) then
nface = nface + 1
lface(1,nface) = lnod(5,ielem)
lface(2,nface) = lnod(6,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 1
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(5,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 5
lfacnode(2,nface) = 6
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
!
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(4,ielem)
lface(3,nface) = lnod(8,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 2
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(8,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 4
lfacnode(3,nface) = 8
lfacnode(4,nface) = 5
!
nface = nface + 1
lface(1,nface) = lnod(4,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 3
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(4,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 4
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
!
elseif(msum.eq.34) then
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(4,ielem)
lface(3,nface) = lnod(8,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 2
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(1,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 4
lfacnode(3,nface) = 8
lfacnode(4,nface) = 5
!
nface = nface + 1
lface(1,nface) = lnod(2,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(6,ielem)
lface(5,nface) = 2
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(2,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 2
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 6
!
nface = nface + 1
lface(1,nface) = lnod(5,ielem)
lface(2,nface) = lnod(6,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 1
lface(6,nface) = 1
lface(7,nface) = ielem
ipoin = lnod(6,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 5
lfacnode(2,nface) = 6
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
!
elseif(msum.eq.30) then
nface = nface + 1
lface(1,nface) = lnod(4,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 3
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(7,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 4
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
!
nface = nface + 1
lface(1,nface) = lnod(4,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 3
70
lface(7,nface) = ielem
ipoin = lnod(6,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 2
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 6
endif
endif
!
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(3,ielem)
lface(4,nface) = lnod(4,ielem)
lface(5,nface) = 1
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(2,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 3
lfacnode(4,nface) = 4
!
enddo elemntlp
!
!
!
Store boundary point number in lfacnode(5-8,iface)
do iface = 1,nface
do inode = 1,4
ipoin = lface(inode,iface)
midloop: do iboun = 1,nboun
jpoin = ibcon(1,iboun)
if(ipoin.eq.jpoin) then
kboun = iboun
exit midloop
endif
enddo midloop
lfacnode(inode+4,iface) = kboun
enddo
enddo
!
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(4,ielem)
lface(3,nface) = lnod(8,ielem)
lface(4,nface) = lnod(5,ielem)
lface(5,nface) = 2
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(5,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 4
lfacnode(3,nface) = 8
lfacnode(4,nface) = 5
!
open(unit=35,file='bface.out')
!
write(35,500)nface
500 format(' # of Boundary Faces = ',i8)
do iface = 1,nface
write(35,520) iface
write(35,510)(lface(j,iface),j=1,8)
write(35,510) (lfacnode(j,iface),j=1,8)
enddo
!
elseif(msum.eq.31) then
nface = nface + 1
lface(1,nface) = lnod(4,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(8,ielem)
lface(5,nface) = 3
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(8,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 4
lfacnode(2,nface) = 3
lfacnode(3,nface) = 7
lfacnode(4,nface) = 8
!
close(unit=35,status='keep')
!
510 format(8i8)
520 format(' Boundary Face Number ',i8)
!
return
end
subroutine genbfac3
!
!
*******************************************************
*********
! SUBROUTINE TO CALCULATE DOMAIN SHAPE
FUNCTIONS AND DERIVATIVES
!
SUBROUTINE SHAPDOM3
!
Use param_var
Use Gaus_quad
Use shap_fcns
Use shap3d_fcns
!
Implicit None
!
integer :: igaus,i,j,k
!
! LINEAR INTERPOLATION FUNCTIONS
!
IGAUS=0
xiloop: DO I = 1, NGAUS
etaloop: DO J = 1, NGAUS
zetaloop: Do K = 1,ngaus
IGAUS = IGAUS + 1
!
nface = nface + 1
lface(1,nface) = lnod(1,ielem)
lface(2,nface) = lnod(2,ielem)
lface(3,nface) = lnod(3,ielem)
lface(4,nface) = lnod(4,ielem)
lface(5,nface) = 1
lface(6,nface) = 2
lface(7,nface) = ielem
ipoin = lnod(1,ielem)
lface(8,nface) = indbc(ipoin)
lfacnode(1,nface) = 1
lfacnode(2,nface) = 2
lfacnode(3,nface) = 3
lfacnode(4,nface) = 4
!
nface = nface + 1
lface(1,nface) = lnod(2,ielem)
lface(2,nface) = lnod(3,ielem)
lface(3,nface) = lnod(7,ielem)
lface(4,nface) = lnod(6,ielem)
lface(5,nface) = 2
lface(6,nface) = 1
71
d2phidedz(7,igaus) = 0.125*(1. + xi(i))
d2phidxde(8,igaus) = -0.125*(1. + xi(k))
d2phidxdz(8,igaus) = -0.125*(1. + xi(j))
d2phidedz(8,igaus) = 0.125*(1. - xi(i))
PHI(1,IGAUS)=0.125*(1.-XI(I))*(1.-XI(J))*(1.-XI(K))
PHI(2,IGAUS)=0.125*(1.+XI(I))*(1.-XI(J))*(1.XI(K))
PHI(3,IGAUS)=0.125*(1.+XI(I))*(1.+XI(J))*(1.!
!
!
!
!
!
XI(K))
PHI(4,IGAUS)=0.125*(1.-XI(I))*(1.+XI(J))*(1.XI(K))
PHI(5,IGAUS)=0.125*(1.-XI(I))*(1.XI(J))*(1.+XI(K))
PHI(6,IGAUS)=0.125*(1.+XI(I))*(1.XI(J))*(1.+XI(K))
PHI(7,IGAUS)=0.125*(1.+XI(I))*(1.+XI(J))*(1.+XI(K))
PHI(8,IGAUS)=0.125*(1.XI(I))*(1.+XI(J))*(1.+XI(K))
!
! derivatives of linear interpolation functions
!
dpxi(1,1,IGAUS)=-0.125*(1.-xi(j))*(1.-xi(k))
dpxi(2,1,IGAUS)=-0.125*(1.-xi(i))*(1.-xi(k))
dpxi(3,1,IGAUS)=-0.125*(1.-xi(i))*(1.-xi(j))
dpxi(1,2,IGAUS)=0.125*(1.-xi(j))*(1.-xi(k))
dpxi(2,2,IGAUS)=-0.125*(1.+xi(i))*(1.-xi(k))
dpxi(3,2,IGAUS)=-0.125*(1.+xi(i))*(1.-xi(j))
dpxi(1,3,IGAUS)=0.125*(1.+xi(j))*(1.-xi(k))
dpxi(2,3,IGAUS)=0.125*(1.+xi(i))*(1.-xi(k))
dpxi(3,3,IGAUS)=-0.125*(1.+xi(i))*(1.+xi(j))
dpxi(1,4,IGAUS)=-0.125*(1.+xi(j))*(1.-xi(k))
dpxi(2,4,IGAUS)=0.125*(1.-xi(i))*(1.-xi(k))
dpxi(3,4,IGAUS)=-0.125*(1.-xi(i))*(1.+xi(j))
dpxi(1,5,IGAUS)=-0.125*(1.-xi(j))*(1.+xi(k))
dpxi(2,5,IGAUS)=-0.125*(1.-xi(i))*(1.+xi(k))
dpxi(3,5,IGAUS)=0.125*(1.-xi(i))*(1.-xi(j))
dpxi(1,6,IGAUS)=0.125*(1.-xi(j))*(1.+xi(k))
dpxi(2,6,IGAUS)=-0.125*(1.+xi(i))*(1.+xi(k))
dpxi(3,6,IGAUS)=0.125*(1.+xi(i))*(1.-xi(j))
dpxi(1,7,IGAUS)=0.125*(1.+xi(j))*(1.+xi(k))
dpxi(2,7,IGAUS)=0.125*(1.+xi(i))*(1.+xi(k))
dpxi(3,7,IGAUS)=0.125*(1.+xi(i))*(1.+xi(j))
dpxi(1,8,IGAUS)=-0.125*(1.+xi(j))*(1.+xi(k))
dpxi(2,8,IGAUS)=0.125*(1.-xi(i))*(1.+xi(k))
dpxi(3,8,IGAUS)=0.125*(1.-xi(i))*(1.+xi(j))
WW(IGAUS)=W(I)*W(J)*W(K)
!
! Second derivatives of interpolation functions
!
! d2phidxde - d2phi/(dxi deta)
! d2phidxdz - d2phi/(dxi dzeta)
! d2phidedz - d2phi/(deta dzeta)
!
d2phidxde(1,igaus) = 0.125*(1. - xi(k))
d2phidxdz(1,igaus) = 0.125*(1. - xi(j))
d2phidedz(1,igaus) = 0.125*(1. - xi(i))
d2phidxde(2,igaus) = -0.125*(1. - xi(k))
d2phidxdz(2,igaus) = -0.125*(1. - xi(j))
d2phidedz(2,igaus) = 0.125*(1. + xi(i))
d2phidxde(3,igaus) = 0.125*(1. - xi(k))
d2phidxdz(3,igaus) = -0.125*(1. + xi(j))
d2phidedz(3,igaus) = -0.125*(1. + xi(i))
d2phidxde(4,igaus) = -0.125*(1. - xi(k))
d2phidxdz(4,igaus) = 0.125*(1. + xi(j))
d2phidedz(4,igaus) = -0.125*(1. - xi(i))
d2phidxde(5,igaus) = 0.125*(1. + xi(k))
d2phidxdz(5,igaus) = -0.125*(1. - xi(j))
d2phidedz(5,igaus) = -0.125*(1. - xi(i))
d2phidxde(6,igaus) = -0.125*(1. + xi(k))
d2phidxdz(6,igaus) = 0.125*(1. - xi(j))
d2phidedz(6,igaus) = -0.125*(1. + xi(i))
d2phidxde(7,igaus) = 0.125*(1. + xi(k))
d2phidxdz(7,igaus) = 0.125*(1. + xi(j))
write(35,75) igaus
write(35,100)(phi(inode,igaus),inode=1,mnode)
write(35,100) (dpxi(1,inode,igaus),inode=1,mnode)
write(35,100)(dpxi(2,inode,igaus),inode=1,mnode)
write(35,100)(dpxi(3,inode,igaus),inode=1,mnode)
enddo zetaloop
enddo etaloop
enddo xiloop
!
75 format(' SHAPE FUNCTIONS AND DERIVATIVES AT
GAUSSIAN POINT ' &
&
,I4)
100 format(4(e16.8,1x))
!
RETURN
END
!
*******************************************************
******
SUBROUTINE
DERSHA_3D(NNODE,ndimn,xloc,dpxi,d2phidxde,&
&
d2phidxdz,d2phidedz,iflag,koun,dshpdx, &
&
detjac,d2phidx)
!
! THIS SUBROUTINE CALCULATES THE DERIVATIVES OF
THE SHAPE FUNCTIONS
!
Use param_var
!
Use shap_fcns
! Use shap3d_fcns
!
Use grid_info
!
Use Gaus_quad
!
Implicit None
!
integer,intent(in) :: nnode,ndimn,iflag,koun
real,dimension(ndimn,nnode),intent(in) :: xloc
real,intent(in) :: dpxi(mdimn,mnode,mgaus)
real,intent(in),dimension(mnode,mgaus) :: d2phidxde,d2phidxdz
real,intent(in),dimension(mnode,mgaus) :: d2phidedz
real,intent(out) :: dshpdx(mdimn,mnode,mgaus),detjac(mgaus)
real,intent(out) :: d2phidx(mdimn,mdimn,mnode,mgaus)
integer :: i,igaus,l,j,k,inode
real :: dxdxi,dxdeta,dxdzeta,dydxi,dydeta,dydzeta,dzdxi,dzdeta
real ::
dzdzeta,d2xdxde,d2xdxdz,d2xdedz,d2ydxde,d2ydxdz,d2ydedz
real :: d2zdxdz,d2zdxde,d2zdedz
real :: detjacinv,detjacinv2
real :: term1,term2,term3,term4,term5,term6
real ::
term11,term12,term13,term21,term22,term23,term31,term32
real :: term33
real :: djacdxi,djacdeta,djacdzeta
real :: jacinv(ndimn,ndimn),djacinvdxi(ndimn,ndimn)
real :: djacinvdet(ndimn,ndimn),djacinvdzt(ndimn,ndimn)
real :: Wn(nnode),Wnbar(nnode),Wntild(nnode)
real :: XELEM(NNODE),YELEM(NNODE),ZELEM(NNODE)
DO I=1,NNODE
XELEM(I)=Xloc(1,i)
YELEM(I)=Xloc(2,i)
ZELEM(I)=Xloc(3,I)
enddo
!
gausloop: DO IGAUS = 1, MGAUS
DXDXI = 0.0
72
write(*,100) (xelem(inode),yelem(inode), &
&
zelem(inode),inode=1,nnode)
stop
endif
100 format(3e20.10)
DXDETA = 0.0
DXDZETA = 0.0
DYDXI = 0.0
DYDETA = 0.0
DYDZETA = 0.0
DZDXI = 0.0
DZDETA = 0.0
DZDZETA = 0.0
d2xdxde = 0.0
d2xdxdz = 0.0
d2xdedz = 0.0
d2ydxde = 0.0
d2ydxdz = 0.0
d2ydedz = 0.0
d2zdxdz = 0.0
d2zdxde = 0.0
d2zdedz = 0.0
DO L = 1, NNODE
DXDXI = DXDXI + dpxi(1,L,IGAUS)*xelem(L)
DXDETA = DXDETA +
dpxi(2,L,IGAUS)*xelem(L)
DXDZETA = DXDZETA +
dpxi(3,L,IGAUS)*Xelem(L)
DYDXI = DYDXI + dpxi(1,L,IGAUS)*yelem(L)
DYDETA = DYDETA +
dpxi(2,L,IGAUS)*yelem(L)
DYDZETA = DYDZETA +
dpxi(3,L,IGAUS)*yelem(L)
DZDXI = DZDXI + dpxi(1,L,IGAUS)*zelem(L)
DZDETA = DZDETA + dpxi(2,L,IGAUS)*zelem(L)
DZDZETA = DZDZETA +
dpxi(3,L,IGAUS)*zelem(L)
d2xdxde = d2xdxde + d2phidxde(L,igaus)*xelem(L)
d2xdxdz = d2xdxdz + d2phidxdz(L,igaus)*xelem(L)
d2xdedz = d2xdedz + d2phidedz(L,igaus)*xelem(L)
d2ydxde = d2ydxde + d2phidxde(L,igaus)*yelem(L)
d2ydxdz = d2ydxdz + d2phidxdz(L,igaus)*yelem(L)
d2ydedz = d2ydedz + d2phidedz(L,igaus)*yelem(L)
d2zdxde = d2zdxde + d2phidxde(L,igaus)*zelem(L)
d2zdxdz = d2zdxdz + d2phidxdz(L,igaus)*zelem(L)
d2zdedz = d2zdedz + d2phidedz(L,igaus)*zelem(L)
enddo
!
! determinant of Jacobian
!
detjac(IGAUS)=dxdxi*dydeta*dzdzeta + &
&
dxdeta*dydzeta*dzdxi + &
&
dxdzeta*dydxi*dzdeta - &
&
dxdzeta*dydeta*dzdxi - &
&
dxdxi*dydzeta*dzdeta - &
&
dxdeta*dydxi*dzdzeta
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
calculate components of Jacobian inverse matrix
jacinv(1,1)=dydeta*dzdzeta - dydzeta*dzdeta
jacinv(1,2)=-(dydxi*dzdzeta - dydzeta*dzdxi)
jacinv(1,3)=dydxi*dzdeta - dydeta*dzdxi
jacinv(2,1)=-(dxdeta*dzdzeta - dxdzeta*dzdeta)
jacinv(2,2)=dxdxi*dzdzeta - dxdzeta*dzdxi
jacinv(2,3)=-(dxdxi*dzdeta - dxdeta*dzdxi)
jacinv(3,1)=dxdeta*dydzeta - dxdzeta*dydeta
jacinv(3,2)=-(dxdxi*dydzeta - dxdzeta*dydxi)
jacinv(3,3)=dxdxi*dydeta - dxdeta*dydxi
!
!
!
CALCULATE DERIVATIVES OF SHAPE FUNCTIONS
do k= 1,nnode
do j = 1,ndimn
dshpdx(j,k,igaus)=0.0
enddo
enddo
!
detjacinv = 1./detjac(igaus)
detjacinv2 = detjacinv/detjac(igaus)
!
do i = 1,ndimn
DO K = 1,NNODE
do j = 1,3
DSHPDX(i,K,IGAUS)=dshpdx(i,k,igaus)+(jacinv(i,j)* &
&
dpxi(j,k,igaus))*detjacinv
enddo
enddo
enddo
!
!
if(koun.le.100) then
!
write(25,*)igaus,detjac(igaus)
!
do i = 1,ndimn
!
write(25,101)(jacinv(i,j),k=1,ndimn)
!
enddo
!
endif
101 format(3(1x,e16.8))
!
if(iflag.eq.1) then
!
! Derivatives of Jacobian inverse components wrt xi, eta, and zeta
!
djacinvdxi(1,1) = d2ydxde*dzdzeta + dydeta* &
&
d2zdxdz - d2ydxdz*dzdeta - &
&
dydzeta*d2zdxde
djacinvdet(1,1) = dydeta*d2zdedz &
&
d2ydedz*dzdeta
djacinvdzt(1,1) = d2ydedz*dzdzeta &
&
dydzeta*d2zdedz
djacinvdxi(1,2) = -(dydxi*d2zdxdz - d2ydxdz* &
&
dzdxi)
djacinvdet(1,2) = -(d2ydxde*dzdzeta + dydxi* &
&
d2zdedz - d2ydedz*dzdxi - &
&
dydzeta*d2zdxde)
djacinvdzt(1,2) = -(d2ydxdz*dzdzeta - dydzeta* &
&
d2zdxdz)
djacinvdxi(1,3) = dydxi*d2zdxde - d2ydxde* &
&
dzdxi
djacinvdet(1,3) = d2ydxde*dzdeta - dydeta*
&
&
d2zdxde
djacinvdzt(1,3) = d2ydxdz*dzdeta + dydxi*
&
if(igaus.eq.1) then
write(25,201)
do inode = 1,nnode
write(25,*)xelem(inode),yelem(inode),zelem(inode)
enddo
write(25,202)igaus
do idimn=1,ndimn
write(25,*)(dxxi(jdimn,idimn,igaus),jdimn=1,ndimn)
enddo
endif
201 format(' X, Y, and Z coordinates')
202 format(' DXDXI AT GAUSSIAN POINT',i4)
!
if(detjac(IGAUS).lt.1.0e-12)then
write(*,*)'detjac = ',detjac(igaus)
write(*,*)'COORDINATES: '
73
term5 = dzdeta*(d2xdxde*dydzeta +
&
dxdxi*d2ydedz)
term6 = dxdeta*(d2ydxde*dzdzeta +
&
dydxi*d2zdedz)
&
d2zdedz - d2ydedz*dzdxi - &
&
dydeta*d2zdxdz
djacinvdxi(2,1) = -(d2xdxde*dzdzeta + dxdeta* &
&
d2zdxdz - d2xdxdz*dzdeta - &
&
dxdzeta*d2zdxde)
djacinvdet(2,1) = -(dxdeta*d2zdedz - d2xdedz* &
&
dzdeta)
djacinvdzt(2,1) = -(d2xdedz*dzdzeta - dxdzeta* &
&
d2zdedz)
djacinvdxi(2,2) = dxdxi*d2zdxdz - d2xdxdz* &
&
dzdxi
djacinvdet(2,2) = d2xdxde*dzdzeta + dxdxi* &
&
d2zdedz - d2xdedz*dzdxi - &
&
dxdzeta*d2zdxde
djacinvdzt(2,2) = d2xdxdz*dzdzeta - dxdzeta* &
&
d2zdxdz
djacinvdxi(2,3) = -(dxdxi*d2zdxde - d2xdxde* &
&
dzdxi)
djacinvdet(2,3) = -(d2xdxde*dzdeta - dxdeta* &
&
d2zdxde)
djacinvdzt(2,3) = -(d2xdxdz*dzdeta + dxdxi* &
&
d2zdedz - d2xdedz*dzdxi - &
&
dxdeta*d2zdxdz)
djacinvdxi(3,1) = d2xdxde*dydzeta + dxdeta* &
&
d2ydxdz - d2xdxdz*dydeta - &
&
dxdzeta*d2ydxde
djacinvdet(3,1) = dxdeta*d2ydedz - d2xdedz* &
&
dydeta
djacinvdzt(3,1) = d2xdedz*dydzeta - dxdeta* &
&
d2ydedz
djacinvdxi(3,2) = -(dxdxi*d2ydxdz - d2xdxdz* &
&
dydxi)
djacinvdet(3,2) = -(d2xdxde*dydzeta + dxdxi* &
&
d2ydedz - d2xdedz*dydxi - &
&
dxdzeta*d2ydxde)
djacinvdzt(3,2) = -(d2xdxdz*dydzeta - dxdzeta* &
&
d2ydxdz)
djacinvdxi(3,3) = dxdxi*d2ydxde - d2xdxde* &
&
dydxi
djacinvdet(3,3) = d2xdxde*dydeta - dxdeta*
&
&
d2ydxde
djacinvdzt(3,3) = d2xdxdz*dydeta + dxdxi*
&
&
d2ydedz - d2xdedz*dydxi - &
&
dxdeta*d2ydxdz
!
!
!
djacdeta = term1 + term2 + term3 - term4 - term5 - term6
!
term1 = dzdzeta*(d2xdxdz*dydeta +
&
dxdxi*d2ydedz)
term2 = dydzeta*(d2xdedz*dzdxi +
&
dxdeta*d2zdxdz)
term3 = dxdzeta*(d2ydxdz*dzdeta +
&
dydxi*d2zdedz)
term4 = dxdzeta*(d2ydedz*dzdxi +
&
dydeta*d2zdxdz)
term5 = dydzeta*(d2xdxdz*dzdeta +
&
dxdxi*d2zdedz)
term6 = dzdzeta*(d2xdedz*dydxi +
&
dxdeta*d2ydxdz)
&
&
&
&
&
&
!
djacdzeta = term1 + term2 + term3 - term4 - term5 -term6
!
!
!
Spatial second derivatives of shape functions
do inode = 1,nnode
wn(inode) = dshpdx(1,inode,igaus)*detjac(igaus)
wnbar(inode) = dshpdx(2,inode,igaus)*detjac(igaus)
wntild(inode) = dshpdx(3,inode,igaus)*detjac(igaus)
enddo
!
do inode = 1,nnode
!
&
&
&
&
term1 = -detjacinv2*djacdxi*wn(inode)
term2 = (djacinvdxi(1,1)*dpxi(1,inode,igaus) +
&
djacinvdxi(1,2)*dpxi(2,inode,igaus) + jacinv(1,2)* &
d2phidxde(inode,igaus) + djacinvdxi(1,3)*
&
dpxi(3,inode,igaus) + jacinv(1,3)*
&
d2phidxdz(inode,igaus))*detjacinv
term11 = jacinv(1,1)*(term1 + term2)
!
&
&
&
&
term1 = -detjacinv2*djacdeta*wn(inode)
term2 = (djacinvdet(1,1)*dpxi(1,inode,igaus) +
&
jacinv(1,1)*d2phidxde(inode,igaus) +
&
djacinvdet(1,2)*dpxi(2,inode,igaus) +
&
djacinvdet(1,3)*dpxi(3,inode,igaus) + jacinv(1,3)* &
d2phidedz(inode,igaus))*detjacinv
term12 = jacinv(1,2)*(term1 + term2)
!
&
&
&
&
&
&
&
&
term1 = -detjacinv2*djacdzeta*wn(inode)
term2 = (djacinvdzt(1,1)*dpxi(1,inode,igaus) +
&
jacinv(1,1)*d2phidxdz(inode,igaus) +
&
djacinvdzt(1,2)*dpxi(2,inode,igaus) +
&
jacinv(1,2)*d2phidedz(inode,igaus) +
&
djacinvdzt(1,3)*dpxi(3,inode,igaus))*detjacinv
term13 = jacinv(1,3)*(term1 + term2)
!
&
&
&
d2phidx(1,1,inode,igaus) = detjacinv*(term11 + term12 + &
term13)
!
!
djacdxi = term1 + term2 + term3 - term4 - term5 - term6
!
term1 = dydeta*(d2xdxde*dzdzeta +
&
dxdxi*d2zdedz)
term2 = dxdeta*(d2ydedz*dzdxi +
&
dydzeta*d2zdxde)
term3 = dzdeta*(d2xdedz*dydxi +
&
dxdzeta*d2ydxde)
term4 = dydeta*(d2xdedz*dzdxi +
&
dxdzeta*d2zdxde)
&
!
Derivatives of determinant of Jacobian wrt to xi, eta, and zeta
term1 = dxdxi*(d2ydxde*dzdzeta +
&
dydeta*d2zdxdz)
term2 = dzdxi*(d2xdxde*dydzeta +
&
dxdeta*d2ydxdz)
term3 = dydxi*(d2xdxdz*dzdeta +
&
dxdzeta*d2zdxde)
term4 = dzdxi*(d2xdxdz*dydeta +
&
dxdzeta*d2ydxde)
term5 = dxdxi*(d2ydxdz*dzdeta +
&
dydzeta*d2zdxde)
term6 = dydxi*(d2xdxde*dzdzeta +
&
dxdeta*d2zdxdz)
&
&
&
&
&
&
&
&
term1 = -detjacinv2*djacdxi*wnbar(inode)
term2 = (djacinvdxi(2,1)*dpxi(1,inode,igaus) +
&
djacinvdxi(2,2)*dpxi(2,inode,igaus) + jacinv(2,2)*&
d2phidxde(inode,igaus) + djacinvdxi(2,3)*
&
dpxi(3,inode,igaus) + jacinv(2,3)*
&
d2phidxdz(inode,igaus))*detjacinv
term21 = jacinv(2,1)*(term1 + term2)
!
term1 = -detjacinv2*djacdeta*wnbar(inode)
term2 = (djacinvdet(2,1)*dpxi(1,inode,igaus) +
&
jacinv(2,1)*d2phidxde(inode,igaus) +
&
74
&
&
&
&
&
!
djacinvdet(2,2)*dpxi(2,inode,igaus) +
&
djacinvdet(2,3)*dpxi(3,inode,igaus) + jacinv(2,3)*&
d2phidedz(inode,igaus))*detjacinv
term22 = jacinv(2,2)*(term1 + term2)
&
&
&
&
!
&
&
&
&
term1 = -detjacinv2*djacdzeta*wnbar(inode)
term2 = (djacinvdzt(2,1)*dpxi(1,inode,igaus) +
&
jacinv(2,1)*d2phidxdz(inode,igaus) +
&
djacinvdzt(2,2)*dpxi(2,inode,igaus) +
&
jacinv(2,2)*d2phidedz(inode,igaus) +
&
djacinvdzt(2,3)*dpxi(3,inode,igaus))*detjacinv
term23 = jacinv(2,3)*(term1 + term2)
!
&
&
&
&
!
&
d2phidx(2,2,inode,igaus) = detjacinv*(term21 + term22 + &
term23)
!
&
&
&
&
term1 = -detjacinv2*djacdxi*wntild(inode)
term2 = (djacinvdxi(3,1)*dpxi(1,inode,igaus) +
&
djacinvdxi(3,2)*dpxi(2,inode,igaus) + jacinv(3,2)*&
d2phidxde(inode,igaus) + djacinvdxi(3,3)*
&
dpxi(3,inode,igaus) + jacinv(3,3)*
&
d2phidxdz(inode,igaus))*detjacinv
term21 = jacinv(1,1)*(term1 + term2)
term1 = -detjacinv2*djacdeta*wntild(inode)
term2 = (djacinvdet(3,1)*dpxi(1,inode,igaus) +
&
jacinv(3,1)*d2phidxde(inode,igaus) +
&
djacinvdet(3,2)*dpxi(2,inode,igaus) +
&
djacinvdet(3,3)*dpxi(3,inode,igaus) + jacinv(3,3)*&
d2phidedz(inode,igaus))*detjacinv
term22 = jacinv(1,2)*(term1 + term2)
!
term1 = -detjacinv2*djacdxi*wntild(inode)
term2 = (djacinvdxi(3,1)*dpxi(1,inode,igaus) +
&
djacinvdxi(3,2)*dpxi(2,inode,igaus) + jacinv(3,2)*&
d2phidxde(inode,igaus) + djacinvdxi(3,3)*
&
dpxi(3,inode,igaus) + jacinv(3,3)*
&
d2phidxdz(inode,igaus))*detjacinv
term31 = jacinv(3,1)*(term1 + term2)
term1 = -detjacinv2*djacdzeta*wntild(inode)
term2 = (djacinvdzt(3,1)*dpxi(1,inode,igaus) +
&
jacinv(3,1)*d2phidxdz(inode,igaus) +
&
&
&
djacinvdzt(3,2)*dpxi(2,inode,igaus) +
&
jacinv(3,2)*d2phidedz(inode,igaus) +
&
!
&
&
&
&
term1 = -detjacinv2*djacdeta*wntild(inode)
term2 = (djacinvdet(3,1)*dpxi(1,inode,igaus) +
&
jacinv(3,1)*d2phidxde(inode,igaus) +
&
djacinvdet(3,2)*dpxi(2,inode,igaus) +
&
djacinvdet(3,3)*dpxi(3,inode,igaus) + jacinv(3,3)*&
d2phidedz(inode,igaus))*detjacinv
term32 = jacinv(3,2)*(term1 + term2)
&
&
!
&
!
&
&
&
&
term1 = -detjacinv2*djacdzeta*wntild(inode)
term2 = (djacinvdzt(3,1)*dpxi(1,inode,igaus) +
&
jacinv(3,1)*d2phidxdz(inode,igaus) +
&
djacinvdzt(3,2)*dpxi(2,inode,igaus) +
&
jacinv(3,2)*d2phidedz(inode,igaus) +
&
djacinvdzt(3,3)*dpxi(3,inode,igaus))*detjacinv
term33 = jacinv(3,3)*(term1 + term2)
d2phidx(1,3,inode,igaus) = detjacinv*(term21 + term22 + &
term23)
d2phidx(3,1,inode,igaus) = d2phidx(1,3,inode,igaus)
!
&
&
&
!
&
djacinvdzt(3,3)*dpxi(3,inode,igaus))*detjacinv
term23 = jacinv(1,3)*(term1 + term2)
d2phidx(3,3,inode,igaus) = detjacinv*(term31 + term32 + &
term33)
&
!
term1 = -detjacinv2*djacdxi*wntild(inode)
term2 = (djacinvdxi(3,1)*dpxi(1,inode,igaus) +
&
djacinvdxi(3,2)*dpxi(2,inode,igaus) + jacinv(3,2)*&
d2phidxde(inode,igaus) + djacinvdxi(3,3)*
&
dpxi(3,inode,igaus) + jacinv(3,3)*
&
d2phidxdz(inode,igaus))*detjacinv
term21 = jacinv(2,1)*(term1 + term2)
!
&
&
&
&
term1 = -detjacinv2*djacdxi*wn(inode)
term2 = (djacinvdxi(1,1)*dpxi(1,inode,igaus) +
&
djacinvdxi(1,2)*dpxi(2,inode,igaus) + jacinv(1,2)*&
d2phidxde(inode,igaus) + djacinvdxi(1,3)*
&
dpxi(3,inode,igaus) + jacinv(1,3)*
&
d2phidxdz(inode,igaus))*detjacinv
term21 = jacinv(2,1)*(term1 + term2)
&
&
&
&
!
&
&
&
&
term1 = -detjacinv2*djacdeta*wn(inode)
term2 = (djacinvdet(1,1)*dpxi(1,inode,igaus) +
&
jacinv(1,1)*d2phidxde(inode,igaus) +
&
djacinvdet(1,2)*dpxi(2,inode,igaus) +
&
djacinvdet(1,3)*dpxi(3,inode,igaus) + jacinv(1,3)*&
d2phidedz(inode,igaus))*detjacinv
term22 = jacinv(2,2)*(term1 + term2)
term1 = -detjacinv2*djacdeta*wntild(inode)
term2 = (djacinvdet(3,1)*dpxi(1,inode,igaus) +
&
jacinv(3,1)*d2phidxde(inode,igaus) +
&
djacinvdet(3,2)*dpxi(2,inode,igaus) +
&
djacinvdet(3,3)*dpxi(3,inode,igaus) + jacinv(3,3)*&
d2phidedz(inode,igaus))*detjacinv
term22 = jacinv(2,2)*(term1 + term2)
!
term1 = -detjacinv2*djacdzeta*wntild(inode)
term2 = (djacinvdzt(3,1)*dpxi(1,inode,igaus) +
&
jacinv(3,1)*d2phidxdz(inode,igaus) +
&
&
!
&
djacinvdzt(3,2)*dpxi(2,inode,igaus) +
&
jacinv(3,2)*d2phidedz(inode,igaus) +
&
&
&
&
&
term1 = -detjacinv2*djacdzeta*wn(inode)
term2 = (djacinvdzt(1,1)*dpxi(1,inode,igaus) +
&
jacinv(1,1)*d2phidxdz(inode,igaus) +
&
djacinvdzt(1,2)*dpxi(2,inode,igaus) +
&
jacinv(1,2)*d2phidedz(inode,igaus) +
&
djacinvdzt(1,3)*dpxi(3,inode,igaus))*detjacinv
term23 = jacinv(2,3)*(term1 + term2)
&
&
!
&
!
&
djacinvdzt(3,3)*dpxi(3,inode,igaus))*detjacinv
term23 = jacinv(2,3)*(term1 + term2)
d2phidx(1,2,inode,igaus) = detjacinv*(term21 + term22 + &
term23)
d2phidx(2,1,inode,igaus) = d2phidx(1,2,inode,igaus)
d2phidx(2,3,inode,igaus) = detjacinv*(term21 + term22 + &
term23)
d2phidx(3,2,inode,igaus) = d2phidx(2,3,inode,igaus)
!
enddo
!
75
!
!
endif
!
!
AT A NODAL POINT
SUBROUTINE CONVFLX3(NPOIN)
DETJAC(IGAUS) = DETJAC(IGAUS)*WW(IGAUS)
enddo gausloop
!
write(25,125)(detjac(ig),ig = 1,mgaus)
125 format(1x,4(e16.8,1x))
!
return
end subroutine dersha_3d
!
!
*******************************************************
********
! THE FOLLOWING SUBROUTINE CALCULATE THE
SHAPE FUNCTIONS AND THEIR
! DERIVATIVES FOR A TWO-D BOUNDARY SURFACE
!
SUBROUTINE SHAPSURF_3d
!
Use Shapbou_3d
Use Gaus_quad
!
Implicit None
!
integer :: igaus,i,j
!
! TWO-DIMENSIONAL LINEAR SHAPE FUNCTIONS
!
igaus = 0
!
DO I = 1, NGAUS
do j = 1,ngaus
igaus = igaus + 1
!
PHI(1,igaus)=0.25*(1.-XI(I))*(1.-xi(j))
PHI(2,igaus)=0.25*(1.+XI(I))*(1.-xi(j))
phi(3,igaus) = 0.25*(1.+xi(i))*(1.+xi(j))
phi(4,igaus) = 0.25*(1.-xi(i))*(1.+xi(j))
!
! DERIVATIVE OF SHAPE FUNCTIONS
!
dpxi(1,1,igaus) = -0.25*(1.-xi(j))
dpxi(2,1,igaus) = -0.25*(1.-xi(i))
dpxi(1,2,igaus) = 0.25*(1.-xi(j))
dpxi(2,2,igaus) = -0.25*(1.+xi(i))
dpxi(1,3,igaus) = 0.25*(1.+xi(j))
dpxi(2,3,igaus) = 0.25*(1.+xi(i))
dpxi(1,4,igaus) = -0.25*(1.+xi(j))
dpxi(2,4,igaus) = 0.25*(1.-xi(i))
!
w_w(igaus) = w(i)*w(j)
!
! Second derivatives
!
d2phi(1,igaus) = 0.25
d2phi(2,igaus) = -0.25
d2phi(3,igaus) = 0.25
d2phi(4,igaus) = -0.25
!
enddo
enddo
!
RETURN
end subroutine shapsurf_3d
!
!
*******************************************************
*******
! THE FOLLOWING SUBROUTINE CALCULATES THE
CONVECTIVE FLUX
!
Use flow_var
Use Conv_flux
!
Implicit None
!
integer,intent(in) :: npoin
integer :: k
real :: r,uvel,vvel,wvel,P,E
!
DO K=1,NPOIN
!
R = DENSE(K)
UVEL = VEL(1,K)
VVEL = VEL(2,K)
WVEL = VEL(3,K)
P = PRESS(K)
E = ENERG(K)
!
F(K,1,1)=R*UVEL
F(K,1,2)=R*UVEL*UVEL + P
F(K,1,3)=R*UVEL*VVEL
F(K,1,4)=R*UVEL*WVEL
F(K,1,5)=(R*E + P)*UVEL
!
F(K,2,1)=R*VVEL
F(K,2,2)=R*UVEL*VVEL
F(K,2,3)=R*VVEL*VVEL + P
F(K,2,4)=R*VVEL*WVEL
F(K,2,5)=(R*E + P)*VVEL
!
F(K,3,1)=R*WVEL
F(K,3,2)=R*UVEL*WVEL
F(K,3,3)=R*VVEL*WVEL
F(K,3,4)=R*WVEL*WVEL + P
F(K,3,5)=(R*E + P)*WVEL
!
enddo
!
RETURN
end subroutine convflx3
!
!
*******************************************************
*
! THE FOLLOWING SUBROUTINE CALCULATES THE
CHARACTERISTIC
! LENGTH OF EACH ELEMENT
!
SUBROUTINE EVALELE3d(adap,ndimn,nnode,NELEM)
!
Use param_var
Use grid_info
Use shap_fcns
Use Shap3d_fcns
Use Gaus_quad
!
Implicit None
!
integer,intent(in) :: ndimn,nnode,nelem
integer :: iel,inode,koun,i,idimn
integer,dimension(nnode) :: iel_nod
real,dimension(ndimn,nnode) :: xloc
real :: dshpdx(mdimn,mnode,mgaus),detjac(mgaus)
real :: d2phidx(mdimn,mdimn,mnode,mgaus)
real :: exp
!
76
diff = vis/rho
onesix = 1./6.
real :: ELEAREA(NELEM)
!
!
logical,intent(in) :: adap
veloc = 0.0
!
!
open(unit=26,file='eleleng.out')
elemntlp: DO IEL=1,NELEM
!
write(*,1000)iel,nnode
do inode = 1, nnode
iel_nod(inode) = lnod(inode,iel)
do idimn = 1,ndimn
xloc(idimn,inode) = x(idimn,iel_nod(inode))
enddo
enddo
koun = 1000
CALL
DERSHA_3D(NNODE,ndimn,xloc,dpxi,d2phidxde,d2phidxdz, &
&
d2phidedz,2,koun,dshpdx,detjac,d2phidx)
ELEAREA(IEL)=0.0
DO I=1,MGAUS
do idimn = 1,ndimn
veloc = veloc + velo(idimn)*velo(idimn)
enddo
!
do inode = 1,nnode
xelem(inode) = xloc(1,inode)
yelem(inode) = xloc(2,inode) ! Coordinates of local
zelem(inode) = xloc(3,inode) ! Nodes
enddo
!
!
!
unit vector in xi, eta, and zeta direction
DXDXI = 0.0
DXDETA = 0.0
DXDZETA = 0.0
DYDXI = 0.0
DYDETA = 0.0
DYDZETA = 0.0
DZDXI = 0.0
DZDETA = 0.0
DZDZETA = 0.0
DO L = 1, NNODE
DXDXI = DXDXI + dpxi(1,L,ig)*xelem(L)
DXDETA = DXDETA + dpxi(2,L,ig)*xelem(L)
DXDZETA = DXDZETA + dpxi(3,L,ig)*Xelem(L)
DYDXI = DYDXI + dpxi(1,L,ig)*yelem(L)
DYDETA = DYDETA + dpxi(2,L,ig)*yelem(L)
DYDZETA = DYDZETA + dpxi(3,L,ig)*yelem(L)
DZDXI = DZDXI + dpxi(1,L,ig)*zelem(L)
DZDETA = DZDETA + dpxi(2,L,ig)*zelem(L)
DZDZETA = DZDZETA + dpxi(3,L,ig)*zelem(L)
enddo
ELEAREA(IEL)=ELEAREA(IEL)+DETJAC(I)*ww(i)
enddo
!
!
write(26,1150)(detjac(ig),ig=1,mgaus)
exp = 1./float(ndimn)
CLENG(IEL)=ELEAREA(IEL)**exp
write(26,1200) iel,elearea(iel),cleng(iel)
enddo elemntlp
close(unit=26,status='keep')
!
1000 format(1x,'ELEMENT ',I8,' NNODE ',i20)
!
write(*,1100)
1100 format(' EXITING SUBROUTINE EVALELE')
1150 format(' DETERMINANT OF JACOBIAN ',/,4(e12.6,1x))
1200 format(1x,'ELEMENT ',I8,' AREA ',e12.6,' CLENG ',e12.6)
RETURN
end subroutine evalele3d
!
!
*******************************************************
************
! Subroutine to calculate Petrov-Galerkin factor, TAU
!
Subroutine GPG(ndimn,nnode,xloc,detjac,ig,velo,rho,vis,hk, &
&GPG_tau)
!
Use param_var
Use shap_fcns
Use grid_info
!
Implicit None
!
integer,intent(in) :: ndimn,nnode,ig
real,dimension(ndimn,nnode),intent(in) :: xloc
real,dimension(mgaus),intent(in) :: detjac
real,intent(in) :: velo(ndimn),rho,vis,hk
real,intent(out) :: GPG_tau
!
integer :: idimn,inode,L
real :: veloc,diff
real,dimension(ndimn) :: uxi,hxi
real,dimension(nnode) :: xelem,yelem,zelem
real :: dxdxi,dydxi,dzdxi,dxdeta,dydeta,dzdeta
real :: dxdzeta,dydzeta,dzdzeta
real,dimension(ndimn) :: exi,eeta,ezeta
real :: jacinv
real,dimension(ndimn) :: pt1,pt2
real :: onesix
real,dimension(ndimn) :: Re,alphabar
!
!
jacinv = 1./detjac(ig)
!
exi(1) = jacinv*dxdxi
exi(2) = jacinv*dydxi
exi(3) = jacinv*dzdxi
eeta(1) = jacinv*dxdeta
eeta(2) = jacinv*dydeta
eeta(3) = jacinv*dzdeta
ezeta(1) = jacinv*dxdzeta
ezeta(2) = jacinv*dydzeta
ezeta(3) = jacinv*dzdzeta
!
uxi = 0.0
!
!
do idimn = 1,ndimn
uxi(1) = uxi(1) + velo(idimn)*exi(idimn)
uxi(2) = uxi(2) + velo(idimn)*eeta(idimn)
uxi(3) = uxi(3) + velo(idimn)*ezeta(idimn)
enddo
hxi
pt1(1) = 0.25*(xelem(1) + xelem(4) + xelem(5) + xelem(8))
pt1(2) = 0.25*(yelem(1) + yelem(4) + yelem(5) + yelem(8))
pt1(3) = 0.25*(zelem(1) + zelem(4) + zelem(5) + zelem(8))
!
pt2(1) = 0.25*(xelem(2) + xelem(3) + xelem(6) + xelem(7))
pt2(2) = 0.25*(yelem(2) + yelem(3) + yelem(6) + yelem(7))
pt2(3) = 0.25*(zelem(2) + zelem(3) + zelem(6) + zelem(7))
!
!
77
hxi(1) = sqrt((pt2(1)-pt1(1))**2 + (pt2(2)-pt1(2))**2 +
(pt2(3)-pt1(3))**2)
heta
&
!
pt1(1) = 0.25*(xelem(1) + xelem(2) + xelem(5) + xelem(6))
pt1(2) = 0.25*(yelem(1) + yelem(2) + yelem(5) + yelem(6))
pt1(3) = 0.25*(zelem(1) + zelem(2) + zelem(5) + zelem(6))
u = velo(1)
v = velo(2)
w = velo(3)
u2 = u*u
v2 = v*v
w2 = w*w
!
pt2(1) = 0.25*(xelem(3) + xelem(4) + xelem(7) + xelem(8))
pt2(2) = 0.25*(yelem(3) + yelem(4) + yelem(7) + yelem(8))
pt2(3) = 0.25*(zelem(3) + zelem(4) + zelem(7) + zelem(8))
!
hxi(2) = sqrt((pt2(1)-pt1(1))**2 + (pt2(2)-pt1(2))**2 +
(pt2(3)-pt1(3))**2)
!
uv = u*v
uw = u*w
vw = v*w
u2pv2pw2 = u2 + v2 + w2
u2pv2 = u2 + v2
u2pw2 = u2 + w2
v2pw2 = v2 + w2
&
hzeta
pt1(1) = 0.25*(xelem(1) + xelem(2) + xelem(3) + xelem(4))
pt1(2) = 0.25*(yelem(1) + yelem(2) + yelem(3) + yelem(4))
pt1(3) = 0.25*(zelem(1) + zelem(2) + zelem(3) + zelem(4))
!
!
aj(1,1,2)=1.0
aj(1,2,1)=GM3D2*u2+GM1D2*v2pw2
aj(1,2,2)=-GAMM3*u
aj(1,2,3)=-GAMM1*v
aj(1,2,4)=-GAMM1*w
aj(1,2,5)=GAMM1
aj(1,3,1)=-uv
aj(1,3,2)=v
aj(1,3,3)=u
aj(1,4,1)=-uw
aj(1,4,2)=w
aj(1,4,4)=u
aj(1,5,1)=-GAMMA*E*u+GAMM1*u*u2pv2pw2
aj(1,5,2)=GAMMA*E-GM1D2*(3.*u2+v2pw2)
aj(1,5,3)=-GAMM1*uv
aj(1,5,4)=-GAMM1*uw
aj(1,5,5)=GAMMA*u
pt2(1) = 0.25*(xelem(5) + xelem(6) + xelem(7) + xelem(8))
pt2(2) = 0.25*(yelem(5) + yelem(6) + yelem(7) + yelem(8))
pt2(3) = 0.25*(zelem(5) + zelem(7) + zelem(7) + zelem(8))
!
hxi(3) = sqrt((pt2(1)-pt1(1))**2 + (pt2(2)-pt1(2))**2 +
(pt2(3)-pt1(3))**2)
&
!
! Calculate alphabar and isoparametric Reynolds number
!
do idimn = 1,ndimn
Re(idimn) = uxi(idimn)*hxi(idimn)/diff
alphabar(idimn) = 1./tanh(Re(idimn)/2.) - 2./Re(idimn)
enddo
!
GPG_tau = 0.0
!
do idimn = 1,ndimn
GPG_tau = GPG_tau +
alphabar(idimn)*hxi(idimn)*uxi(idimn)
enddo
!
GPG_tau = onesix*GPG_tau/veloc
!
return
end subroutine GPG
!
!
*******************************************************
*********
! THE FOLLOWING SUBROUTINE CALCULATES THE
THREE-D JACOBIAN MATRICES
! "A SUB I" FOR A SAMPLE POINT
!
! THESE MATRICES ARE FOR THE NAVIER-STOKES
SYSTEM OF EQUATION
! WITHOUT PRESSURE CORRECTIONS
!
SUBROUTINE
AJACOB_3D(velo,E,gamma,gamm1,gm3d2,gm1d2,gamm3,aj)
!
!DIR$ INLINEALWAYS AJACOB_3D
!
Use Param_var
! Use thermo_propt
!
Implicit None
!
real,intent(in) :: velo(mdimn),E
real,intent(in) :: gamma,gamm1,gm3d2,gm1d2,gamm3
real,dimension(mdimn,mequa,mequa),intent(out) :: aj
real :: u,v,w,u2,v2,w2,uv,uw,vw,u2pv2pw2,u2pv2,u2pw2,v2pw2
!
! Zero Jacobian
aj = 0.0
!
aj(2,1,3)=1.0
aj(2,2,1)=-uv
aj(2,2,2)=v
aj(2,2,3)=u
aj(2,3,1)=GM1D2*u2pw2+GM3D2*v2
aj(2,3,2)=-GAMM1*u
aj(2,3,3)=-GAMM3*v
aj(2,3,4)=-GAMM1*w
aj(2,3,5)=GAMM1
aj(2,4,1)=-vw
aj(2,4,3)=w
aj(2,4,4)=v
aj(2,5,1)=-GAMMA*E*v+GAMM1*v*u2pv2pw2
aj(2,5,2)=-GAMM1*uv
aj(2,5,3)=GAMMA*E-GM1D2*(u2pw2+3.*v2)
aj(2,5,4)=-GAMM1*vw
aj(2,5,5)=GAMMA*v
!
aj(3,1,4)=1.0
aj(3,2,1)=-uw
aj(3,2,2)=w
aj(3,2,4)=u
aj(3,3,1)=-vw
aj(3,3,3)=w
aj(3,3,4)=v
aj(3,4,1)=GM1D2*u2pv2 + GM3D2*w2
aj(3,4,2)=-GAMM1*u
aj(3,4,3)=-GAMM1*v
aj(3,4,4)=-GAMM3*w
aj(3,4,5)=GAMM1
aj(3,5,1)=-GAMMA*E*w + GAMM1*w*u2pv2pw2
aj(3,5,2)=-GAMM1*uw
aj(3,5,3)=-GAMM1*vw
aj(3,5,4)=GAMMA*E - GM1D2*(u2pv2 + 3.*w2)
aj(3,5,5)=GAMMA*w
!
78
&
visr*(-2.*u*drdx+v*drdy+ w*drdz)))*reinv
bj(1,2,2)=VISR*drdx*DENOM*reinv
bj(1,2,3)=VISLAM*drdy*DENOM*reinv
bj(1,2,4)=VISLAM*drdz*DENOM*reinv
RETURN
end subroutine ajacob_3d
!
!
*******************************************************
***********
! THE FOLLOWING SUBROUTINE CALCULATES THE
JACOBIAN "B SUB I"
! FOR A SAMPLE POINT
!
SUBROUTINE
BJACOB_3D(reinv,cv,VIS,HK,TAU,DUNDX,Unkn,velo,E,bj)
!
!DIR$ INLINEALWAYS BJACOB_3D
!
Use Param_var
! Use thermo_propt
!
Implicit None
!
real,intent(in) :: reinv,cv,vis,hk,tau(mdimn,mdimn)
real,intent(in) ::
DUNDX(mdimn,MEQUA),VELO(MDIMN),UNKN(MEQUA)
real,intent(in) :: E
real,dimension(mdimn,mequa,mequa),intent(out) :: bj
real :: vislam,visr,denom,term1
real :: r,ru,rv,rw,re,u,v,w,u2,v2,w2,u2pv2pw2
real :: drdx,dldx,dmdx,dndx,dedx,drdy,dldy,dmdy,dndy,dedy
real :: drdz,dldz,dmdz,dndz,dedz
!
! Zero Jacobian
bj = 0.0
!
VISLAM=-2.*VIS/3.
visr=2.*vis+vislam
!
DENOM=1./UNKN(1)**2
TERM1=HK*DENOM/CV
!
r = unkn(1)
ru = unkn(2)
rv = unkn(3)
rw = unkn(4)
re = unkn(5)
u = velo(1)
v = velo(2)
w = velo(3)
u2 = u*u
v2 = v*v
w2 = w*w
u2pv2pw2 = u2 + v2 + w2
!
drdx = dundx(1,1)
dldx = dundx(1,2)
dmdx = dundx(1,3)
dndx = dundx(1,4)
dedx = dundx(1,5)
drdy = dundx(2,1)
dldy = dundx(2,2)
dmdy = dundx(2,3)
dndy = dundx(2,4)
dedy = dundx(2,5)
drdz = dundx(3,1)
dldz = dundx(3,2)
dmdz = dundx(3,3)
dndz = dundx(3,4)
dedz = dundx(3,5)
!
bj(1,2,1)=(DENOM*(VISR*dldx+VISLAM*(dmdy+dndz)+
&
bj(1,3,1)=(VIS*DENOM*(dldy+dmdx2.*(u*drdy+v*drdx)))*reinv
bj(1,3,2)=VIS*drdy*DENOM*reinv
bj(1,3,3)=VIS*drdx*DENOM*reinv
bj(1,4,1)=(VIS*DENOM*(dldz+dndx2.*(u*drdz+w*drdx)))*reinv
bj(1,4,2)=VIS*drdz*DENOM*reinv
bj(1,4,4)=VIS*drdx*DENOM*reinv
bj(1,5,1)=u*bj(1,2,1)+v*bj(1,3,1)+w*bj(1,4,1)+(DENOM*(ru*TAU
(1,1) + &
&
rv*TAU(2,1)+rw*TAU(3,1))
&
&
-TERM1*(-dedx+(2.*E-3.*u2pv2pw2)*drdx &
&
+2.*(u*dldx+v*dmdx+w*dndx)))*reinv
bj(1,5,2)=u*bj(1,2,2)+v*bj(1,3,2)+w*bj(1,4,2) + (
&
&
-TAU(1,1)/r - TERM1*(2.*u*drdx-dldx))*reinv
bj(1,5,3)=u*bj(1,2,3)+v*bj(1,3,3)+w*bj(1,4,3) + (-TAU(1,2)/r
&
&
-term1*(-dmdx+2.*v*drdx))*reinv
bj(1,5,4)=u*bj(1,2,4)+v*bj(1,3,4)+w*bj(1,4,4) + (-TAU(1,3)/r &
&
TERM1*(2*w*drdx-dndx))*reinv
bj(1,5,5)=TERM1*drdx*reinv
!
bj(2,2,1)=bj(1,3,1)
bj(2,2,2)=bj(1,3,2)
bj(2,2,3)=bj(1,3,3)
bj(2,3,1)=(DENOM*(VISLAM*(dldx+dndz) +
VISR*(dmdy+u*drdx-2.*v* &
&
drdy+w*drdz)))*reinv
bj(2,3,2)=VISLAM*drdx*DENOM*reinv
bj(2,3,3)=VISR*drdy*DENOM*reinv
bj(2,3,4)=VISLAM*drdz*DENOM*reinv
bj(2,4,1)=(VIS*DENOM*(dmdz+dndy-2.*(v*drdz
+w*drdy)))*reinv
bj(2,4,3)=VIS*DENOM*drdz*reinv
bj(2,4,4)=VIS*DENOM*drdy*reinv
bj(2,5,1)=u*bj(2,2,1)+v*bj(2,3,1)+w*bj(2,4,1) + (DENOM*(ru*
&
&
TAU(1,2)+rv*TAU(2,2)+rw*TAU(2,3))
&
&
-TERM1*(-dedy+(2.*E-3.*u2pv2pw2)
&
&
*drdy + 2.*(u*dldy+v*dmdy+w*dndy)))*reinv
bj(2,5,2)=u*bj(2,2,2) + v*bj(2,3,2) + w*bj(2,4,2)+(-TAU(2,1)/r &
&
TERM1*(-dldy+2.*u*drdy))*reinv
bj(2,5,3)=u*bj(2,2,3)+v*bj(2,3,3)+w*bj(2,4,3)+
&
&
(-TAU(2,2)/r - TERM1*(2.*v*drdy - dmdy))*reinv
bj(2,5,4)=u*bj(2,2,4)+v*bj(2,3,4)+w*bj(2,4,4) + (-TAU(2,3)/r
&
&
-TERM1*(2.*w*drdy-dndy))*reinv
bj(2,5,5)=TERM1*drdy*reinv
!
bj(3,2,1)=bj(1,4,1)
bj(3,2,2)=bj(1,4,2)
bj(3,2,4)=bj(1,4,4)
bj(3,3,1)=bj(2,4,1)
bj(3,3,3)=bj(2,4,3)
bj(3,3,4)=bj(2,4,4)
bj(3,4,1)=(DENOM*(VISR*(dndz+u*drdx+v*
&
&
drdy-2.*w*drdz)+VISLAM*(dldx+ dmdy)))*reinv
bj(3,4,2)=VISLAM*drdx*DENOM*reinv
bj(3,4,3)=VISLAM*drdy*DENOM*reinv
bj(3,4,4)=VISR*drdz*DENOM*reinv
bj(3,5,1)=u*bj(3,2,1)+v*bj(3,3,1)+w*bj(3,4,1) + ( &
79
cj(1,1,5,3)=rv/r*cj(1,1,3,3) + TERM1*rv*reinv
cj(1,1,5,4)=rw/r*cj(1,1,4,4) + TERM1*rw*reinv
cj(1,1,5,5)=-hkocv/r*reinv
&
DENOM*(ru*TAU(3,1)+rv*TAU(3,2)+rw* &
&
TAU(3,3))-term1*(-dedz+(2.*E-3.*u2pv2pw2)*drdz &
&
+2.*(u*dldz+v*dmdz+w*dndz)))*reinv
bj(3,5,2)=u*bj(3,2,2)+v*bj(3,3,2)+w*bj(3,4,2) + (-TAU(3,1)/r
!
cj(1,2,2,1)=VISLAM*rv*DENOM*reinv
cj(1,2,2,3)=-VISLAM/r*reinv
cj(1,2,3,1)=VIS*ru*DENOM*reinv
cj(1,2,3,2)=-VIS/r*reinv
cj(1,2,5,1)=ru/r*cj(1,2,2,1)+rv/r*cj(1,2,3,1)
cj(1,2,5,2)=rv/r*cj(1,2,3,2)
cj(1,2,5,3)=ru/r*cj(1,2,2,3)
&
&
-TERM1*(2.*u*drdz-dldz))*reinv
bj(3,5,3)=u*bj(3,2,3)+v*bj(3,3,3)+w*bj(3,4,3) + (-TAU(3,2)/r
&
&
-TERM1*(2.*v*drdz-dmdz))*reinv
bj(3,5,4)=u*bj(3,2,4)+v*bj(3,3,4)+w*bj(3,4,4) +
&
&
(-TAU(3,3)/r - TERM1*(2.*w*drdz - dndz))*reinv
bj(3,5,5)=TERM1*drdz*reinv
!
cj(1,3,2,1)=VISLAM*rw*DENOM*reinv
cj(1,3,2,4)=-VISLAM/r*reinv
cj(1,3,4,1)=VIS*ru*DENOM*reinv
cj(1,3,4,2)=-VIS/r*reinv
cj(1,3,5,1)=ru/r*cj(1,3,2,1)+rw/r*cj(1,3,4,1)
cj(1,3,5,2)=rw/r*cj(1,3,4,2)
cj(1,3,5,4)=ru/r*cj(1,3,2,4)
!
RETURN
end subroutine BJACOB_3D
!
!
*******************************************************
*******
! THE FOLLOWING SUBROUTINE CALCULATES THE
JACOBIAN "C SUB IJ"
! ON A SAMPLE POINT
!
SUBROUTINE CJACOB_3D(reinv,cv,VIS,HK,UNKN,cj)
!
!DIR$ INLINEALWAYS CJACOB_3D
!
Use Param_var
! Use thermo_propt
!
Implicit None
!
real,intent(in) :: reinv,cv,vis,hk
real,intent(in) :: unkn(mequa)
real,dimension(mdimn,mdimn,mequa,mequa),intent(out) :: cj
!
cj(2,1,2,1)=cj(1,1,3,1)
cj(2,1,2,3)=cj(1,1,3,3)
cj(2,1,3,1)=VISLAM*ru*DENOM*reinv
cj(2,1,3,2)=-VISLAM/r*reinv
cj(2,1,5,1)=ru/r*cj(2,1,2,1)+rv/r*cj(2,1,3,1)
cj(2,1,5,2)=rv/r*cj(2,1,3,2)
cj(2,1,5,3)=ru/r*cj(2,1,2,3)
!
cj(2,2,2,1)=cj(1,2,3,1)
cj(2,2,2,2)=cj(1,2,3,2)
cj(2,2,3,1)=VISR*rv*DENOM*reinv
cj(2,2,3,3)=-VISR/r*reinv
cj(2,2,4,1)=VIS*rw*DENOM*reinv
cj(2,2,4,4)=-VIS/r*reinv
cj(2,2,5,1)=(ru*cj(2,2,2,1)+rv*cj(2,2,3,1)+rw*cj(2,2,4,1))/r
&
- TERM1*(-re + ru2prv2prw2/r)*reinv
cj(2,2,5,2)=ru/r*cj(2,2,2,2) + TERM1*ru*reinv
cj(2,2,5,3)=rv/r*cj(2,2,3,3) + TERM1*rv*reinv
cj(2,2,5,4)=rw/r*cj(2,2,4,4) + TERM1*rw*reinv
cj(2,2,5,5)=-hkocv/r*reinv
real :: velo(mdimn)
real :: vislam,visr,r,ru,rv,rw,re,ru2,rv2,rw2,ru2prv2prw2
real :: denom,term1,hkocv
!
!
!
cj(2,3,3,1)=VISLAM*rw*DENOM*reinv
cj(2,3,3,4)=-VISLAM/r*reinv
cj(2,3,4,1)=VIS*rv*DENOM*reinv
cj(2,3,4,3)=-VIS/r*reinv
cj(2,3,5,1)=rv/r*cj(2,3,3,1)+rw/r*cj(2,3,4,1)
cj(2,3,5,3)=rw/r*cj(2,3,4,3)
cj(2,3,5,4)=rv/r*cj(2,3,3,4)
Zero Jacobian
cj= 0.0
!
VISLAM=-2.*VIS/3.
visr=2.*vis+vislam
!
r = unkn(1)
ru = unkn(2)
rv = unkn(3)
rw = unkn(4)
re = unkn(5)
ru2 = ru*ru
rv2 = rv*rv
rw2 = rw*rw
ru2prv2prw2 = ru2 + rv2 + rw2
!
cj(3,1,2,1)=cj(1,1,4,1)
cj(3,1,2,4)=cj(1,1,4,4)
cj(3,1,4,1)=VISLAM*ru*DENOM*reinv
cj(3,1,4,2)=-VISLAM/r*reinv
cj(3,1,5,1)=ru/r*cj(3,1,2,1)+rw/r*cj(3,1,4,1)
cj(3,1,5,2)=rw/r*cj(3,1,4,2)
cj(3,1,5,4)=ru/r*cj(3,1,2,4)
cj(3,2,3,1)=cj(2,2,4,1)
cj(3,2,3,4)=cj(2,2,4,4)
cj(3,2,4,1)=VISLAM*rv*DENOM*reinv
cj(3,2,4,3)=-VISLAM/r*reinv
cj(3,2,5,1)=rv/r*cj(3,2,3,1)+rw/r*cj(3,2,4,1)
cj(3,2,5,3)=rw/r*cj(3,2,4,3)
cj(3,2,5,4)=rv/r*cj(3,2,3,4)
!
DENOM=1./r**2
TERM1=HK/CV*DENOM
hkocv = hk/cv
!
cj(1,1,2,1)=VISR*ru*DENOM*reinv
cj(1,1,2,2)=-VISR/r*reinv
cj(1,1,3,1)=VIS*rv*DENOM*reinv
cj(1,1,3,3)=-VIS/r*reinv
cj(1,1,4,1)=VIS*rw*DENOM*reinv
cj(1,1,4,4)=-VIS/r*reinv
cj(1,1,5,1)=(ru*cj(1,1,2,1)+ rv*cj(1,1,3,1) + rw*cj(1,1,4,1))/r &
&
-TERM1*(-re + ru2prv2prw2/r)*reinv
cj(1,1,5,2)=ru/r*cj(1,1,2,2) + TERM1*ru*reinv
!
cj(3,3,2,1)=cj(1,3,4,1)
cj(3,3,2,2)=cj(1,3,4,2)
cj(3,3,3,1)=cj(2,3,4,1)
cj(3,3,3,3)=cj(2,3,4,3)
cj(3,3,4,1)=VISR*rw*DENOM*reinv
cj(3,3,4,4)=-VISR/r*reinv
80
&
dg1dx1(3) = -vis*(d2udx2(1,1,2) + d2udx2(2,1,1))*reinv
dg1dx1(4) = -vis*(d2udx2(1,1,3) + d2udx2(3,1,1))*reinv
dg1dx1(5) = G(1,2)*dudx(1,1) + velo(1)*dg1dx1(2) + G(1,3)*
cj(3,3,5,1)=(ru*cj(3,3,2,1)+rv*cj(3,3,3,1)+rw*cj(3,3,4,1))/r &
&
- TERM1*(-re + ru2prv2prw2/r)*reinv
cj(3,3,5,2)=ru/r*cj(3,3,2,2) + TERM1*ru*reinv
cj(3,3,5,3)=rv/r*cj(3,3,3,3) + TERM1*rv*reinv
cj(3,3,5,4)=rw/r*cj(3,3,4,4) + TERM1*rw*reinv
cj(3,3,5,5)=-hkocv/r*reinv
&
&
dudx(2,1) + velo(2)*dg1dx1(3) + G(1,4)*dudx(3,1) +
&
velo(3)*dg1dx1(4) - hk*d2tdx2(1)*reinv
&
!
!
RETURN
end subroutine cjacob_3d
dg2dx2(1) = 0.0
dg2dx2(2) = -vis*(d2udx2(1,2,2) + d2udx2(2,2,1))*reinv
dg2dx2(3) = (-vis43*d2udx2(2,2,2)+vis23*(d2udx2(1,2,1) + &
&
d2udx2(3,2,3)))*reinv
dg2dx2(4) = -vis*(d2udx2(2,2,3) + d2udx2(3,2,2))*reinv
dg2dx2(5) = G(2,2)*dudx(1,2) + velo(1)*dg2dx2(2) + G(2,3)*
!
!
*******************************************************
*****
! THE FOLLOWING SUBROUTINE CALCULATES THE
VISCOUS FLUX AT A
! NODAL POINT
!
SUBROUTINE
VISCFLX_3D(reinv,TAU,HK,vis,dudx,dtdx,velo,d2tdx2, &
&
d2udx2,G,dgjdxj)
!
!DIR$ INLINEALWAYS VISCFLX_3D
!
Use param_var
!
Implicit None
!
real,intent(in) :: reinv,hk,vis
real,intent(in) :: TAU(mdimn,mdimn),DTDX(mdimn)
REAL,intent(out) :: G(MDIMN,MEQUA),dgjdxj(mequa)
real,intent(in) :: dudx(mdimn,mdimn),velo(mdimn)
real,intent(in) :: d2tdx2(mdimn),d2udx2(mdimn,mdimn,mdimn)
real :: dg1dx1(mequa),dg2dx2(mequa),dg3dx3(mequa)
real :: vis43,vis23
integer :: iequa
!
vis43 = 4./3.*vis
vis23 = 2./3.*vis
!
G(1,1)=0.0
G(1,2)=-TAU(1,1)*reinv
G(1,3)=-TAU(1,2)*reinv
&
&
dudx(2,2) + velo(2)*dg2dx2(3) + G(2,4)*dudx(3,2) &
+ velo(3)*dg2dx2(4) - hk*d2tdx2(2)*reinv
!
dg3dx3(1) = 0.0
dg3dx3(2) = -vis*(d2udx2(1,3,3) + d2udx2(3,1,3))*reinv
dg3dx3(3) = -vis*(d2udx2(2,3,3) + d2udx2(3,2,3))*reinv
dg3dx3(4) = (-vis43*d2udx2(3,3,3) + vis23*(d2udx2(1,1,3) +
&
&
d2udx2(2,2,3)))*reinv
dg3dx3(5) = G(3,2)*dudx(1,3) + velo(1)*dg3dx3(2) + G(3,3)*
&
&
&
dudx(2,3) + velo(2)*dg3dx3(3) + G(3,4)*dudx(3,3) &
+ velo(3)*dg3dx3(4) - hk*d2tdx2(3)*reinv
!
do iequa = 1,mequa
dgjdxj(iequa) = dg1dx1(iequa) + dg2dx2(iequa) +
dg3dx3(iequa)
!
dgjdxj(iequa) = 0.0
enddo
!
RETURN
end subroutine viscflx_3d
!
!
*******************************************************
*******
! THE FOLLOWING SUBROUTINE CALCULATES THE "U"
VECTOR AND
! JACOBIANS AT THE GAUSSIAN POINT OF INTEREST
FOR THE
! BOUNDARY TERMS
!
SUBROUTINE
EVALBOU3D(NDIMN,NEQUA,ilbou,DPIDX,IG,VELO, &
&
E,T,unkn,DUDX,dtdx,dundx,cflux,dfxdx,&
&
d2tdx2,d2udx2)
!
Use flow_var
Use thermo_propt
Use Conv_flux
Use shapbou_3d
!
Implicit None
!
integer,intent(in) :: ndimn,nequa,ig
integer,intent(in) :: ilbou(4)
real,intent(in) :: dpidx(mdimn,4,ngsurf)
real,intent(out) :: E,T
REAL,intent(out) ::
CFLUX(NDIMN,NEQUA),DFXDX(NDIMN,NEQUA)
real,intent(out) :: dtdx(ndimn)
REAL,intent(out) ::
DUNDX(NDIMN,NEQUA),unkn(nequa),velo(ndimn)
real,intent(out) :: dudx(mdimn,mdimn)
real,intent(out) :: d2tdx2(mdimn),d2udx2(mdimn,mdimn,mdimn)
G(1,4)=-TAU(1,3)*reinv
G(1,5)=(-TAU(1,1)*VELO(1) - TAU(1,2)*VELO(2) TAU(1,3)*VELO(3) - &
&
HK*DTDX(1))*reinv
!
G(2,1)=0.0
G(2,2)=-TAU(2,1)*reinv
G(2,3)=-TAU(2,2)*reinv
G(2,4)=-TAU(2,3)*reinv
G(2,5)=(-TAU(2,1)*VELO(1) - TAU(2,2)*VELO(2) TAU(2,3)*VELO(3) - &
&
HK*DTDX(2))*reinv
!
G(3,1) = 0.0
G(3,2)=-TAU(3,1)*reinv
G(3,3)=-TAU(3,2)*reinv
G(3,4)=-TAU(3,3)*reinv
G(3,5)=(-TAU(3,1)*VELO(1) - TAU(3,2)*VELO(2) TAU(3,3)*VELO(3) - &
&
HK*DTDX(3))*reinv
!
! DGJDXJ
!
dg1dx1(1) = 0.0
dg1dx1(2) = (-vis43*d2udx2(1,1,1)+vis23*(d2udx2(2,1,2) +
&
&
d2udx2(3,1,3)))*reinv
81
CFLUX(jdimn,IEQUA) =
CFLUX(jdimn,IEQUA)+PHI(I,IG)*
&
&
F(IPOIN,jdimn,IEQUA)
enddo
enddo
enddo
!
RETURN
end subroutine evalbou3d
!
!
*******************************************************
********
! Subroutine to calculate the normal vector and the spatial
! derivatives of the shape functions for a two-d boundary surface
!
Subroutine calnorm3(ndimn,ndbou,ifacdir,locnode,enorm,en)
!
Use param_var
Use grid_info
Use shapbou_3d
!
Implicit None
!
integer,intent(in) :: ndimn,ifacdir,locnode(4)
integer,intent(in) :: ndbou
real,intent(out) :: en(ndimn,ngsurf),enorm(ndimn)
!
real :: xelem(ndimn,4),xdiff(ndimn)
real :: Lambda(ndimn),gama(ndimn),Mu(ndimn)
real :: acoortr(ndimn,ndimn)
real :: dpdxp(4),dpdyp(4)
! Deriviative in prime directions
real :: d2phidx2(4),d2phidy2(4)
!
integer :: idimn,inode,jnode,j,ig
real :: sum,el,dx_dxi,dy_dxi,dz_dxi,dx_deta,dy_deta,dz_deta
real :: dx_dxieta,dy_dxieta,dz_dxieta,dxdxi,dxdeta,dydxi,dydeta
real :: dxxieta,dyxieta,djacinv
real :: endir
!
do idimn = 1,ndimn
do inode = 1,4
xelem(idimn,inode) = x(idimn,locnode(inode))
enddo
enddo
!
! calculate unit vectors (e12)
!
sum = 0.0
!
do idimn = 1,ndimn
xdiff(idimn) = xelem(idimn,2) - xelem(idimn,1)
sum = sum + xdiff(idimn)*xdiff(idimn)
enddo
!
el = sqrt(sum)
!
do j = 1,ndimn
Lambda(j) = xdiff(j)/el
enddo
!
! vector e14
!
sum = 0.0
!
do idimn = 1,ndimn
xdiff(idimn) = xelem(idimn,4) - xelem(idimn,1)
sum = sum + xdiff(idimn)*xdiff(idimn)
enddo
!
!
integer :: idimn,jdimn,iequa,i,L,iordr
integer :: ipoin
!
T = 0.0
E=0.0
!
do idimn = 1, ndimn
do jdimn = 1,ndimn
dudx(idimn,jdimn) = 0.0
d2udx2(1,idimn,jdimn) = 0.0
d2udx2(2,idimn,jdimn) = 0.0
d2udx2(3,idimn,jdimn) = 0.0
enddo
velo(idimn) = 0.0
dtdx(idimn) = 0.0
d2tdx2(idimn) = 0.0
enddo
DO IEQUA = 1, NEQUA
unkn(iequa) = 0.00
do idimn = 1,ndimn
DUNDX(idimn,IEQUA) = 0.0
dfxdx(idimn,iequa) = 0.0
cflux(idimn,iequa) = 0.0
enddo
ENDDO
!
DO I=1,4
L=ILBOU(I)
iordr = nequa*(L-1)
E=E+ENERG(L)*PHI(I,IG)
T = T + TEMPR(L)*PHI(I,IG)
!
do idimn = 1, ndimn
VELO(idimn)=VELO(idimn)+VEL(idimn,L)*PHI(I,IG)
dtdx(idimn) = dtdx(idimn) + dpidx(idimn,i,ig)*tempr(L)
d2tdx2(idimn) = d2tdx2(idimn) + d2phidx(idimn,idimn,i,ig)*
&
&
tempr(L)
do jdimn = 1,ndimn
dudx(idimn,jdimn) = dudx(idimn,jdimn) + dpidx(jdimn,i,ig)
&
&
*vel(idimn,L)
d2udx2(1,idimn,jdimn) = d2udx2(1,idimn,jdimn) +
&
d2phidx(idimn,jdimn,i,ig)*vel(1,L)
d2udx2(2,idimn,jdimn) = d2udx2(2,idimn,jdimn) +
&
d2phidx(idimn,jdimn,i,ig)*vel(2,L)
d2udx2(3,idimn,jdimn) = d2udx2(3,idimn,jdimn) +
&
d2phidx(idimn,jdimn,i,ig)*vel(3,L)
enddo
enddo
&
&
&
!
DO IEQUA = 1, NEQUA
Unkn(iequa)=Unkn(iequa)+U(iordr+iequa)*PHI(I,IG)
do jdimn = 1,ndimn
DUNDX(jdimn,IEQUA) = DUNDX(jdimn,IEQUA) +
DPIDX(jdimn,I,IG)* &
&
U(iordr+IEQUA)
enddo
ENDDO
enddo
!
DO IEQUA = 1, NEQUA
DO I = 1, 4
IPOIN = ILBOU(I)
do jdimn = 1,ndimn
DFXDX(jdimn,IEQUA) = DFXDX(jdimn,IEQUA) +
DPIDX(jdimn,I,IG)* &
&
F(IPOIN,jdimn,IEQUA)
82
&
el = sqrt(sum)
do j = 1,ndimn
Mu(j) = xdiff(j)/el
enddo
!
!
!
&
&
dydeta = acoortr(2,1)*dx_deta + &
acoortr(2,2)*dy_deta + &
acoortr(2,3)*dz_deta
!
dxxieta = acoortr(1,1)*dx_dxieta + acoortr(1,2)*dy_dxieta +
direction of the normal vector
&
&
if(ifacdir.eq.1) endir = 1.
if(ifacdir.eq.2) endir = -1.
!
!
!
acoortr(2,3)*dz_dxi
!
!
acoortr(1,3)*dz_dxieta
dyxieta = acoortr(2,1)*dx_dxieta + acoortr(2,2)*dy_dxieta +
&
&
vector normal to surface
acoortr(2,3)*dz_dxieta
!
detjac(ig) = dxdxi*dydeta - dydxi*dxdeta
enorm(1) = endir*(Lambda(2)*Mu(3) - Lambda(3)*Mu(2))
enorm(2) = endir*(Lambda(3)*Mu(1) - Lambda(1)*Mu(3))
enorm(3) = endir*(Lambda(1)*Mu(2) - Lambda(2)*Mu(1))
!
if(detjac(ig).lt.1.0e-12) then
write(*,2000)detjac(ig)
do inode = 1,4
!
! write(45,1000)(enorm(j), j=1,ndimn)
1000 format(' Direction Cosines: ',3e16.8)
!
! y-prime axis
!
gama(1) = endir*(enorm(2)*Lambda(3) - enorm(3)*Lambda(2))
gama(2) = endir*(enorm(3)*Lambda(1) - enorm(1)*Lambda(3))
gama(3) = endir*(enorm(1)*Lambda(2) - enorm(2)*Lambda(1))
!
! coordinate transformation matrix
!
do idimn = 1,ndimn
acoortr(1,idimn) = Lambda(idimn)
acoortr(2,idimn) = gama(idimn)
acoortr(3,idimn) = enorm(idimn)
enddo
!
! components of surface Jacobian
!
do ig = 1,ngsurf
!
dx_dxi = 0.0
dy_dxi = 0.0
dz_dxi = 0.0
dx_deta = 0.0
dy_deta = 0.0
dz_deta = 0.0
dx_dxieta = 0.0
dy_dxieta = 0.0
dz_dxieta = 0.0
!
do inode = 1,4
dx_dxi = dx_dxi + dpxi(1,inode,ig)*xelem(1,inode)
dy_dxi = dy_dxi + dpxi(1,inode,ig)*xelem(2,inode)
dz_dxi = dz_dxi + dpxi(1,inode,ig)*xelem(3,inode)
dx_deta = dx_deta + dpxi(2,inode,ig)*xelem(1,inode)
dy_deta = dy_deta + dpxi(2,inode,ig)*xelem(2,inode)
dz_deta = dz_deta + dpxi(2,inode,ig)*xelem(3,inode)
dx_dxieta = dx_dxieta + d2phi(inode,ig)*xelem(1,inode)
dy_dxieta = dy_dxieta + d2phi(inode,ig)*xelem(2,inode)
dz_dxieta = dz_dxieta + d2phi(inode,ig)*xelem(3,inode)
enddo
!
dxdxi = acoortr(1,1)*dx_dxi + &
&
acoortr(1,2)*dy_dxi +
&
&
acoortr(1,3)*dz_dxi
!
dxdeta = acoortr(1,1)*dx_deta + &
&
acoortr(1,2)*dy_deta + &
&
acoortr(1,3)*dz_deta
!
dydxi = acoortr(2,1)*dx_dxi + &
&
acoortr(2,2)*dy_dxi +
&
write(*,2100)locnode(inode),(xelem(idimn,inode),idimn=1,ndimn)
enddo
write(*,*)' Normal Direction: ',endir
write(*,*)' Transformation Matrix, ifacdir = ',ifacdir
write(*,*)(Lambda(jnode),jnode=1,3)
write(*,*)(Mu(jnode),jnode=1,3)
write(*,*)(enorm(jnode),jnode=1,3)
endif
!
2000 format(' SURFACE DETERMINANT OF JACOBIAN IS
NEGATIVE ',/, &
&
' DETERMINANT OF JACOBIAN IS: ',e16.8,/,
&
&
' COORDINATES ARE:')
2100 format(i8,3e16.8)
!
djacinv = 1./detjac(ig)
!
do inode = 1,4
dpdxp(inode) = (dydeta*dpxi(1,inode,ig) &
&
dydxi*dpxi(2,inode,ig))*djacinv
!
dpdyp(inode) = (-dxdeta*dpxi(1,inode,ig) +
&
&
dxdxi*dpxi(2,inode,ig))*djacinv
!
enddo
!
! Spatial derivatives of shape functions and normal vector
!
do idimn = 1,ndimn
do inode = 1,4
!
dshpdx(idimn,inode,ig) = acoortr(1,idimn)*dpdxp(inode)
&
&
+ acoortr(2,idimn)*dpdyp(inode)
!
enddo
!
en(idimn,ig) = enorm(idimn)*w_w(ig)*detjac(ig)
!
enddo
!
! Second derivatives of shape functions
!
call d2shapsurf(4,ig,ndbou,dxxieta,dyxieta,dxdxi,dxdeta, &
&
dydxi,dydeta,d2phidx2,d2phidy2)
!
do inode = 1,4
!
d2phidx(1,1,inode,ig) = acoortr(1,1)*acoortr(1,1)*
&
&
d2phidx2(inode) + acoortr(2,1)*
&
83
&
detjac2 = 1./detjac(igaus)**2
detjac3 = 1./detjac(igaus)**3
acoortr(2,1)*d2phidy2(inode)
!
&
d2phidx(2,2,inode,ig) = acoortr(1,2)*acoortr(1,2)*
d2phidx2(inode) + acoortr(2,2)*
!
&
&
&
&
&
acoortr(2,2)*d2phidy2(inode)
!
&
d2phidx(3,3,inode,ig) = acoortr(1,3)*acoortr(1,3)*
d2phidx2(inode) + acoortr(2,3)*
do inode = 1, nnode
term1 = -detjac3*djacdxi*(dydeta**2*
dpxi(1,inode,igaus) - dydeta* &
dydxi*dpxi(2,inode,igaus))
&
!
&
term2 = detjac2*(dydeta*dyxieta*dpxi(1,inode,igaus)
&
&
&
acoortr(2,3)*d2phidy2(inode)
&
- dydeta*dydxi*d2phi(inode,igaus))
&
&
term3 = detjac3*djacdeta*(dydxi*dydeta*
&
dpxi(1,inode,igaus) - dydxi**2*
&
dpxi(2,inode,igaus))
&
&
term4 = -detjac2*(dydxi*dydeta*
d2phi(inode,igaus) - dydxi*dyxieta*
dpxi(2,inode,igaus))
!
!
&
d2phidx(1,2,inode,ig) = acoortr(1,1)*acoortr(1,2)*
d2phidx2(inode) + acoortr(2,1)*
&
&
&
!
acoortr(2,2)*d2phidy2(inode)
!
d2phidx(2,1,inode,ig) = d2phidx(1,2,inode,ig)
!
&
d2phidx(1,3,inode,ig) = acoortr(1,1)*acoortr(1,3)*
d2phidx2(inode) + acoortr(2,1)*
!
!
!
&
&
&
&
&
d2phi/dx2
d2phidx2(inode) = term1 + term2 + term3 + term4
acoortr(2,3)*d2phidy2(inode)
!
!
d2phidx(3,1,inode,ig) = d2phidx(1,3,inode,ig)
&
&
term1 = detjac3*djacdxi*(-dxdeta**2* &
dpxi(1,inode,igaus) + dxdeta* &
dxdxi*dpxi(2,inode,igaus))
&
&
term2 = -detjac2*(-dxdeta*dxxieta*
dpxi(1,inode,igaus) + dxdeta* &
dxdxi*d2phi(inode,igaus))
!
d2phidx(2,3,inode,ig) = acoortr(1,2)*acoortr(1,3)*
&
d2phidx2(inode) + acoortr(2,2)*
&
&
acoortr(2,3)*d2phidy2(inode)
&
!
!
d2phidx(3,2,inode,ig) = d2phidx(2,3,inode,ig)
&
!
!
&
&
term3 = -detjac3*djacdeta*(-dxdxi*dxdeta* &
dpxi(1,inode,igaus) + dxdxi**2*
&
dpxi(2,inode,igaus))
&
&
term4 = detjac2*(-dxdxi*dxdeta*
d2phi(inode,igaus) + dxdxi*dxxieta* &
dpxi(2,inode,igaus))
enddo
!
enddo
!
!
return
end subroutine calnorm3
!
!
*******************************************************
********
! Subroutine to calculate spatial second derivative of shape
! functions for numerical damping
!
subroutine d2shapsurf(nnode,igaus,ndbou,dxxieta,dyxieta,dxdxi,
&
&
dxdeta,dydxi,dydeta,d2phidx2,d2phidy2)
!
Use param_var
Use Gaus_quad
Use grid_info
Use shapbou_3d
!
Implicit None
!
integer,intent(in) :: ndbou
!
integer,intent(in) :: nnode,igaus
real,intent(in) :: dxxieta,dyxieta,dxdxi,dxdeta,dydxi,dydeta
!
real,intent(out) :: d2phidx2(ndbou),d2phidy2(ndbou)
integer :: inode
real :: djacdxi,djacdeta,detjac2,detjac3
real :: term1,term2,term3,term4
!
djacdxi = dxdxi*dyxieta - dxxieta*dydeta
djacdeta = dxxieta*dydeta - dxdeta*dyxieta
!
!
!
!
&
d2phi/dy2
d2phidy2(inode) = term1 + term2 + term3 + term4
!
&
&
term1 = -detjac3*djacdxi*(-dydeta*dxdeta* &
dpxi(1,inode,igaus) + dydeta* &
dxdxi* dpxi(2,inode,igaus))
!
term2 = detjac2*(-dydeta*dxxieta*dpxi(1,inode,igaus)
&
&
+ dydeta*dxdxi*
&
d2phi(inode,igaus))
&
&
term3 = detjac3*djacdeta*(-dydxi*dxdeta* &
dpxi(1,inode,igaus) + dydxi*
&
dxdxi*dpxi(2,inode,igaus))
&
!
!
&
&
term4 = -detjac2*(-dydxi*dxdeta*
d2phi(inode,igaus) + dydxi*dxxieta*
dpxi(2,inode,igaus))
&
&
!
! d2phi/dxdy
!
!
d2phidx(1,2,inode,igaus) = term1 + term2 + term3 +
term4
!
!
term1 = detjac3*djacdxi*(dxdeta*dydeta*
! &
dpxi(1,inode,igaus) - dxdeta*
84
!
!
!
!
!
!
!
!
!
!
!
&
!
!
!
!
!
!
dydxi*dpxi(2,inode,igaus))
term2 = -detjac2*(dxdeta*dyxieta*dpxi(1,inode,igaus)
&
- dxdeta*dydxi*d2phi(inode,igaus))
term3 = -detjac3*djacdeta*(dxdxi*dydeta*
&
dpxi(1,inode,igaus) - dxdxi*
&
dydxi*dpxi(2,inode,igaus))
&
dpxi(2,inode,igaus))
d2phidydx
d2phidx(2,1,inode,igaus) = term1 + term2 + term3 + term4
enddo
!
return
end subroutine d2shapsurf
term4 = detjac2*(dxdxi*dydeta*
&
d2phi(inode,igaus) - dxdxi*dyxieta*
!
85
Fly UP