Neko 1.99.1
A portable framework for high-order spectral element flow simulations
Loading...
Searching...
No Matches
sx_convect_scalar.f90
Go to the documentation of this file.
1! Copyright (c) 2024, The Neko Authors
2! All rights reserved.
3!
4! Redistribution and use in source and binary forms, with or without
5! modification, are permitted provided that the following conditions
6! are met:
7!
8! * Redistributions of source code must retain the above copyright
9! notice, this list of conditions and the following disclaimer.
10!
11! * Redistributions in binary form must reproduce the above
12! copyright notice, this list of conditions and the following
13! disclaimer in the documentation and/or other materials provided
14! with the distribution.
15!
16! * Neither the name of the authors nor the names of its
17! contributors may be used to endorse or promote products derived
18! from this software without specific prior written permission.
19!
20! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
24! COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
25! INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
26! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
27! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
28! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
29! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
30! ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31! POSSIBILITY OF SUCH DAMAGE.
32!
33submodule(opr_sx) sx_convect_scalar
34 use num_types, only : rp
35 use math, only : col2
36 implicit none
37
38contains
39
40 module subroutine opr_sx_convect_scalar(du, u, cr, cs, ct, xh_gll, xh_gl, &
41 coef_gll, coef_gl, gll_to_gl)
42 type(space_t), intent(in) :: Xh_GL
43 type(space_t), intent(in) :: Xh_GLL
44 type(coef_t), intent(in) :: coef_GLL
45 type(coef_t), intent(in) :: coef_GL
46 type(interpolator_t), intent(inout) :: GLL_to_GL
47 real(kind=rp), intent(inout) :: &
48 du(xh_gll%lx, xh_gll%ly, xh_gll%lz, coef_gl%msh%nelv)
49 real(kind=rp), intent(inout) :: &
50 u(xh_gl%lx, xh_gl%lx, xh_gl%lx, coef_gl%msh%nelv)
51 real(kind=rp), intent(inout) :: cr(xh_gl%lxyz, coef_gl%msh%nelv)
52 real(kind=rp), intent(inout) :: cs(xh_gl%lxyz, coef_gl%msh%nelv)
53 real(kind=rp), intent(inout) :: ct(xh_gl%lxyz, coef_gl%msh%nelv)
54 associate(dx => xh_gl%dx, dy => xh_gl%dy, dz => xh_gl%dz, &
55 lx => xh_gl%lx, nelv => coef_gl%msh%nelv)
56
57 select case (lx)
58 case (18)
59 call sx_convect_scalar_lx18(du, u, cr, cs, ct, dx, dy, dz, &
60 xh_gll, coef_gll, gll_to_gl, nelv)
61 case (17)
62 call sx_convect_scalar_lx17(du, u, cr, cs, ct, dx, dy, dz, &
63 xh_gll, coef_gll, gll_to_gl, nelv)
64 case (16)
65 call sx_convect_scalar_lx16(du, u, cr, cs, ct, dx, dy, dz, &
66 xh_gll, coef_gll, gll_to_gl, nelv)
67 case (15)
68 call sx_convect_scalar_lx15(du, u, cr, cs, ct, dx, dy, dz, &
69 xh_gll, coef_gll, gll_to_gl, nelv)
70 case (14)
71 call sx_convect_scalar_lx14(du, u, cr, cs, ct, dx, dy, dz, &
72 xh_gll, coef_gll, gll_to_gl, nelv)
73 case (13)
74 call sx_convect_scalar_lx13(du, u, cr, cs, ct, dx, dy, dz, &
75 xh_gll, coef_gll, gll_to_gl, nelv)
76 case (12)
77 call sx_convect_scalar_lx12(du, u, cr, cs, ct, dx, dy, dz, &
78 xh_gll, coef_gll, gll_to_gl, nelv)
79 case (11)
80 call sx_convect_scalar_lx11(du, u, cr, cs, ct, dx, dy, dz, &
81 xh_gll, coef_gll, gll_to_gl, nelv)
82 case (10)
83 call sx_convect_scalar_lx10(du, u, cr, cs, ct, dx, dy, dz, &
84 xh_gll, coef_gll, gll_to_gl, nelv)
85 case (9)
86 call sx_convect_scalar_lx9(du, u, cr, cs, ct, dx, dy, dz, &
87 xh_gll, coef_gll, gll_to_gl, nelv)
88 case (8)
89 call sx_convect_scalar_lx8(du, u, cr, cs, ct, dx, dy, dz, &
90 xh_gll, coef_gll, gll_to_gl, nelv)
91 case (7)
92 call sx_convect_scalar_lx7(du, u, cr, cs, ct, dx, dy, dz, &
93 xh_gll, coef_gll, gll_to_gl, nelv)
94 case (6)
95 call sx_convect_scalar_lx6(du, u, cr, cs, ct, dx, dy, dz, &
96 xh_gll, coef_gll, gll_to_gl, nelv)
97 case (5)
98 call sx_convect_scalar_lx5(du, u, cr, cs, ct, dx, dy, dz, &
99 xh_gll, coef_gll, gll_to_gl, nelv)
100 case (4)
101 call sx_convect_scalar_lx4(du, u, cr, cs, ct, dx, dy, dz, &
102 xh_gll, coef_gll, gll_to_gl, nelv)
103 case (3)
104 call sx_convect_scalar_lx3(du, u, cr, cs, ct, dx, dy, dz, &
105 xh_gll, coef_gll, gll_to_gl, nelv)
106 case (2)
107 call sx_convect_scalar_lx2(du, u, cr, cs, ct, dx, dy, dz, &
108 xh_gll, coef_gll, gll_to_gl, nelv)
109 case default
110 call sx_convect_scalar_lx(du, u, cr, cs, ct, dx, dy, dz, &
111 xh_gll, coef_gll, gll_to_gl, nelv, lx)
112 end select
113 end associate
114
115 end subroutine opr_sx_convect_scalar
116
117 subroutine sx_convect_scalar_lx(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
118 coef_GLL, GLL_to_GL, nelv, lx)
119 integer, intent(in) :: nelv, lx
120 type(space_t), intent(in) :: Xh_GLL
121 type(coef_t), intent(in) :: coef_GLL
122 type(interpolator_t), intent(inout) :: GLL_to_GL
123 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
124 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
125 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
126 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
127 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
128 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
129 real(kind=rp) :: ur(lx, lx, lx, nelv)
130 real(kind=rp) :: us(lx, lx, lx, nelv)
131 real(kind=rp) :: ut(lx, lx, lx, nelv)
132 real(kind=rp) :: ud(lx, lx, lx, nelv)
133 real(kind=rp) :: wr, ws, wt
134 integer :: e, i, j, k, jj, kk, n_GLL
135 n_gll = nelv * xh_gll%lxyz
136 do i = 1, lx
137 do jj = 1, lx * lx * nelv
138 wr = 0d0
139 do kk = 1, lx
140 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
141 end do
142 ur(i, jj, 1, 1) = wr
143 end do
144 end do
145
146 do k = 1, lx
147 do i = 1, lx
148 do j = 1, lx
149 do e = 1, nelv
150 ws = 0d0
151 !NEC$ unroll_completely
152 do kk = 1, lx
153 ws = ws + dy(j, kk) * u(i, kk, k, e)
154 end do
155 us(i,j,k,e) = ws
156 end do
157 end do
158 end do
159 end do
160
161 do j = 1, lx
162 do i = 1, lx
163 do k = 1, lx
164 do e = 1, nelv
165 wt = 0d0
166 !NEC$ unroll_completely
167 do kk = 1, lx
168 wt = wt + dz(k, kk) * u(i, j, kk, e)
169 end do
170 ut(i,j,k,e) = wt
171 end do
172 end do
173 end do
174 end do
175
176 do i = 1, lx * lx * lx
177 do e = 1, nelv
178 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
179 + cs(i,e) * us(i,1,1,e) &
180 + ct(i,e) * ut(i,1,1,e) )
181 end do
182 end do
183 call gll_to_gl%map(du, ud, nelv, xh_gll)
184 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
185 call col2(du, coef_gll%Binv, n_gll)
186
187 end subroutine sx_convect_scalar_lx
188
189 subroutine sx_convect_scalar_lx18(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
190 coef_GLL, GLL_to_GL, nelv)
191 integer, parameter :: lx = 18
192 integer, intent(in) :: nelv
193 type(space_t), intent(in) :: Xh_GLL
194 type(coef_t), intent(in) :: coef_GLL
195 type(interpolator_t), intent(inout) :: GLL_to_GL
196 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
197 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
198 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
199 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
200 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
201 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
202 real(kind=rp) :: ur(lx, lx, lx, nelv)
203 real(kind=rp) :: us(lx, lx, lx, nelv)
204 real(kind=rp) :: ut(lx, lx, lx, nelv)
205 real(kind=rp) :: ud(lx, lx, lx, nelv)
206 real(kind=rp) :: wr, ws, wt
207 integer :: e, i, j, k, jj, kk, n_GLL
208 n_gll = nelv * xh_gll%lxyz
209 do i = 1, lx
210 do jj = 1, lx * lx * nelv
211 wr = 0d0
212 do kk = 1, lx
213 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
214 end do
215 ur(i, jj, 1, 1) = wr
216 end do
217 end do
218
219 do k = 1, lx
220 do i = 1, lx
221 do j = 1, lx
222 do e = 1, nelv
223 ws = 0d0
224 !NEC$ unroll_completely
225 do kk = 1, lx
226 ws = ws + dy(j, kk) * u(i, kk, k, e)
227 end do
228 us(i,j,k,e) = ws
229 end do
230 end do
231 end do
232 end do
233
234 do j = 1, lx
235 do i = 1, lx
236 do k = 1, lx
237 do e = 1, nelv
238 wt = 0d0
239 !NEC$ unroll_completely
240 do kk = 1, lx
241 wt = wt + dz(k, kk) * u(i, j, kk, e)
242 end do
243 ut(i,j,k,e) = wt
244 end do
245 end do
246 end do
247 end do
248
249 do i = 1, lx * lx * lx
250 do e = 1, nelv
251 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
252 + cs(i,e) * us(i,1,1,e) &
253 + ct(i,e) * ut(i,1,1,e) )
254 end do
255 end do
256 call gll_to_gl%map(du, ud, nelv, xh_gll)
257 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
258 call col2(du, coef_gll%Binv, n_gll)
259
260 end subroutine sx_convect_scalar_lx18
261
262 subroutine sx_convect_scalar_lx17(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
263 coef_GLL, GLL_to_GL, nelv)
264 integer, parameter :: lx = 17
265 integer, intent(in) :: nelv
266 type(space_t), intent(in) :: Xh_GLL
267 type(coef_t), intent(in) :: coef_GLL
268 type(interpolator_t), intent(inout) :: GLL_to_GL
269 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
270 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
271 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
272 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
273 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
274 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
275 real(kind=rp) :: ur(lx, lx, lx, nelv)
276 real(kind=rp) :: us(lx, lx, lx, nelv)
277 real(kind=rp) :: ut(lx, lx, lx, nelv)
278 real(kind=rp) :: ud(lx, lx, lx, nelv)
279 real(kind=rp) :: wr, ws, wt
280 integer :: e, i, j, k, jj, kk, n_GLL
281 n_gll = nelv * xh_gll%lxyz
282 do i = 1, lx
283 do jj = 1, lx * lx * nelv
284 wr = 0d0
285 do kk = 1, lx
286 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
287 end do
288 ur(i, jj, 1, 1) = wr
289 end do
290 end do
291
292 do k = 1, lx
293 do i = 1, lx
294 do j = 1, lx
295 do e = 1, nelv
296 ws = 0d0
297 !NEC$ unroll_completely
298 do kk = 1, lx
299 ws = ws + dy(j, kk) * u(i, kk, k, e)
300 end do
301 us(i,j,k,e) = ws
302 end do
303 end do
304 end do
305 end do
306
307 do j = 1, lx
308 do i = 1, lx
309 do k = 1, lx
310 do e = 1, nelv
311 wt = 0d0
312 !NEC$ unroll_completely
313 do kk = 1, lx
314 wt = wt + dz(k, kk) * u(i, j, kk, e)
315 end do
316 ut(i,j,k,e) = wt
317 end do
318 end do
319 end do
320 end do
321
322 do i = 1, lx * lx * lx
323 do e = 1, nelv
324 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
325 + cs(i,e) * us(i,1,1,e) &
326 + ct(i,e) * ut(i,1,1,e) )
327 end do
328 end do
329 call gll_to_gl%map(du, ud, nelv, xh_gll)
330 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
331 call col2(du, coef_gll%Binv, n_gll)
332
333 end subroutine sx_convect_scalar_lx17
334
335 subroutine sx_convect_scalar_lx16(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
336 coef_GLL, GLL_to_GL, nelv)
337 integer, parameter :: lx = 16
338 integer, intent(in) :: nelv
339 type(space_t), intent(in) :: Xh_GLL
340 type(coef_t), intent(in) :: coef_GLL
341 type(interpolator_t), intent(inout) :: GLL_to_GL
342 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
343 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
344 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
345 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
346 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
347 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
348 real(kind=rp) :: ur(lx, lx, lx, nelv)
349 real(kind=rp) :: us(lx, lx, lx, nelv)
350 real(kind=rp) :: ut(lx, lx, lx, nelv)
351 real(kind=rp) :: ud(lx, lx, lx, nelv)
352 real(kind=rp) :: wr, ws, wt
353 integer :: e, i, j, k, jj, kk, n_GLL
354 n_gll = nelv * xh_gll%lxyz
355 do i = 1, lx
356 do jj = 1, lx * lx * nelv
357 wr = 0d0
358 do kk = 1, lx
359 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
360 end do
361 ur(i, jj, 1, 1) = wr
362 end do
363 end do
364
365 do k = 1, lx
366 do i = 1, lx
367 do j = 1, lx
368 do e = 1, nelv
369 ws = 0d0
370 !NEC$ unroll_completely
371 do kk = 1, lx
372 ws = ws + dy(j, kk) * u(i, kk, k, e)
373 end do
374 us(i,j,k,e) = ws
375 end do
376 end do
377 end do
378 end do
379
380 do j = 1, lx
381 do i = 1, lx
382 do k = 1, lx
383 do e = 1, nelv
384 wt = 0d0
385 !NEC$ unroll_completely
386 do kk = 1, lx
387 wt = wt + dz(k, kk) * u(i, j, kk, e)
388 end do
389 ut(i,j,k,e) = wt
390 end do
391 end do
392 end do
393 end do
394
395 do i = 1, lx * lx * lx
396 do e = 1, nelv
397 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
398 + cs(i,e) * us(i,1,1,e) &
399 + ct(i,e) * ut(i,1,1,e) )
400 end do
401 end do
402 call gll_to_gl%map(du, ud, nelv, xh_gll)
403 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
404 call col2(du, coef_gll%Binv, n_gll)
405
406 end subroutine sx_convect_scalar_lx16
407
408 subroutine sx_convect_scalar_lx15(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
409 coef_GLL, GLL_to_GL, nelv)
410 integer, parameter :: lx = 15
411 integer, intent(in) :: nelv
412 type(space_t), intent(in) :: Xh_GLL
413 type(coef_t), intent(in) :: coef_GLL
414 type(interpolator_t), intent(inout) :: GLL_to_GL
415 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
416 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
417 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
418 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
419 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
420 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
421 real(kind=rp) :: ur(lx, lx, lx, nelv)
422 real(kind=rp) :: us(lx, lx, lx, nelv)
423 real(kind=rp) :: ut(lx, lx, lx, nelv)
424 real(kind=rp) :: ud(lx, lx, lx, nelv)
425 real(kind=rp) :: wr, ws, wt
426 integer :: e, i, j, k, jj, kk, n_GLL
427 n_gll = nelv * xh_gll%lxyz
428 do i = 1, lx
429 do jj = 1, lx * lx * nelv
430 wr = 0d0
431 do kk = 1, lx
432 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
433 end do
434 ur(i, jj, 1, 1) = wr
435 end do
436 end do
437
438 do k = 1, lx
439 do i = 1, lx
440 do j = 1, lx
441 do e = 1, nelv
442 ws = 0d0
443 !NEC$ unroll_completely
444 do kk = 1, lx
445 ws = ws + dy(j, kk) * u(i, kk, k, e)
446 end do
447 us(i,j,k,e) = ws
448 end do
449 end do
450 end do
451 end do
452
453 do j = 1, lx
454 do i = 1, lx
455 do k = 1, lx
456 do e = 1, nelv
457 wt = 0d0
458 !NEC$ unroll_completely
459 do kk = 1, lx
460 wt = wt + dz(k, kk) * u(i, j, kk, e)
461 end do
462 ut(i,j,k,e) = wt
463 end do
464 end do
465 end do
466 end do
467
468 do i = 1, lx * lx * lx
469 do e = 1, nelv
470 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
471 + cs(i,e) * us(i,1,1,e) &
472 + ct(i,e) * ut(i,1,1,e) )
473 end do
474 end do
475 call gll_to_gl%map(du, ud, nelv, xh_gll)
476 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
477 call col2(du, coef_gll%Binv, n_gll)
478
479 end subroutine sx_convect_scalar_lx15
480
481 subroutine sx_convect_scalar_lx14(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
482 coef_GLL, GLL_to_GL, nelv)
483 integer, parameter :: lx = 14
484 integer, intent(in) :: nelv
485 type(space_t), intent(in) :: Xh_GLL
486 type(coef_t), intent(in) :: coef_GLL
487 type(interpolator_t), intent(inout) :: GLL_to_GL
488 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
489 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
490 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
491 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
492 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
493 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
494 real(kind=rp) :: ur(lx, lx, lx, nelv)
495 real(kind=rp) :: us(lx, lx, lx, nelv)
496 real(kind=rp) :: ut(lx, lx, lx, nelv)
497 real(kind=rp) :: ud(lx, lx, lx, nelv)
498 real(kind=rp) :: wr, ws, wt
499 integer :: e, i, j, k, jj, kk, n_GLL
500 n_gll = nelv * xh_gll%lxyz
501 do i = 1, lx
502 do jj = 1, lx * lx * nelv
503 wr = 0d0
504 do kk = 1, lx
505 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
506 end do
507 ur(i, jj, 1, 1) = wr
508 end do
509 end do
510
511 do k = 1, lx
512 do i = 1, lx
513 do j = 1, lx
514 do e = 1, nelv
515 ws = 0d0
516 !NEC$ unroll_completely
517 do kk = 1, lx
518 ws = ws + dy(j, kk) * u(i, kk, k, e)
519 end do
520 us(i,j,k,e) = ws
521 end do
522 end do
523 end do
524 end do
525
526 do j = 1, lx
527 do i = 1, lx
528 do k = 1, lx
529 do e = 1, nelv
530 wt = 0d0
531 !NEC$ unroll_completely
532 do kk = 1, lx
533 wt = wt + dz(k, kk) * u(i, j, kk, e)
534 end do
535 ut(i,j,k,e) = wt
536 end do
537 end do
538 end do
539 end do
540
541 do i = 1, lx * lx * lx
542 do e = 1, nelv
543 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
544 + cs(i,e) * us(i,1,1,e) &
545 + ct(i,e) * ut(i,1,1,e) )
546 end do
547 end do
548 call gll_to_gl%map(du, ud, nelv, xh_gll)
549 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
550 call col2(du, coef_gll%Binv, n_gll)
551
552 end subroutine sx_convect_scalar_lx14
553
554 subroutine sx_convect_scalar_lx13(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
555 coef_GLL, GLL_to_GL, nelv)
556 integer, parameter :: lx = 13
557 integer, intent(in) :: nelv
558 type(space_t), intent(in) :: Xh_GLL
559 type(coef_t), intent(in) :: coef_GLL
560 type(interpolator_t), intent(inout) :: GLL_to_GL
561 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
562 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
563 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
564 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
565 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
566 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
567 real(kind=rp) :: ur(lx, lx, lx, nelv)
568 real(kind=rp) :: us(lx, lx, lx, nelv)
569 real(kind=rp) :: ut(lx, lx, lx, nelv)
570 real(kind=rp) :: ud(lx, lx, lx, nelv)
571 real(kind=rp) :: wr, ws, wt
572 integer :: e, i, j, k, jj, kk, n_GLL
573 n_gll = nelv * xh_gll%lxyz
574 do i = 1, lx
575 do jj = 1, lx * lx * nelv
576 wr = 0d0
577 do kk = 1, lx
578 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
579 end do
580 ur(i, jj, 1, 1) = wr
581 end do
582 end do
583
584 do k = 1, lx
585 do i = 1, lx
586 do j = 1, lx
587 do e = 1, nelv
588 ws = 0d0
589 !NEC$ unroll_completely
590 do kk = 1, lx
591 ws = ws + dy(j, kk) * u(i, kk, k, e)
592 end do
593 us(i,j,k,e) = ws
594 end do
595 end do
596 end do
597 end do
598
599 do j = 1, lx
600 do i = 1, lx
601 do k = 1, lx
602 do e = 1, nelv
603 wt = 0d0
604 !NEC$ unroll_completely
605 do kk = 1, lx
606 wt = wt + dz(k, kk) * u(i, j, kk, e)
607 end do
608 ut(i,j,k,e) = wt
609 end do
610 end do
611 end do
612 end do
613
614 do i = 1, lx * lx * lx
615 do e = 1, nelv
616 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
617 + cs(i,e) * us(i,1,1,e) &
618 + ct(i,e) * ut(i,1,1,e) )
619 end do
620 end do
621 call gll_to_gl%map(du, ud, nelv, xh_gll)
622 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
623 call col2(du, coef_gll%Binv, n_gll)
624
625 end subroutine sx_convect_scalar_lx13
626
627 subroutine sx_convect_scalar_lx12(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
628 coef_GLL, GLL_to_GL, nelv)
629 integer, parameter :: lx = 12
630 integer, intent(in) :: nelv
631 type(space_t), intent(in) :: Xh_GLL
632 type(coef_t), intent(in) :: coef_GLL
633 type(interpolator_t), intent(inout) :: GLL_to_GL
634 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
635 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
636 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
637 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
638 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
639 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
640 real(kind=rp) :: ur(lx, lx, lx, nelv)
641 real(kind=rp) :: us(lx, lx, lx, nelv)
642 real(kind=rp) :: ut(lx, lx, lx, nelv)
643 real(kind=rp) :: ud(lx, lx, lx, nelv)
644 real(kind=rp) :: wr, ws, wt
645 integer :: e, i, j, k, jj, kk, n_GLL
646 n_gll = nelv * xh_gll%lxyz
647 do i = 1, lx
648 do jj = 1, lx * lx * nelv
649 wr = 0d0
650 do kk = 1, lx
651 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
652 end do
653 ur(i, jj, 1, 1) = wr
654 end do
655 end do
656
657 do k = 1, lx
658 do i = 1, lx
659 do j = 1, lx
660 do e = 1, nelv
661 ws = 0d0
662 !NEC$ unroll_completely
663 do kk = 1, lx
664 ws = ws + dy(j, kk) * u(i, kk, k, e)
665 end do
666 us(i,j,k,e) = ws
667 end do
668 end do
669 end do
670 end do
671
672 do j = 1, lx
673 do i = 1, lx
674 do k = 1, lx
675 do e = 1, nelv
676 wt = 0d0
677 !NEC$ unroll_completely
678 do kk = 1, lx
679 wt = wt + dz(k, kk) * u(i, j, kk, e)
680 end do
681 ut(i,j,k,e) = wt
682 end do
683 end do
684 end do
685 end do
686
687 do i = 1, lx * lx * lx
688 do e = 1, nelv
689 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
690 + cs(i,e) * us(i,1,1,e) &
691 + ct(i,e) * ut(i,1,1,e) )
692 end do
693 end do
694 call gll_to_gl%map(du, ud, nelv, xh_gll)
695 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
696 call col2(du, coef_gll%Binv, n_gll)
697
698 end subroutine sx_convect_scalar_lx12
699
700 subroutine sx_convect_scalar_lx11(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
701 coef_GLL, GLL_to_GL, nelv)
702 integer, parameter :: lx = 11
703 integer, intent(in) :: nelv
704 type(space_t), intent(in) :: Xh_GLL
705 type(coef_t), intent(in) :: coef_GLL
706 type(interpolator_t), intent(inout) :: GLL_to_GL
707 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
708 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
709 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
710 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
711 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
712 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
713 real(kind=rp) :: ur(lx, lx, lx, nelv)
714 real(kind=rp) :: us(lx, lx, lx, nelv)
715 real(kind=rp) :: ut(lx, lx, lx, nelv)
716 real(kind=rp) :: ud(lx, lx, lx, nelv)
717 real(kind=rp) :: wr, ws, wt
718 integer :: e, i, j, k, jj, kk, n_GLL
719 n_gll = nelv * xh_gll%lxyz
720 do i = 1, lx
721 do jj = 1, lx * lx * nelv
722 wr = 0d0
723 do kk = 1, lx
724 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
725 end do
726 ur(i, jj, 1, 1) = wr
727 end do
728 end do
729
730 do k = 1, lx
731 do i = 1, lx
732 do j = 1, lx
733 do e = 1, nelv
734 ws = 0d0
735 !NEC$ unroll_completely
736 do kk = 1, lx
737 ws = ws + dy(j, kk) * u(i, kk, k, e)
738 end do
739 us(i,j,k,e) = ws
740 end do
741 end do
742 end do
743 end do
744
745 do j = 1, lx
746 do i = 1, lx
747 do k = 1, lx
748 do e = 1, nelv
749 wt = 0d0
750 !NEC$ unroll_completely
751 do kk = 1, lx
752 wt = wt + dz(k, kk) * u(i, j, kk, e)
753 end do
754 ut(i,j,k,e) = wt
755 end do
756 end do
757 end do
758 end do
759
760 do i = 1, lx * lx * lx
761 do e = 1, nelv
762 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
763 + cs(i,e) * us(i,1,1,e) &
764 + ct(i,e) * ut(i,1,1,e) )
765 end do
766 end do
767 call gll_to_gl%map(du, ud, nelv, xh_gll)
768 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
769 call col2(du, coef_gll%Binv, n_gll)
770
771 end subroutine sx_convect_scalar_lx11
772
773 subroutine sx_convect_scalar_lx10(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
774 coef_GLL, GLL_to_GL, nelv)
775 integer, parameter :: lx = 10
776 integer, intent(in) :: nelv
777 type(space_t), intent(in) :: Xh_GLL
778 type(coef_t), intent(in) :: coef_GLL
779 type(interpolator_t), intent(inout) :: GLL_to_GL
780 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
781 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
782 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
783 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
784 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
785 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
786 real(kind=rp) :: ur(lx, lx, lx, nelv)
787 real(kind=rp) :: us(lx, lx, lx, nelv)
788 real(kind=rp) :: ut(lx, lx, lx, nelv)
789 real(kind=rp) :: ud(lx, lx, lx, nelv)
790 real(kind=rp) :: wr, ws, wt
791 integer :: e, i, j, k, jj, kk, n_GLL
792 n_gll = nelv * xh_gll%lxyz
793 do i = 1, lx
794 do jj = 1, lx * lx * nelv
795 wr = 0d0
796 do kk = 1, lx
797 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
798 end do
799 ur(i, jj, 1, 1) = wr
800 end do
801 end do
802
803 do k = 1, lx
804 do i = 1, lx
805 do j = 1, lx
806 do e = 1, nelv
807 ws = 0d0
808 !NEC$ unroll_completely
809 do kk = 1, lx
810 ws = ws + dy(j, kk) * u(i, kk, k, e)
811 end do
812 us(i,j,k,e) = ws
813 end do
814 end do
815 end do
816 end do
817
818 do j = 1, lx
819 do i = 1, lx
820 do k = 1, lx
821 do e = 1, nelv
822 wt = 0d0
823 !NEC$ unroll_completely
824 do kk = 1, lx
825 wt = wt + dz(k, kk) * u(i, j, kk, e)
826 end do
827 ut(i,j,k,e) = wt
828 end do
829 end do
830 end do
831 end do
832
833 do i = 1, lx * lx * lx
834 do e = 1, nelv
835 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
836 + cs(i,e) * us(i,1,1,e) &
837 + ct(i,e) * ut(i,1,1,e) )
838 end do
839 end do
840 call gll_to_gl%map(du, ud, nelv, xh_gll)
841 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
842 call col2(du, coef_gll%Binv, n_gll)
843
844 end subroutine sx_convect_scalar_lx10
845
846 subroutine sx_convect_scalar_lx9(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
847 coef_GLL, GLL_to_GL, nelv)
848 integer, parameter :: lx = 9
849 integer, intent(in) :: nelv
850 type(space_t), intent(in) :: Xh_GLL
851 type(coef_t), intent(in) :: coef_GLL
852 type(interpolator_t), intent(inout) :: GLL_to_GL
853 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
854 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
855 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
856 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
857 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
858 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
859 real(kind=rp) :: ur(lx, lx, lx, nelv)
860 real(kind=rp) :: us(lx, lx, lx, nelv)
861 real(kind=rp) :: ut(lx, lx, lx, nelv)
862 real(kind=rp) :: ud(lx, lx, lx, nelv)
863 real(kind=rp) :: wr, ws, wt
864 integer :: e, i, j, k, jj, kk, n_GLL
865 n_gll = nelv * xh_gll%lxyz
866 do i = 1, lx
867 do jj = 1, lx * lx * nelv
868 wr = 0d0
869 do kk = 1, lx
870 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
871 end do
872 ur(i, jj, 1, 1) = wr
873 end do
874 end do
875
876 do k = 1, lx
877 do i = 1, lx
878 do j = 1, lx
879 do e = 1, nelv
880 ws = 0d0
881 !NEC$ unroll_completely
882 do kk = 1, lx
883 ws = ws + dy(j, kk) * u(i, kk, k, e)
884 end do
885 us(i,j,k,e) = ws
886 end do
887 end do
888 end do
889 end do
890
891 do j = 1, lx
892 do i = 1, lx
893 do k = 1, lx
894 do e = 1, nelv
895 wt = 0d0
896 !NEC$ unroll_completely
897 do kk = 1, lx
898 wt = wt + dz(k, kk) * u(i, j, kk, e)
899 end do
900 ut(i,j,k,e) = wt
901 end do
902 end do
903 end do
904 end do
905
906 do i = 1, lx * lx * lx
907 do e = 1, nelv
908 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
909 + cs(i,e) * us(i,1,1,e) &
910 + ct(i,e) * ut(i,1,1,e) )
911 end do
912 end do
913 call gll_to_gl%map(du, ud, nelv, xh_gll)
914 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
915 call col2(du, coef_gll%Binv, n_gll)
916
917 end subroutine sx_convect_scalar_lx9
918
919 subroutine sx_convect_scalar_lx8(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
920 coef_GLL, GLL_to_GL, nelv)
921 integer, parameter :: lx = 8
922 integer, intent(in) :: nelv
923 type(space_t), intent(in) :: Xh_GLL
924 type(coef_t), intent(in) :: coef_GLL
925 type(interpolator_t), intent(inout) :: GLL_to_GL
926 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
927 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
928 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
929 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
930 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
931 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
932 real(kind=rp) :: ur(lx, lx, lx, nelv)
933 real(kind=rp) :: us(lx, lx, lx, nelv)
934 real(kind=rp) :: ut(lx, lx, lx, nelv)
935 real(kind=rp) :: ud(lx, lx, lx, nelv)
936 real(kind=rp) :: wr, ws, wt
937 integer :: e, i, j, k, jj, kk, n_GLL
938 n_gll = nelv * xh_gll%lxyz
939 do i = 1, lx
940 do jj = 1, lx * lx * nelv
941 wr = 0d0
942 do kk = 1, lx
943 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
944 end do
945 ur(i, jj, 1, 1) = wr
946 end do
947 end do
948
949 do k = 1, lx
950 do i = 1, lx
951 do j = 1, lx
952 do e = 1, nelv
953 ws = 0d0
954 !NEC$ unroll_completely
955 do kk = 1, lx
956 ws = ws + dy(j, kk) * u(i, kk, k, e)
957 end do
958 us(i,j,k,e) = ws
959 end do
960 end do
961 end do
962 end do
963
964 do j = 1, lx
965 do i = 1, lx
966 do k = 1, lx
967 do e = 1, nelv
968 wt = 0d0
969 !NEC$ unroll_completely
970 do kk = 1, lx
971 wt = wt + dz(k, kk) * u(i, j, kk, e)
972 end do
973 ut(i,j,k,e) = wt
974 end do
975 end do
976 end do
977 end do
978
979 do i = 1, lx * lx * lx
980 do e = 1, nelv
981 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
982 + cs(i,e) * us(i,1,1,e) &
983 + ct(i,e) * ut(i,1,1,e) )
984 end do
985 end do
986 call gll_to_gl%map(du, ud, nelv, xh_gll)
987 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
988 call col2(du, coef_gll%Binv, n_gll)
989
990 end subroutine sx_convect_scalar_lx8
991
992 subroutine sx_convect_scalar_lx7(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
993 coef_GLL, GLL_to_GL, nelv)
994 integer, parameter :: lx = 7
995 integer, intent(in) :: nelv
996 type(space_t), intent(in) :: Xh_GLL
997 type(coef_t), intent(in) :: coef_GLL
998 type(interpolator_t), intent(inout) :: GLL_to_GL
999 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
1000 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
1001 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
1002 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
1003 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
1004 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
1005 real(kind=rp) :: ur(lx, lx, lx, nelv)
1006 real(kind=rp) :: us(lx, lx, lx, nelv)
1007 real(kind=rp) :: ut(lx, lx, lx, nelv)
1008 real(kind=rp) :: ud(lx, lx, lx, nelv)
1009 real(kind=rp) :: wr, ws, wt
1010 integer :: e, i, j, k, jj, kk, n_GLL
1011 n_gll = nelv * xh_gll%lxyz
1012 do i = 1, lx
1013 do jj = 1, lx * lx * nelv
1014 wr = 0d0
1015 do kk = 1, lx
1016 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
1017 end do
1018 ur(i, jj, 1, 1) = wr
1019 end do
1020 end do
1021
1022 do k = 1, lx
1023 do i = 1, lx
1024 do j = 1, lx
1025 do e = 1, nelv
1026 ws = 0d0
1027 !NEC$ unroll_completely
1028 do kk = 1, lx
1029 ws = ws + dy(j, kk) * u(i, kk, k, e)
1030 end do
1031 us(i,j,k,e) = ws
1032 end do
1033 end do
1034 end do
1035 end do
1036
1037 do j = 1, lx
1038 do i = 1, lx
1039 do k = 1, lx
1040 do e = 1, nelv
1041 wt = 0d0
1042 !NEC$ unroll_completely
1043 do kk = 1, lx
1044 wt = wt + dz(k, kk) * u(i, j, kk, e)
1045 end do
1046 ut(i,j,k,e) = wt
1047 end do
1048 end do
1049 end do
1050 end do
1051
1052 do i = 1, lx * lx * lx
1053 do e = 1, nelv
1054 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
1055 + cs(i,e) * us(i,1,1,e) &
1056 + ct(i,e) * ut(i,1,1,e) )
1057 end do
1058 end do
1059 call gll_to_gl%map(du, ud, nelv, xh_gll)
1060 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
1061 call col2(du, coef_gll%Binv, n_gll)
1062
1063 end subroutine sx_convect_scalar_lx7
1064
1065 subroutine sx_convect_scalar_lx6(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
1066 coef_GLL, GLL_to_GL, nelv)
1067 integer, parameter :: lx = 6
1068 integer, intent(in) :: nelv
1069 type(space_t), intent(in) :: Xh_GLL
1070 type(coef_t), intent(in) :: coef_GLL
1071 type(interpolator_t), intent(inout) :: GLL_to_GL
1072 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
1073 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
1074 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
1075 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
1076 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
1077 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
1078 real(kind=rp) :: ur(lx, lx, lx, nelv)
1079 real(kind=rp) :: us(lx, lx, lx, nelv)
1080 real(kind=rp) :: ut(lx, lx, lx, nelv)
1081 real(kind=rp) :: ud(lx, lx, lx, nelv)
1082 real(kind=rp) :: wr, ws, wt
1083 integer :: e, i, j, k, jj, kk, n_GLL
1084 n_gll = nelv * xh_gll%lxyz
1085 do i = 1, lx
1086 do jj = 1, lx * lx * nelv
1087 wr = 0d0
1088 do kk = 1, lx
1089 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
1090 end do
1091 ur(i, jj, 1, 1) = wr
1092 end do
1093 end do
1094
1095 do k = 1, lx
1096 do i = 1, lx
1097 do j = 1, lx
1098 do e = 1, nelv
1099 ws = 0d0
1100 !NEC$ unroll_completely
1101 do kk = 1, lx
1102 ws = ws + dy(j, kk) * u(i, kk, k, e)
1103 end do
1104 us(i,j,k,e) = ws
1105 end do
1106 end do
1107 end do
1108 end do
1109
1110 do j = 1, lx
1111 do i = 1, lx
1112 do k = 1, lx
1113 do e = 1, nelv
1114 wt = 0d0
1115 !NEC$ unroll_completely
1116 do kk = 1, lx
1117 wt = wt + dz(k, kk) * u(i, j, kk, e)
1118 end do
1119 ut(i,j,k,e) = wt
1120 end do
1121 end do
1122 end do
1123 end do
1124
1125 do i = 1, lx * lx * lx
1126 do e = 1, nelv
1127 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
1128 + cs(i,e) * us(i,1,1,e) &
1129 + ct(i,e) * ut(i,1,1,e) )
1130 end do
1131 end do
1132 call gll_to_gl%map(du, ud, nelv, xh_gll)
1133 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
1134 call col2(du, coef_gll%Binv, n_gll)
1135
1136 end subroutine sx_convect_scalar_lx6
1137
1138 subroutine sx_convect_scalar_lx5(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
1139 coef_GLL, GLL_to_GL, nelv)
1140 integer, parameter :: lx = 5
1141 integer, intent(in) :: nelv
1142 type(space_t), intent(in) :: Xh_GLL
1143 type(coef_t), intent(in) :: coef_GLL
1144 type(interpolator_t), intent(inout) :: GLL_to_GL
1145 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
1146 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
1147 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
1148 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
1149 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
1150 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
1151 real(kind=rp) :: ur(lx, lx, lx, nelv)
1152 real(kind=rp) :: us(lx, lx, lx, nelv)
1153 real(kind=rp) :: ut(lx, lx, lx, nelv)
1154 real(kind=rp) :: ud(lx, lx, lx, nelv)
1155 real(kind=rp) :: wr, ws, wt
1156 integer :: e, i, j, k, jj, kk, n_GLL
1157 n_gll = nelv * xh_gll%lxyz
1158 do i = 1, lx
1159 do jj = 1, lx * lx * nelv
1160 wr = 0d0
1161 do kk = 1, lx
1162 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
1163 end do
1164 ur(i, jj, 1, 1) = wr
1165 end do
1166 end do
1167
1168 do k = 1, lx
1169 do i = 1, lx
1170 do j = 1, lx
1171 do e = 1, nelv
1172 ws = 0d0
1173 !NEC$ unroll_completely
1174 do kk = 1, lx
1175 ws = ws + dy(j, kk) * u(i, kk, k, e)
1176 end do
1177 us(i,j,k,e) = ws
1178 end do
1179 end do
1180 end do
1181 end do
1182
1183 do j = 1, lx
1184 do i = 1, lx
1185 do k = 1, lx
1186 do e = 1, nelv
1187 wt = 0d0
1188 !NEC$ unroll_completely
1189 do kk = 1, lx
1190 wt = wt + dz(k, kk) * u(i, j, kk, e)
1191 end do
1192 ut(i,j,k,e) = wt
1193 end do
1194 end do
1195 end do
1196 end do
1197
1198 do i = 1, lx * lx * lx
1199 do e = 1, nelv
1200 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
1201 + cs(i,e) * us(i,1,1,e) &
1202 + ct(i,e) * ut(i,1,1,e) )
1203 end do
1204 end do
1205 call gll_to_gl%map(du, ud, nelv, xh_gll)
1206 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
1207 call col2(du, coef_gll%Binv, n_gll)
1208
1209 end subroutine sx_convect_scalar_lx5
1210
1211 subroutine sx_convect_scalar_lx4(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
1212 coef_GLL, GLL_to_GL, nelv)
1213 integer, parameter :: lx = 4
1214 integer, intent(in) :: nelv
1215 type(space_t), intent(in) :: Xh_GLL
1216 type(coef_t), intent(in) :: coef_GLL
1217 type(interpolator_t), intent(inout) :: GLL_to_GL
1218 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
1219 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
1220 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
1221 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
1222 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
1223 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
1224 real(kind=rp) :: ur(lx, lx, lx, nelv)
1225 real(kind=rp) :: us(lx, lx, lx, nelv)
1226 real(kind=rp) :: ut(lx, lx, lx, nelv)
1227 real(kind=rp) :: ud(lx, lx, lx, nelv)
1228 real(kind=rp) :: wr, ws, wt
1229 integer :: e, i, j, k, jj, kk, n_GLL
1230 n_gll = nelv * xh_gll%lxyz
1231 do i = 1, lx
1232 do jj = 1, lx * lx * nelv
1233 wr = 0d0
1234 do kk = 1, lx
1235 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
1236 end do
1237 ur(i, jj, 1, 1) = wr
1238 end do
1239 end do
1240
1241 do k = 1, lx
1242 do i = 1, lx
1243 do j = 1, lx
1244 do e = 1, nelv
1245 ws = 0d0
1246 !NEC$ unroll_completely
1247 do kk = 1, lx
1248 ws = ws + dy(j, kk) * u(i, kk, k, e)
1249 end do
1250 us(i,j,k,e) = ws
1251 end do
1252 end do
1253 end do
1254 end do
1255
1256 do j = 1, lx
1257 do i = 1, lx
1258 do k = 1, lx
1259 do e = 1, nelv
1260 wt = 0d0
1261 !NEC$ unroll_completely
1262 do kk = 1, lx
1263 wt = wt + dz(k, kk) * u(i, j, kk, e)
1264 end do
1265 ut(i,j,k,e) = wt
1266 end do
1267 end do
1268 end do
1269 end do
1270
1271 do i = 1, lx * lx * lx
1272 do e = 1, nelv
1273 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
1274 + cs(i,e) * us(i,1,1,e) &
1275 + ct(i,e) * ut(i,1,1,e) )
1276 end do
1277 end do
1278 call gll_to_gl%map(du, ud, nelv, xh_gll)
1279 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
1280 call col2(du, coef_gll%Binv, n_gll)
1281
1282 end subroutine sx_convect_scalar_lx4
1283
1284 subroutine sx_convect_scalar_lx3(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
1285 coef_GLL, GLL_to_GL, nelv)
1286 integer, parameter :: lx = 3
1287 integer, intent(in) :: nelv
1288 type(space_t), intent(in) :: Xh_GLL
1289 type(coef_t), intent(in) :: coef_GLL
1290 type(interpolator_t), intent(inout) :: GLL_to_GL
1291 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
1292 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
1293 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
1294 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
1295 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
1296 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
1297 real(kind=rp) :: ur(lx, lx, lx, nelv)
1298 real(kind=rp) :: us(lx, lx, lx, nelv)
1299 real(kind=rp) :: ut(lx, lx, lx, nelv)
1300 real(kind=rp) :: ud(lx, lx, lx, nelv)
1301 real(kind=rp) :: wr, ws, wt
1302 integer :: e, i, j, k, jj, kk, n_GLL
1303 n_gll = nelv * xh_gll%lxyz
1304 do i = 1, lx
1305 do jj = 1, lx * lx * nelv
1306 wr = 0d0
1307 do kk = 1, lx
1308 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
1309 end do
1310 ur(i, jj, 1, 1) = wr
1311 end do
1312 end do
1313
1314 do k = 1, lx
1315 do i = 1, lx
1316 do j = 1, lx
1317 do e = 1, nelv
1318 ws = 0d0
1319 !NEC$ unroll_completely
1320 do kk = 1, lx
1321 ws = ws + dy(j, kk) * u(i, kk, k, e)
1322 end do
1323 us(i,j,k,e) = ws
1324 end do
1325 end do
1326 end do
1327 end do
1328
1329 do j = 1, lx
1330 do i = 1, lx
1331 do k = 1, lx
1332 do e = 1, nelv
1333 wt = 0d0
1334 !NEC$ unroll_completely
1335 do kk = 1, lx
1336 wt = wt + dz(k, kk) * u(i, j, kk, e)
1337 end do
1338 ut(i,j,k,e) = wt
1339 end do
1340 end do
1341 end do
1342 end do
1343
1344 do i = 1, lx * lx * lx
1345 do e = 1, nelv
1346 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
1347 + cs(i,e) * us(i,1,1,e) &
1348 + ct(i,e) * ut(i,1,1,e) )
1349 end do
1350 end do
1351 call gll_to_gl%map(du, ud, nelv, xh_gll)
1352 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
1353 call col2(du, coef_gll%Binv, n_gll)
1354
1355 end subroutine sx_convect_scalar_lx3
1356
1357 subroutine sx_convect_scalar_lx2(du, u, cr, cs, ct, dx, dy, dz, Xh_GLL, &
1358 coef_GLL, GLL_to_GL, nelv)
1359 integer, parameter :: lx = 2
1360 integer, intent(in) :: nelv
1361 type(space_t), intent(in) :: Xh_GLL
1362 type(coef_t), intent(in) :: coef_GLL
1363 type(interpolator_t), intent(inout) :: GLL_to_GL
1364 real(kind=rp), intent(inout) :: du(xh_gll%lx, xh_gll%lx, xh_gll%lx, nelv)
1365 real(kind=rp), intent(in) :: u(lx, lx, lx, nelv)
1366 real(kind=rp), intent(in) :: cr(lx*lx*lx, nelv)
1367 real(kind=rp), intent(in) :: cs(lx*lx*lx, nelv)
1368 real(kind=rp), intent(in) :: ct(lx*lx*lx, nelv)
1369 real(kind=rp), dimension(lx, lx), intent(in) :: dx, dy, dz
1370 real(kind=rp) :: ur(lx, lx, lx, nelv)
1371 real(kind=rp) :: us(lx, lx, lx, nelv)
1372 real(kind=rp) :: ut(lx, lx, lx, nelv)
1373 real(kind=rp) :: ud(lx, lx, lx, nelv)
1374 real(kind=rp) :: wr, ws, wt
1375 integer :: e, i, j, k, jj, kk, n_GLL
1376 n_gll = nelv * xh_gll%lxyz
1377 do i = 1, lx
1378 do jj = 1, lx * lx * nelv
1379 wr = 0d0
1380 do kk = 1, lx
1381 wr = wr + dx(i, kk) * u(kk, jj, 1, 1)
1382 end do
1383 ur(i, jj, 1, 1) = wr
1384 end do
1385 end do
1386
1387 do k = 1, lx
1388 do i = 1, lx
1389 do j = 1, lx
1390 do e = 1, nelv
1391 ws = 0d0
1392 !NEC$ unroll_completely
1393 do kk = 1, lx
1394 ws = ws + dy(j, kk) * u(i, kk, k, e)
1395 end do
1396 us(i,j,k,e) = ws
1397 end do
1398 end do
1399 end do
1400 end do
1401
1402 do j = 1, lx
1403 do i = 1, lx
1404 do k = 1, lx
1405 do e = 1, nelv
1406 wt = 0d0
1407 !NEC$ unroll_completely
1408 do kk = 1, lx
1409 wt = wt + dz(k, kk) * u(i, j, kk, e)
1410 end do
1411 ut(i,j,k,e) = wt
1412 end do
1413 end do
1414 end do
1415 end do
1416
1417 do i = 1, lx * lx * lx
1418 do e = 1, nelv
1419 ud(i,1,1,e) = ( cr(i,e) * ur(i,1,1,e) &
1420 + cs(i,e) * us(i,1,1,e) &
1421 + ct(i,e) * ut(i,1,1,e) )
1422 end do
1423 end do
1424 call gll_to_gl%map(du, ud, nelv, xh_gll)
1425 call coef_gll%gs_h%op(du, n_gll, gs_op_add)
1426 call col2(du, coef_gll%Binv, n_gll)
1427
1428 end subroutine sx_convect_scalar_lx2
1429
1430end submodule sx_convect_scalar
math
Definition math.f90:60
math::col2
subroutine, public col2(a, b, n)
Vector multiplication .
Definition math.f90:854
num_types
Definition num_types.f90:1
num_types::rp
integer, parameter, public rp
Global precision used in computations.
Definition num_types.f90:12
opr_sx
Operators SX-Aurora backend.
Definition opr_sx.f90:2