V3FIT
r8util_bcherm3.f
1  subroutine r8util_bcherm3(fherm,idimx1,idimx2,idimx3,
2  > jbcx1a,jbcx1b, jbcx2a,jbcx2b, jbcx3a,jbcx3b,
3  > zbcx1a,zbcx1b, zbcx2a,zbcx2b, zbcx3a,zbcx3b,
4  > x1, x2, x3)
5 
6 C... insert BCs as needed for Hermite interpolation setup
7 
8  IMPLICIT NONE
9  INTEGER, PARAMETER :: R8=selected_real_kind(12,100)
10  integer :: idimx1,idimx2,idimx3 ! array dimensions
11  real*8 :: fherm(0:7,idimx1,idimx2,idimx3)
12 
13  integer :: jbcx1a,jbcx1b ! x1 BC controls
14  real*8 :: zbcx1a(idimx2,idimx3) ! x1(1) BC data
15  real*8 :: zbcx1b(idimx2,idimx3) ! x1(idimx1) BC data
16 
17  integer :: jbcx2a,jbcx2b ! x2 BC controls
18  real*8 :: zbcx2a(idimx1,idimx3) ! x2(1) BC data
19  real*8 :: zbcx2b(idimx1,idimx3) ! x2(idimx2) BC data
20 
21  integer :: jbcx3a,jbcx3b ! x3 BC controls
22  real*8 :: zbcx3a(idimx2,idimx3) ! x3(1) BC data
23  real*8 :: zbcx3b(idimx2,idimx3) ! x3(idimx3) BC data
24 
25  real*8 :: x1(idimx1),x2(idimx2),x3(idimx3)
26 
27 C-----------------------------------------------------------------
28  integer :: ix,iy
29  REAL*8 :: zdx
30 C-----------------------------------------------------------------
31 
32  if((jbcx1a.eq.1).or.(jbcx1b.eq.1)) then
33 
34  if(jbcx1a.eq.1) then
35  fherm(1,1,1:idimx2,1:idimx3)=zbcx1a(1:idimx2,1:idimx3)
36  else
37  zdx = x1(2)-x1(1)
38  do iy=1,idimx3
39  do ix=1,idimx2
40  fherm(1,1,ix,iy)=
41  > (fherm(0,2,ix,iy)-fherm(0,1,ix,iy))/zdx
42  enddo
43  enddo
44  endif
45 
46  if(jbcx1b.eq.1) then
47  fherm(1,idimx1,1:idimx2,1:idimx3)=zbcx1b(1:idimx2,1:idimx3)
48  else
49  zdx = x1(idimx1)-x1(idimx1-1)
50  do iy=1,idimx3
51  do ix=1,idimx2
52  fherm(1,idimx1,ix,iy)=
53  > (fherm(0,idimx1,ix,iy)-fherm(0,idimx1-1,ix,iy))/
54  > zdx
55  enddo
56  enddo
57  endif
58 
59  endif
60 
61  if((jbcx2a.eq.1).or.(jbcx2b.eq.1)) then
62 
63  if(jbcx2a.eq.1) then
64  fherm(2,1:idimx1,1,1:idimx3)=zbcx2a(1:idimx1,1:idimx3)
65  else
66  zdx=x2(2)-x2(1)
67  do iy=1,idimx3
68  do ix=1,idimx1
69  fherm(2,ix,1,iy)=
70  > (fherm(0,ix,2,iy)-fherm(0,ix,1,iy))/zdx
71  enddo
72  enddo
73  endif
74 
75  if(jbcx2b.eq.1) then
76  fherm(2,1:idimx1,idimx2,1:idimx3)=zbcx2b(1:idimx1,1:idimx3)
77  else
78  zdx=x2(idimx2)-x2(idimx2-1)
79  do iy=1,idimx3
80  do ix=1,idimx1
81  fherm(2,ix,idimx2,iy)=
82  > (fherm(0,ix,idimx2,iy)-fherm(0,ix,idimx2-1,iy))/
83  > zdx
84  enddo
85  enddo
86  endif
87  endif
88 
89  if((jbcx3a.eq.1).or.(jbcx3b.eq.1)) then
90 
91  if(jbcx3a.eq.1) then
92  fherm(3,1:idimx1,1:idimx2,1)=zbcx3a(1:idimx1,1:idimx2)
93  else
94  zdx=x3(2)-x3(1)
95  do iy=1,idimx2
96  do ix=1,idimx1
97  fherm(3,ix,iy,1)=
98  > (fherm(0,ix,iy,2)-fherm(0,ix,iy,1))/zdx
99  enddo
100  enddo
101  endif
102 
103  if(jbcx3b.eq.1) then
104  fherm(3,1:idimx1,1:idimx2,idimx3)=zbcx3b(1:idimx1,1:idimx2)
105  else
106  zdx=x3(idimx3)-x3(idimx3-1)
107  do iy=1,idimx2
108  do ix=1,idimx1
109  fherm(3,ix,iy,idimx3)=
110  > (fherm(0,ix,iy,idimx3)-fherm(0,ix,iy,idimx3-1))/
111  > zdx
112  enddo
113  enddo
114  endif
115  endif
116 
117  end subroutine r8util_bcherm3