xnpster/spbt
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

initial

Browse Source
This commit is contained in:
Mikhail Kocharmin
2025-05-06 22:04:43 +03:00
commit 784a8f2ec7
29 changed files with 5922 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

186
initialize_bt.for Normal file
View File

@@ -0,0 +1,186 @@
! *** generated by SAPFOR with version 2412 and build date: Apr 29 2025 22:44:14
! *** Enabled options ***:
! *** maximum shadow width is 50 percent
! *** generated by SAPFOR
!---------------------------------------------------------------------
!---------------------------------------------------------------------
!---------------------------------------------------------------------
! This subroutine initializes_bt the field variable u using
! tri-linear transfinite interpolation of the boundary values
!---------------------------------------------------------------------
subroutine initialize_bt ()
include 'header3d_bt.h'
integer :: i,j,k,m,ix,iy,iz
double precision :: xi,eta,zeta,pface(5,3,2),pxi,peta,pzeta,temp(
&5),xi1,yi1,zi1
xi = 0.0
eta = 0.0
zeta = 0.0
!$SPF PARALLEL_REG r0
! DVM$ PARALLEL (K,J,I) ON U(*,I,J,K), SHADOW_COMPUTE ,PRIVATE (M)
! DVM$ REGION OUT (U)
!---------------------------------------------------------------------
! Later (in compute_rhs) we compute 1/u for every element. A few of
! the corner elements are not used, but it convenient (and faster)
! to compute the whole thing with a simple loop. Make sure those
! values are nonzero by initializing the whole thing here.
!---------------------------------------------------------------------
do k = 0,imax - 1
do j = 0,imax - 1
do i = 0,imax - 1
do m = 1,5
u(m,i,j,k) = 1.0
enddo
enddo
enddo
enddo
!$SPF ANALYSIS(PRIVATE(temp, pface))
! DVM$ PARALLEL (K,J,I) ON U(*,I,J,K), PRIVATE (M,ZETA,ETA,XI,IX,IY,IZ,PX
! DVM$&I,PETA,PZETA,PFACE,XI1,YI1,ZI1,TEMP),SHADOW_COMPUTE
do k = 0,grid_points(3) - 1
do j = 0,grid_points(2) - 1
do i = 0,grid_points(1) - 1
zeta = dble (k) * dnzm1
eta = dble (j) * dnym1
xi = dble (i) * dnxm1
do ix = 1,2
! call exact_solution_bt(dble(ix-1), eta, zeta, Pface(1,1,ix))
xi1 = dble (ix - 1)
do m = 1,5
pface(m,1,ix) = ce(m,1) + xi1 * (ce(m,2) + xi1 * (c
&e(m,5) + xi1 * (ce(m,8) + xi1 * ce(m,11)))) + eta * (ce(m,3) + eta
& * (ce(m,6) + eta * (ce(m,9) + eta * ce(m,12)))) + zeta * (ce(m,4)
& + zeta * (ce(m,7) + zeta * (ce(m,10) + zeta * ce(m,13))))
enddo
enddo
do iy = 1,2
! call exact_solution_bt(xi, dble(iy-1) , zeta, Pface(1,2,iy))
yi1 = dble (iy - 1)
do m = 1,5
pface(m,2,iy) = ce(m,1) + xi * (ce(m,2) + xi * (ce(
&m,5) + xi * (ce(m,8) + xi * ce(m,11)))) + yi1 * (ce(m,3) + yi1 * (
&ce(m,6) + yi1 * (ce(m,9) + yi1 * ce(m,12)))) + zeta * (ce(m,4) + z
&eta * (ce(m,7) + zeta * (ce(m,10) + zeta * ce(m,13))))
enddo
enddo
do iz = 1,2
! call exact_solution_bt(xi, eta, dble(iz-1), Pface(1,3,iz))
zi1 = dble (iz - 1)
do m = 1,5
pface(m,3,iz) = ce(m,1) + xi * (ce(m,2) + xi * (ce(
&m,5) + xi * (ce(m,8) + xi * ce(m,11)))) + eta * (ce(m,3) + eta * (
&ce(m,6) + eta * (ce(m,9) + eta * ce(m,12)))) + zi1 * (ce(m,4) + zi
&1 * (ce(m,7) + zi1 * (ce(m,10) + zi1 * ce(m,13))))
enddo
enddo
do m = 1,5
pxi = xi * pface(m,1,2) + (1.0d0 - xi) * pface(m,1,1)
peta = eta * pface(m,2,2) + (1.0d0 - eta) * pface(m,2,
&1)
pzeta = zeta * pface(m,3,2) + (1.0d0 - zeta) * pface(m
&,3,1)
u(m,i,j,k) = pxi + peta + pzeta - pxi * peta - pxi * p
&zeta - peta * pzeta + pxi * peta * pzeta
enddo
if (i .eq. 0) then
do m = 1,5
temp(m) = ce(m,1) + xi * (ce(m,2) + xi * (ce(m,5) +
& xi * (ce(m,8) + xi * ce(m,11)))) + eta * (ce(m,3) + eta * (ce(m,6
&) + eta * (ce(m,9) + eta * ce(m,12)))) + zeta * (ce(m,4) + zeta *
&(ce(m,7) + zeta * (ce(m,10) + zeta * ce(m,13))))
enddo
do m = 1,5
u(m,i,j,k) = temp(m)
enddo
endif
if (i .eq. grid_points(1) - 1) then
xi = 1.0d0
do m = 1,5
temp(m) = ce(m,1) + xi * (ce(m,2) + xi * (ce(m,5) +
& xi * (ce(m,8) + xi * ce(m,11)))) + eta * (ce(m,3) + eta * (ce(m,6
&) + eta * (ce(m,9) + eta * ce(m,12)))) + zeta * (ce(m,4) + zeta *
&(ce(m,7) + zeta * (ce(m,10) + zeta * ce(m,13))))
enddo
do m = 1,5
u(m,i,j,k) = temp(m)
enddo
endif
if (j .eq. 0) then
zeta = dble (k) * dnzm1
xi = dble (i) * dnxm1
eta = 0.0d0
do m = 1,5
temp(m) = ce(m,1) + xi * (ce(m,2) + xi * (ce(m,5) +
& xi * (ce(m,8) + xi * ce(m,11)))) + eta * (ce(m,3) + eta * (ce(m,6
&) + eta * (ce(m,9) + eta * ce(m,12)))) + zeta * (ce(m,4) + zeta *
&(ce(m,7) + zeta * (ce(m,10) + zeta * ce(m,13))))
enddo
do m = 1,5
u(m,i,j,k) = temp(m)
enddo
endif
if (j .eq. grid_points(2) - 1) then
zeta = dble (k) * dnzm1
xi = dble (i) * dnxm1
eta = 1.0d0
! call exact_solution_bt(xi, eta, zeta, temp)
do m = 1,5
temp(m) = ce(m,1) + xi * (ce(m,2) + xi * (ce(m,5) +
& xi * (ce(m,8) + xi * ce(m,11)))) + eta * (ce(m,3) + eta * (ce(m,6
&) + eta * (ce(m,9) + eta * ce(m,12)))) + zeta * (ce(m,4) + zeta *
&(ce(m,7) + zeta * (ce(m,10) + zeta * ce(m,13))))
enddo
do m = 1,5
u(m,i,j,k) = temp(m)
enddo
endif
if (k .eq. 0) then
zeta = 0.0d0
xi = dble (i) * dnxm1
eta = dble (j) * dnym1
! call exact_solution_bt(xi, eta, zeta, temp)
do m = 1,5
temp(m) = ce(m,1) + xi * (ce(m,2) + xi * (ce(m,5) +
& xi * (ce(m,8) + xi * ce(m,11)))) + eta * (ce(m,3) + eta * (ce(m,6
&) + eta * (ce(m,9) + eta * ce(m,12)))) + zeta * (ce(m,4) + zeta *
&(ce(m,7) + zeta * (ce(m,10) + zeta * ce(m,13))))
enddo
do m = 1,5
u(m,i,j,k) = temp(m)
enddo
endif
if (k .eq. grid_points(3) - 1) then
zeta = 1.0d0
xi = dble (i) * dnxm1
eta = dble (j) * dnym1
! call exact_solution_bt(xi, eta, zeta, temp)
do m = 1,5
temp(m) = ce(m,1) + xi * (ce(m,2) + xi * (ce(m,5) +
& xi * (ce(m,8) + xi * ce(m,11)))) + eta * (ce(m,3) + eta * (ce(m,6
&) + eta * (ce(m,9) + eta * ce(m,12)))) + zeta * (ce(m,4) + zeta *
&(ce(m,7) + zeta * (ce(m,10) + zeta * ce(m,13))))
enddo
do m = 1,5
u(m,i,j,k) = temp(m)
enddo
endif
enddo
enddo
enddo
!$SPF END PARALLEL_REG
! DVM$ END REGION
return
end