MFC
Exascale flow solver
Loading...
Searching...
No Matches
m_acoustic_src.fpp.f90
Go to the documentation of this file.
1# 1 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
2!>
3!! @file
4!! @brief Contains module m_acoustic_src
5
6# 1 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp" 1
7# 1 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 1
8# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
9# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
10# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
11# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
12# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
13# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
14
15# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
16# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
17# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
18
19# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
20
21# 46 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
22
23# 58 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
24
25# 68 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
26
27# 98 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
28
29# 110 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
30
31# 120 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
32
33# 145 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
34! New line at end of file is required for FYPP
35# 2 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
36# 1 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp" 1
37# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
38# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
39# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
40# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
41# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
42# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
43
44# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
45# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
46# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
47
48# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
49
50# 46 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
51
52# 58 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
53
54# 68 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
55
56# 98 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
57
58# 110 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
59
60# 120 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
61
62# 145 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
63! New line at end of file is required for FYPP
64# 2 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp" 2
65
66# 4 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
67# 5 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
68# 6 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
69# 7 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
70# 8 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
71
72# 20 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
73
74# 43 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
75
76# 48 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
77
78# 53 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
79
80# 58 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
81
82# 63 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
83
84# 68 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
85
86# 76 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
87
88# 81 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
89
90# 86 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
91
92# 91 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
93
94# 96 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
95
96# 101 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
97
98# 106 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
99
100# 111 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
101
102# 116 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
103
104# 121 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
105
106# 151 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
107
108# 192 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
109
110# 206 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
111
112# 231 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
113
114# 242 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
115
116# 244 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
117# 255 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
118
119# 284 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
120
121# 294 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
122
123# 304 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
124
125# 313 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
126
127# 330 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
128
129# 340 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
130
131# 347 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
132
133# 353 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
134
135# 359 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
136
137# 365 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
138
139# 371 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
140
141# 377 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
142! New line at end of file is required for FYPP
143# 3 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
144# 1 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp" 1
145# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
146# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
147# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
148# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
149# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
150# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
151
152# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
153# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
154# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
155
156# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
157
158# 46 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
159
160# 58 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
161
162# 68 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
163
164# 98 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
165
166# 110 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
167
168# 120 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
169
170# 145 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
171! New line at end of file is required for FYPP
172# 2 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp" 2
173
174# 7 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
175
176# 17 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
177
178# 22 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
179
180# 27 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
181
182# 32 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
183
184# 37 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
185
186# 42 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
187
188# 47 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
189
190# 52 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
191
192# 57 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
193
194# 62 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
195
196# 73 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
197
198# 78 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
199
200# 83 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
201
202# 88 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
203
204# 103 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
205
206# 131 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
207
208# 160 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
209
210# 175 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
211
212# 193 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
213
214# 215 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
215
216# 244 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
217
218# 259 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
219
220# 269 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
221
222# 278 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
223
224# 294 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
225
226# 304 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
227
228# 311 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
229! New line at end of file is required for FYPP
230# 4 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
231
232! GPU parallel region (scalar reductions, maxval/minval)
233# 23 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
234
235! GPU parallel loop over threads (most common GPU macro)
236# 43 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
237
238! Required closing for GPU_PARALLEL_LOOP
239# 55 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
240
241! Mark routine for device compilation
242# 112 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
243
244! Declare device-resident data
245# 130 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
246
247! Inner loop within a GPU parallel region
248# 145 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
249
250! Scoped GPU data region
251# 164 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
252
253! Host code with device pointers (for MPI with GPU buffers)
254# 193 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
255
256! Allocate device memory (unscoped)
257# 207 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
258
259! Free device memory
260# 219 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
261
262! Atomic operation on device
263# 231 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
264
265! End atomic capture block
266# 242 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
267
268! Copy data between host and device
269# 254 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
270
271! Synchronization barrier
272# 266 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
273
274! Import GPU library module (openacc or omp_lib)
275# 275 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
276
277! Emit code only for AMD compiler
278# 282 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
279
280! Emit code for non-Cray compilers
281# 289 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
282
283! Emit code only for Cray compiler
284# 296 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
285
286! Emit code for non-NVIDIA compilers
287# 303 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
288
289# 305 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
290# 306 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
291! New line at end of file is required for FYPP
292# 2 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp" 2
293
294# 14 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
295
296! Caution: This macro requires the use of a binding script to set CUDA_VISIBLE_DEVICES, such that we have one GPU device per MPI
297! rank. That's because for both cudaMemAdvise (preferred location) and cudaMemPrefetchAsync we use location = device_id = 0. For an
298! example see misc/nvidia_uvm/bind.sh. NVIDIA unified memory page placement hint
299# 57 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
300
301! Allocate and create GPU device memory
302# 77 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
303
304! Free GPU device memory and deallocate
305# 85 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
306
307! Cray-specific GPU pointer setup for vector fields
308# 109 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
309
310! Cray-specific GPU pointer setup for scalar fields
311# 125 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
312
313! Cray-specific GPU pointer setup for acoustic source spatials
314# 150 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
315
316# 156 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
317
318# 163 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
319! New line at end of file is required for FYPP
320# 6 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp" 2
321
322!> @brief One-way acoustic source injection, Maeda and Colonius JCP (2017)
323module m_acoustic_src
324
325 use m_derived_types
326 use m_global_parameters
327 use m_bubbles
328 use m_variables_conversion
329 use m_helper_basic
330 use m_constants
331
332 implicit none
333
334 private; public :: s_initialize_acoustic_src, s_precalculate_acoustic_spatial_sources, s_acoustic_src_calculations
335
336 integer, allocatable, dimension(:) :: pulse, support
337
338# 22 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
339#if defined(MFC_OpenACC)
340# 22 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
341!$acc declare create(pulse, support)
342# 22 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
343#elif defined(MFC_OpenMP)
344# 22 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
345!$omp declare target (pulse, support)
346# 22 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
347#endif
348
349 logical, allocatable, dimension(:) :: dipole
350
351# 25 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
352#if defined(MFC_OpenACC)
353# 25 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
354!$acc declare create(dipole)
355# 25 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
356#elif defined(MFC_OpenMP)
357# 25 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
358!$omp declare target (dipole)
359# 25 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
360#endif
361
362 real(wp), allocatable, target, dimension(:,:) :: loc_acoustic
363
364# 28 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
365#if defined(MFC_OpenACC)
366# 28 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
367!$acc declare create(loc_acoustic)
368# 28 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
369#elif defined(MFC_OpenMP)
370# 28 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
371!$omp declare target (loc_acoustic)
372# 28 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
373#endif
374
375 real(wp), allocatable, dimension(:) :: mag, length, height, wavelength, frequency
376 real(wp), allocatable, dimension(:) :: gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay
377
378# 32 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
379#if defined(MFC_OpenACC)
380# 32 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
381!$acc declare create(mag, length, height, wavelength, frequency)
382# 32 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
383#elif defined(MFC_OpenMP)
384# 32 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
385!$omp declare target (mag, length, height, wavelength, frequency)
386# 32 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
387#endif
388
389# 33 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
390#if defined(MFC_OpenACC)
391# 33 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
392!$acc declare create(gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay)
393# 33 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
394#elif defined(MFC_OpenMP)
395# 33 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
396!$omp declare target (gauss_sigma_dist, gauss_sigma_time, npulse, dir, delay)
397# 33 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
398#endif
399
400 real(wp), allocatable, dimension(:) :: foc_length, aperture
401
402# 36 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
403#if defined(MFC_OpenACC)
404# 36 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
405!$acc declare create(foc_length, aperture)
406# 36 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
407#elif defined(MFC_OpenMP)
408# 36 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
409!$omp declare target (foc_length, aperture)
410# 36 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
411#endif
412
413 real(wp), allocatable, dimension(:) :: element_spacing_angle, element_polygon_ratio, rotate_angle
414
415# 39 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
416#if defined(MFC_OpenACC)
417# 39 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
418!$acc declare create(element_spacing_angle, element_polygon_ratio, rotate_angle)
419# 39 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
420#elif defined(MFC_OpenMP)
421# 39 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
422!$omp declare target (element_spacing_angle, element_polygon_ratio, rotate_angle)
423# 39 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
424#endif
425
426 real(wp), allocatable, dimension(:) :: bb_bandwidth, bb_lowest_freq
427
428# 42 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
429#if defined(MFC_OpenACC)
430# 42 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
431!$acc declare create(bb_bandwidth, bb_lowest_freq)
432# 42 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
433#elif defined(MFC_OpenMP)
434# 42 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
435!$omp declare target (bb_bandwidth, bb_lowest_freq)
436# 42 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
437#endif
438
439 integer, allocatable, dimension(:) :: num_elements, element_on, bb_num_freq
440
441# 45 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
442#if defined(MFC_OpenACC)
443# 45 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
444!$acc declare create(num_elements, element_on, bb_num_freq)
445# 45 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
446#elif defined(MFC_OpenMP)
447# 45 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
448!$omp declare target (num_elements, element_on, bb_num_freq)
449# 45 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
450#endif
451
452 !> @name Acoustic source terms
453 !> @{
454 real(wp), allocatable, dimension(:,:,:) :: mass_src, e_src
455 real(wp), allocatable, dimension(:,:,:,:) :: mom_src
456 !> @}
457
458# 52 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
459#if defined(MFC_OpenACC)
460# 52 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
461!$acc declare create(mass_src, e_src, mom_src)
462# 52 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
463#elif defined(MFC_OpenMP)
464# 52 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
465!$omp declare target (mass_src, e_src, mom_src)
466# 52 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
467#endif
468
469 integer, dimension(:), allocatable :: source_spatials_num_points !< Number of non-zero source grid points for each source
470
471# 55 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
472#if defined(MFC_OpenACC)
473# 55 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
474!$acc declare create(source_spatials_num_points)
475# 55 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
476#elif defined(MFC_OpenMP)
477# 55 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
478!$omp declare target (source_spatials_num_points)
479# 55 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
480#endif
481
482 type(source_spatial_type), dimension(:), allocatable :: source_spatials !< Data of non-zero source grid points for each source
483
484# 58 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
485#if defined(MFC_OpenACC)
486# 58 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
487!$acc declare create(source_spatials)
488# 58 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
489#elif defined(MFC_OpenMP)
490# 58 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
491!$omp declare target (source_spatials)
492# 58 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
493#endif
494
495contains
496
497 !> Initialize the acoustic source module
498 impure subroutine s_initialize_acoustic_src
499
500 integer :: i, j !< generic loop variables
501
502#ifdef MFC_DEBUG
503# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
504 block
505# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
506 use iso_fortran_env, only: output_unit
507# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
508
509# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
510 print *, 'm_acoustic_src.fpp:67: ', '@:ALLOCATE(loc_acoustic(1:3, 1:num_source), mag(1:num_source), dipole(1:num_source), support(1:num_source), length(1:num_source), height(1:num_source), wavelength(1:num_source), frequency(1:num_source), gauss_sigma_dist(1:num_source), gauss_sigma_time(1:num_source), foc_length(1:num_source), aperture(1:num_source), npulse(1:num_source), pulse(1:num_source), dir(1:num_source), delay(1:num_source), element_polygon_ratio(1:num_source), rotate_angle(1:num_source), element_spacing_angle(1:num_source), num_elements(1:num_source), element_on(1:num_source), bb_num_freq(1:num_source), bb_bandwidth(1:num_source), bb_lowest_freq(1:num_source))'
511# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
512
513# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
514 call flush (output_unit)
515# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
516 end block
517# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
518#endif
519# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
520 allocate (loc_acoustic(1:3, 1:num_source), mag(1:num_source), dipole(1:num_source), support(1:num_source), length(1:num_source), height(1:num_source), wavelength(1:num_source), frequency(1:num_source), gauss_sigma_dist(1:num_source), gauss_sigma_time(1:num_source), foc_length(1:num_source), aperture(1:num_source), npulse(1:num_source), pulse(1:num_source), dir(1:num_source), delay(1:num_source), element_polygon_ratio(1:num_source), rotate_angle(1:num_source), element_spacing_angle(1:num_source), num_elements(1:num_source), element_on(1:num_source), bb_num_freq(1:num_source), bb_bandwidth(1:num_source), bb_lowest_freq(1:num_source))
521# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
522
523# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
524
525# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
526
527# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
528
529# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
530
531# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
532
533# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
534
535# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
536
537# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
538
539# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
540
541# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
542
543# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
544
545# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
546
547# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
548
549# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
550
551# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
552
553# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
554
555# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
556
557# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
558
559# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
560
561# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
562
563# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
564
565# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
566
567# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
568
569# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
570
571# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
572#if defined(MFC_OpenACC)
573# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
574!$acc enter data create(loc_acoustic, mag, dipole, support, length, height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, foc_length, aperture, npulse, pulse, dir, delay, element_polygon_ratio, rotate_angle, element_spacing_angle, num_elements, element_on, bb_num_freq, bb_bandwidth, bb_lowest_freq)
575# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
576#elif defined(MFC_OpenMP)
577# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
578!$omp target enter data map(always,alloc:loc_acoustic, mag, dipole, support, length, height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, foc_length, aperture, npulse, pulse, dir, delay, element_polygon_ratio, rotate_angle, element_spacing_angle, num_elements, element_on, bb_num_freq, bb_bandwidth, bb_lowest_freq)
579# 67 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
580#endif
581# 73 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
582
583 do i = 1, num_source
584 do j = 1, 3
585 loc_acoustic(j, i) = acoustic(i)%loc(j)
586 end do
587 mag(i) = acoustic(i)%mag
588 dipole(i) = acoustic(i)%dipole
589 support(i) = acoustic(i)%support
590 length(i) = acoustic(i)%length
591 height(i) = acoustic(i)%height
592 wavelength(i) = acoustic(i)%wavelength
593 frequency(i) = acoustic(i)%frequency
594 gauss_sigma_dist(i) = acoustic(i)%gauss_sigma_dist
595 gauss_sigma_time(i) = acoustic(i)%gauss_sigma_time
596 foc_length(i) = acoustic(i)%foc_length
597 aperture(i) = acoustic(i)%aperture
598 npulse(i) = acoustic(i)%npulse
599 pulse(i) = acoustic(i)%pulse
600 dir(i) = acoustic(i)%dir
601 element_spacing_angle(i) = acoustic(i)%element_spacing_angle
602 element_polygon_ratio(i) = acoustic(i)%element_polygon_ratio
603 num_elements(i) = acoustic(i)%num_elements
604 bb_num_freq(i) = acoustic(i)%bb_num_freq
605 bb_bandwidth(i) = acoustic(i)%bb_bandwidth
606 bb_lowest_freq(i) = acoustic(i)%bb_lowest_freq
607
608 if (acoustic(i)%element_on == dflt_int) then
609 element_on(i) = 0
610 else
611 element_on(i) = acoustic(i)%element_on
612 end if
613 if (f_is_default(acoustic(i)%rotate_angle)) then
614 rotate_angle(i) = 0._wp
615 else
616 rotate_angle(i) = acoustic(i)%rotate_angle
617 end if
618 if (f_is_default(acoustic(i)%delay)) then ! m_checker guarantees acoustic(i)%delay is set for pulse = 2 (Gaussian)
619 delay(i) = 0._wp ! Defaults to zero for sine and square waves
620 else
621 delay(i) = acoustic(i)%delay
622 end if
623 end do
624
625# 115 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
626#if defined(MFC_OpenACC)
627# 115 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
628!$acc update device(loc_acoustic, mag, dipole, support, length, height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, foc_length, aperture, npulse, pulse, dir, delay, element_polygon_ratio, rotate_angle, element_spacing_angle, num_elements, element_on, bb_num_freq, bb_bandwidth, bb_lowest_freq)
629# 115 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
630#elif defined(MFC_OpenMP)
631# 115 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
632!$omp target update to(loc_acoustic, mag, dipole, support, length, height, wavelength, frequency, gauss_sigma_dist, gauss_sigma_time, foc_length, aperture, npulse, pulse, dir, delay, element_polygon_ratio, rotate_angle, element_spacing_angle, num_elements, element_on, bb_num_freq, bb_bandwidth, bb_lowest_freq)
633# 115 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
634#endif
635# 118 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
636
637#ifdef MFC_DEBUG
638# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
639 block
640# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
641 use iso_fortran_env, only: output_unit
642# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
643
644# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
645 print *, 'm_acoustic_src.fpp:119: ', '@:ALLOCATE(mass_src(0:m, 0:n, 0:p))'
646# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
647
648# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
649 call flush (output_unit)
650# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
651 end block
652# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
653#endif
654# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
655 allocate (mass_src(0:m, 0:n, 0:p))
656# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
657
658# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
659
660# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
661#if defined(MFC_OpenACC)
662# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
663!$acc enter data create(mass_src)
664# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
665#elif defined(MFC_OpenMP)
666# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
667!$omp target enter data map(always,alloc:mass_src)
668# 119 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
669#endif
670#ifdef MFC_DEBUG
671# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
672 block
673# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
674 use iso_fortran_env, only: output_unit
675# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
676
677# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
678 print *, 'm_acoustic_src.fpp:120: ', '@:ALLOCATE(mom_src(1:num_vels, 0:m, 0:n, 0:p))'
679# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
680
681# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
682 call flush (output_unit)
683# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
684 end block
685# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
686#endif
687# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
688 allocate (mom_src(1:num_vels, 0:m, 0:n, 0:p))
689# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
690
691# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
692
693# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
694#if defined(MFC_OpenACC)
695# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
696!$acc enter data create(mom_src)
697# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
698#elif defined(MFC_OpenMP)
699# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
700!$omp target enter data map(always,alloc:mom_src)
701# 120 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
702#endif
703#ifdef MFC_DEBUG
704# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
705 block
706# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
707 use iso_fortran_env, only: output_unit
708# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
709
710# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
711 print *, 'm_acoustic_src.fpp:121: ', '@:ALLOCATE(E_src(0:m, 0:n, 0:p))'
712# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
713
714# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
715 call flush (output_unit)
716# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
717 end block
718# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
719#endif
720# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
721 allocate (e_src(0:m, 0:n, 0:p))
722# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
723
724# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
725
726# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
727#if defined(MFC_OpenACC)
728# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
729!$acc enter data create(E_src)
730# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
731#elif defined(MFC_OpenMP)
732# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
733!$omp target enter data map(always,alloc:E_src)
734# 121 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
735#endif
736
737 end subroutine s_initialize_acoustic_src
738
739 !> Compute mass, momentum, and energy acoustic source terms and add to the RHS
740 impure subroutine s_acoustic_src_calculations(q_cons_vf, q_prim_vf, rhs_vf)
741
742 type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf !< Conservative variables
743 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf !< Primitive variables
744 type(scalar_field), dimension(sys_size), intent(inout) :: rhs_vf
745
746# 135 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
747 real(wp), dimension(num_fluids) :: myalpha, myalpha_rho
748# 137 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
749 real(wp) :: myrho, b_tait
750 real(wp) :: sim_time, c, small_gamma
751 real(wp) :: frequency_local, gauss_sigma_time_local
752 real(wp) :: mass_src_diff, mom_src_diff
753 real(wp) :: source_temporal
754 real(wp) :: period_bb !< period of each sine wave in broadband source
755 real(wp) :: sl_bb !< spectral level at each frequency
756 real(wp) :: ffre_bb !< source term corresponding to each frequency
757 real(wp) :: sum_bb !< total source term for the broadband wave
758 real(wp), allocatable, dimension(:) :: phi_rn !< random phase shift for each frequency
759 integer :: i, j, k, l, q !< generic loop variables
760 integer :: ai !< acoustic source index
761 integer :: num_points
762 logical :: freq_conv_flag, gauss_conv_flag
763 integer, parameter :: mass_label = 1, mom_label = 2
764
765 sim_time = mytime ! Accumulated time, correct under adaptive dt
766
767
768# 155 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
769
770# 155 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
771#if defined(MFC_OpenACC)
772# 155 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
773!$acc parallel loop collapse(3) gang vector default(present) private(j, k, l)
774# 155 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
775#elif defined(MFC_OpenMP)
776# 155 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
777
778# 155 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
779
780# 155 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
781
782# 155 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
783!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(j, k, l)
784# 155 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
785#endif
786 do l = 0, p
787 do k = 0, n
788 do j = 0, m
789 mass_src(j, k, l) = 0._wp
790 mom_src(1, j, k, l) = 0._wp
791 e_src(j, k, l) = 0._wp
792 if (n > 0) mom_src(2, j, k, l) = 0._wp
793 if (p > 0) mom_src(3, j, k, l) = 0._wp
794 end do
795 end do
796 end do
797
798# 167 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
799#if defined(MFC_OpenACC)
800# 167 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
801!$acc end parallel loop
802# 167 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
803#elif defined(MFC_OpenMP)
804# 167 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
805
806# 167 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
807!$omp end target teams loop
808# 167 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
809#endif
810
811 ! Keep outer loop sequential because different sources can have very different number of points
812 do ai = 1, num_source
813 ! Skip if the pulse has not started yet for sine and square waves
814 if (.not. (sim_time < delay(ai) .and. (pulse(ai) == 1 .or. pulse(ai) == 3))) then
815 ! Decide if frequency need to be converted from wavelength
816 freq_conv_flag = f_is_default(frequency(ai))
817 gauss_conv_flag = f_is_default(gauss_sigma_time(ai))
818
819 num_points = source_spatials_num_points(ai) ! Use scalar to force firstprivate to prevent GPU bug
820
821 ! Calculate the broadband source
822 period_bb = 0._wp
823 sl_bb = 0._wp
824 ffre_bb = 0._wp
825 sum_bb = 0._wp
826
827 ! Allocate buffers for random phase shift
828 allocate (phi_rn(1:bb_num_freq(ai)))
829 phi_rn(1:bb_num_freq(ai)) = 0._wp
830
831 if (pulse(ai) == 4) then
832 call random_number(phi_rn(1:bb_num_freq(ai)))
833 ! Ensure all the ranks have the same random phase shift
834 call s_mpi_send_random_number(phi_rn, bb_num_freq(ai))
835 end if
836
837 do k = 1, bb_num_freq(ai)
838 ! Acoustic period of the wave at each discrete frequency
839 period_bb = 1._wp/(bb_lowest_freq(ai) + k*bb_bandwidth(ai))
840 ! Spectral level at each frequency
841 sl_bb = broadband_spectral_level_constant*mag(ai) + k*mag(ai)/broadband_spectral_level_growth_rate
842 ! Source term corresponding to each frequencies
843 ffre_bb = sqrt((2._wp*sl_bb*bb_bandwidth(ai)))*cos((sim_time)*2._wp*pi/period_bb + 2._wp*pi*phi_rn(k))
844 ! Sum up the source term of each frequency to obtain the total source term for broadband wave
845 sum_bb = sum_bb + ffre_bb
846 end do
847
848 deallocate (phi_rn)
849
850
851# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
852
853# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
854#if defined(MFC_OpenACC)
855# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
856!$acc parallel loop gang vector default(present) &
857# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
858!$acc& private(myalpha, myalpha_rho, myRho, B_tait, c, small_gamma, frequency_local, gauss_sigma_time_local, mass_src_diff, mom_src_diff, source_temporal, j, k, l, q) &
859# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
860!$acc& copyin(sum_BB, freq_conv_flag, gauss_conv_flag, sim_time)
861# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
862#elif defined(MFC_OpenMP)
863# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
864
865# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
866
867# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
868
869# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
870!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) &
871# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
872!$omp& private(myalpha, myalpha_rho, myRho, B_tait, c, small_gamma, frequency_local, gauss_sigma_time_local, mass_src_diff, mom_src_diff, source_temporal, j, k, l, q) &
873# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
874!$omp& map(to:sum_BB, freq_conv_flag, gauss_conv_flag, sim_time)
875# 208 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
876#endif
877# 211 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
878 do i = 1, num_points
879 j = source_spatials(ai)%coord(1, i)
880 k = source_spatials(ai)%coord(2, i)
881 l = source_spatials(ai)%coord(3, i)
882
883 ! Compute speed of sound
884 myrho = 0._wp
885 b_tait = 0._wp
886 small_gamma = 0._wp
887
888
889# 221 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
890#if defined(MFC_OpenACC)
891# 221 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
892!$acc loop seq
893# 221 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
894#elif defined(MFC_OpenMP)
895# 221 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
896
897# 221 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
898#endif
899 do q = 1, num_fluids
900 myalpha_rho(q) = q_cons_vf(q)%sf(j, k, l)
901 myalpha(q) = q_cons_vf(eqn_idx%adv%beg + q - 1)%sf(j, k, l)
902 end do
903
904 if (bubbles_euler) then
905 if (num_fluids > 2) then
906
907# 229 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
908#if defined(MFC_OpenACC)
909# 229 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
910!$acc loop seq
911# 229 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
912#elif defined(MFC_OpenMP)
913# 229 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
914
915# 229 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
916#endif
917 do q = 1, num_fluids - 1
918 myrho = myrho + myalpha_rho(q)
919 b_tait = b_tait + myalpha(q)*pi_infs(q)
920 small_gamma = small_gamma + myalpha(q)*gammas(q)
921 end do
922 else
923 myrho = myalpha_rho(1)
924 b_tait = pi_infs(1)
925 small_gamma = gammas(1)
926 end if
927 end if
928
929 if ((.not. bubbles_euler) .or. (mpp_lim .and. (num_fluids > 2))) then
930
931# 243 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
932#if defined(MFC_OpenACC)
933# 243 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
934!$acc loop seq
935# 243 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
936#elif defined(MFC_OpenMP)
937# 243 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
938
939# 243 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
940#endif
941 do q = 1, num_fluids
942 myrho = myrho + myalpha_rho(q)
943 b_tait = b_tait + myalpha(q)*pi_infs(q)
944 small_gamma = small_gamma + myalpha(q)*gammas(q)
945 end do
946 end if
947
948 small_gamma = 1._wp/small_gamma + 1._wp
949 c = sqrt(small_gamma*(q_prim_vf(eqn_idx%E)%sf(j, k, l) + ((small_gamma - 1._wp)/small_gamma)*b_tait)/myrho)
950
951 ! Wavelength to frequency conversion
952 if (pulse(ai) == 1 .or. pulse(ai) == 3) frequency_local = f_frequency_local(freq_conv_flag, ai, c)
953 if (pulse(ai) == 2) gauss_sigma_time_local = f_gauss_sigma_time_local(gauss_conv_flag, ai, c)
954
955 ! Update momentum source term
956 call s_source_temporal(sim_time, c, ai, mom_label, frequency_local, gauss_sigma_time_local, source_temporal, &
957 & sum_bb)
958 mom_src_diff = source_temporal*source_spatials(ai)%val(i)
959
960 if (dipole(ai)) then ! Double amplitude & No momentum source term (only works for Planar)
961 mass_src(j, k, l) = mass_src(j, k, l) + 2._wp*mom_src_diff/c
962 if (model_eqns /= model_eqns_4eq) e_src(j, k, l) = e_src(j, k, &
963 & l) + 2._wp*mom_src_diff*c/(small_gamma - 1._wp)
964 cycle
965 end if
966
967 if (n == 0) then ! 1D
968 mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*sign(1._wp, dir(ai)) ! Left or right-going wave
969 else if (p == 0) then ! 2D
970 if (support(ai) < 5) then ! Planar
971 mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*cos(dir(ai))
972 mom_src(2, j, k, l) = mom_src(2, j, k, l) + mom_src_diff*sin(dir(ai))
973 else
974 mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*cos(source_spatials(ai)%angle(i))
975 mom_src(2, j, k, l) = mom_src(2, j, k, l) + mom_src_diff*sin(source_spatials(ai)%angle(i))
976 end if
977 else ! 3D
978 if (support(ai) < 5) then ! Planar
979 mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*cos(dir(ai))
980 mom_src(2, j, k, l) = mom_src(2, j, k, l) + mom_src_diff*sin(dir(ai))
981 else
982 mom_src(1, j, k, l) = mom_src(1, j, k, l) + mom_src_diff*source_spatials(ai)%xyz_to_r_ratios(1, i)
983 mom_src(2, j, k, l) = mom_src(2, j, k, l) + mom_src_diff*source_spatials(ai)%xyz_to_r_ratios(2, i)
984 mom_src(3, j, k, l) = mom_src(3, j, k, l) + mom_src_diff*source_spatials(ai)%xyz_to_r_ratios(3, i)
985 end if
986 end if
987
988 ! Update mass source term
989 if (support(ai) < 5) then ! Planar
990 mass_src_diff = mom_src_diff/c
991 else ! Spherical or cylindrical support
992 ! Mass source term must be calculated differently using a correction term for spherical and cylindrical
993 ! support
994 call s_source_temporal(sim_time, c, ai, mass_label, frequency_local, gauss_sigma_time_local, &
995 & source_temporal, sum_bb)
996 mass_src_diff = source_temporal*source_spatials(ai)%val(i)
997 end if
998 mass_src(j, k, l) = mass_src(j, k, l) + mass_src_diff
999
1000 ! Update energy source term
1001 if (model_eqns /= model_eqns_4eq) then
1002 e_src(j, k, l) = e_src(j, k, l) + mass_src_diff*c**2._wp/(small_gamma - 1._wp)
1003 end if
1004 end do
1005
1006# 308 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1007#if defined(MFC_OpenACC)
1008# 308 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1009!$acc end parallel loop
1010# 308 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1011#elif defined(MFC_OpenMP)
1012# 308 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1013
1014# 308 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1015!$omp end target teams loop
1016# 308 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1017#endif
1018 end if
1019 end do
1020
1021 ! Update the rhs variables
1022
1023# 313 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1024
1025# 313 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1026#if defined(MFC_OpenACC)
1027# 313 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1028!$acc parallel loop collapse(3) gang vector default(present) private(j, k, l)
1029# 313 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1030#elif defined(MFC_OpenMP)
1031# 313 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1032
1033# 313 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1034
1035# 313 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1036
1037# 313 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1038!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(j, k, l)
1039# 313 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1040#endif
1041 do l = 0, p
1042 do k = 0, n
1043 do j = 0, m
1044
1045# 317 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1046#if defined(MFC_OpenACC)
1047# 317 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1048!$acc loop seq
1049# 317 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1050#elif defined(MFC_OpenMP)
1051# 317 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1052
1053# 317 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1054#endif
1055 do q = eqn_idx%cont%beg, eqn_idx%cont%end
1056 rhs_vf(q)%sf(j, k, l) = rhs_vf(q)%sf(j, k, l) + mass_src(j, k, l)
1057 end do
1058
1059# 321 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1060#if defined(MFC_OpenACC)
1061# 321 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1062!$acc loop seq
1063# 321 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1064#elif defined(MFC_OpenMP)
1065# 321 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1066
1067# 321 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1068#endif
1069 do q = eqn_idx%mom%beg, eqn_idx%mom%end
1070 rhs_vf(q)%sf(j, k, l) = rhs_vf(q)%sf(j, k, l) + mom_src(q - eqn_idx%cont%end, j, k, l)
1071 end do
1072 rhs_vf(eqn_idx%E)%sf(j, k, l) = rhs_vf(eqn_idx%E)%sf(j, k, l) + e_src(j, k, l)
1073 end do
1074 end do
1075 end do
1076
1077# 329 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1078#if defined(MFC_OpenACC)
1079# 329 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1080!$acc end parallel loop
1081# 329 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1082#elif defined(MFC_OpenMP)
1083# 329 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1084
1085# 329 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1086!$omp end target teams loop
1087# 329 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1088#endif
1089
1090 end subroutine s_acoustic_src_calculations
1091
1092 !> Compute the temporally varying amplitude of the pulse
1093 elemental subroutine s_source_temporal(sim_time, c, ai, term_index, frequency_local, gauss_sigma_time_local, source, sum_BB)
1094
1095
1096# 336 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1097#if MFC_OpenACC
1098# 336 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1099!$acc routine seq
1100# 336 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1101#elif MFC_OpenMP
1102# 336 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1103
1104# 336 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1105
1106# 336 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1107!$omp declare target device_type(any)
1108# 336 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1109#endif
1110 integer, intent(in) :: ai, term_index
1111 real(wp), intent(in) :: sim_time, c, sum_bb
1112 real(wp), intent(in) :: frequency_local, gauss_sigma_time_local
1113 real(wp), intent(out) :: source
1114 real(wp) :: omega !< angular frequency
1115 real(wp) :: sine_wave !< sine function for square wave
1116 real(wp) :: foc_length_factor !< Scale amplitude with radius for spherical support
1117 ! i.e. Spherical support -> 1/r scaling; Cylindrical support -> 1/sqrt(r) [empirical correction: ^-0.5 -> ^-0.85]
1118 integer, parameter :: mass_label = 1
1119
1120 if (n == 0) then
1121 foc_length_factor = 1._wp
1122 else if (p == 0 .and. (.not. cyl_coord)) then ! 2D axisymmetric case is physically 3D
1123 foc_length_factor = foc_length(ai)**(-0.85_wp) ! Empirical correction
1124 else
1125 foc_length_factor = 1/foc_length(ai)
1126 end if
1127
1128 source = 0._wp
1129
1130 ! Temporal waveform: sine, Gaussian pulse, square wave, or broadband
1131 if (pulse(ai) == 1) then ! Sine wave
1132 if ((sim_time - delay(ai))*frequency_local > npulse(ai)) return
1133
1134 omega = 2._wp*pi*frequency_local
1135 source = mag(ai)*sin((sim_time - delay(ai))*omega)
1136
1137 if (term_index == mass_label) then
1138 source = source/c + foc_length_factor*mag(ai)*(cos((sim_time - delay(ai))*omega) - 1._wp)/omega
1139 end if
1140 else if (pulse(ai) == 2) then ! Gaussian pulse
1141 source = mag(ai)*exp(-0.5_wp*((sim_time - delay(ai))**2._wp)/(gauss_sigma_time_local**2._wp))
1142
1143 if (term_index == mass_label) then
1144 source = source/c - foc_length_factor*mag(ai)*sqrt(pi/2)*gauss_sigma_time_local*(erf((sim_time - delay(ai)) &
1145 & /(sqrt(2._wp)*gauss_sigma_time_local)) + 1)
1146 end if
1147 else if (pulse(ai) == 3) then ! Square wave
1148 if ((sim_time - delay(ai))*frequency_local > npulse(ai)) return
1149
1150 omega = 2._wp*pi*frequency_local
1151 sine_wave = sin((sim_time - delay(ai))*omega)
1152 source = mag(ai)*sign(1._wp, sine_wave)
1153
1154 ! Prevent max-norm differences due to compilers to pass CI
1155 if (abs(sine_wave) < 1.e-2_wp) then
1156 source = mag(ai)*sine_wave*1.e2_wp
1157 end if
1158 else if (pulse(ai) == 4) then ! Broadband wave
1159 source = sum_bb
1160 end if
1161
1162 end subroutine s_source_temporal
1163
1164 !> Pre-compute non-zero spatial source weights before time-stepping
1165 impure subroutine s_precalculate_acoustic_spatial_sources
1166
1167 integer :: j, k, l, ai
1168 integer :: count
1169 integer :: dim
1170 real(wp) :: source_spatial, angle, xyz_to_r_ratios(3)
1171 real(wp), parameter :: threshold = 1.e-10_wp
1172
1173 if (n == 0) then
1174 dim = 1
1175 else if (p == 0) then
1176 dim = 2
1177 else
1178 dim = 3
1179 end if
1180
1181#ifdef MFC_DEBUG
1182# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1183 block
1184# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1185 use iso_fortran_env, only: output_unit
1186# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1187
1188# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1189 print *, 'm_acoustic_src.fpp:408: ', '@:ALLOCATE(source_spatials_num_points(1:num_source))'
1190# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1191
1192# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1193 call flush (output_unit)
1194# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1195 end block
1196# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1197#endif
1198# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1199 allocate (source_spatials_num_points(1:num_source))
1200# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1201
1202# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1203
1204# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1205#if defined(MFC_OpenACC)
1206# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1207!$acc enter data create(source_spatials_num_points)
1208# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1209#elif defined(MFC_OpenMP)
1210# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1211!$omp target enter data map(always,alloc:source_spatials_num_points)
1212# 408 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1213#endif
1214#ifdef MFC_DEBUG
1215# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1216 block
1217# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1218 use iso_fortran_env, only: output_unit
1219# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1220
1221# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1222 print *, 'm_acoustic_src.fpp:409: ', '@:ALLOCATE(source_spatials(1:num_source))'
1223# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1224
1225# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1226 call flush (output_unit)
1227# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1228 end block
1229# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1230#endif
1231# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1232 allocate (source_spatials(1:num_source))
1233# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1234
1235# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1236
1237# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1238#if defined(MFC_OpenACC)
1239# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1240!$acc enter data create(source_spatials)
1241# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1242#elif defined(MFC_OpenMP)
1243# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1244!$omp target enter data map(always,alloc:source_spatials)
1245# 409 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1246#endif
1247
1248 do ai = 1, num_source
1249 ! First pass: Count the number of points for each source
1250 count = 0
1251 do l = 0, p
1252 do k = 0, n
1253 do j = 0, m
1254 call s_source_spatial(j, k, l, loc_acoustic(:,ai), ai, source_spatial, angle, xyz_to_r_ratios)
1255 if (abs(source_spatial) < threshold) cycle
1256 count = count + 1
1257 end do
1258 end do
1259 end do
1260 source_spatials_num_points(ai) = count
1261
1262 ! Allocate arrays with the correct size
1263
1264#ifdef MFC_DEBUG
1265# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1266 block
1267# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1268 use iso_fortran_env, only: output_unit
1269# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1270
1271# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1272 print *, 'm_acoustic_src.fpp:427: ', '@:ALLOCATE(source_spatials(ai)%coord(1:3, 1:count))'
1273# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1274
1275# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1276 call flush (output_unit)
1277# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1278 end block
1279# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1280#endif
1281# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1282 allocate (source_spatials(ai)%coord(1:3, 1:count))
1283# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1284
1285# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1286
1287# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1288#if defined(MFC_OpenACC)
1289# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1290!$acc enter data create(source_spatials(ai)%coord)
1291# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1292#elif defined(MFC_OpenMP)
1293# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1294!$omp target enter data map(always,alloc:source_spatials(ai)%coord)
1295# 427 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1296#endif
1297#ifdef MFC_DEBUG
1298# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1299 block
1300# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1301 use iso_fortran_env, only: output_unit
1302# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1303
1304# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1305 print *, 'm_acoustic_src.fpp:428: ', '@:ALLOCATE(source_spatials(ai)%val(1:count))'
1306# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1307
1308# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1309 call flush (output_unit)
1310# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1311 end block
1312# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1313#endif
1314# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1315 allocate (source_spatials(ai)%val(1:count))
1316# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1317
1318# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1319
1320# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1321#if defined(MFC_OpenACC)
1322# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1323!$acc enter data create(source_spatials(ai)%val)
1324# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1325#elif defined(MFC_OpenMP)
1326# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1327!$omp target enter data map(always,alloc:source_spatials(ai)%val)
1328# 428 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1329#endif
1330#ifdef MFC_DEBUG
1331# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1332 block
1333# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1334 use iso_fortran_env, only: output_unit
1335# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1336
1337# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1338 print *, 'm_acoustic_src.fpp:429: ', '@:ALLOCATE(source_spatials(ai)%angle(1:count))'
1339# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1340
1341# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1342 call flush (output_unit)
1343# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1344 end block
1345# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1346#endif
1347# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1348 allocate (source_spatials(ai)%angle(1:count))
1349# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1350
1351# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1352
1353# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1354#if defined(MFC_OpenACC)
1355# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1356!$acc enter data create(source_spatials(ai)%angle)
1357# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1358#elif defined(MFC_OpenMP)
1359# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1360!$omp target enter data map(always,alloc:source_spatials(ai)%angle)
1361# 429 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1362#endif
1363#ifdef MFC_DEBUG
1364# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1365 block
1366# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1367 use iso_fortran_env, only: output_unit
1368# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1369
1370# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1371 print *, 'm_acoustic_src.fpp:430: ', '@:ALLOCATE(source_spatials(ai)%xyz_to_r_ratios(1:3, 1:count))'
1372# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1373
1374# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1375 call flush (output_unit)
1376# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1377 end block
1378# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1379#endif
1380# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1381 allocate (source_spatials(ai)%xyz_to_r_ratios(1:3, 1:count))
1382# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1383
1384# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1385
1386# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1387#if defined(MFC_OpenACC)
1388# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1389!$acc enter data create(source_spatials(ai)%xyz_to_r_ratios)
1390# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1391#elif defined(MFC_OpenMP)
1392# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1393!$omp target enter data map(always,alloc:source_spatials(ai)%xyz_to_r_ratios)
1394# 430 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1395#endif
1396
1397#ifdef _CRAYFTN
1398# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1399 block
1400# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1401#ifdef MFC_DEBUG
1402# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1403 block
1404# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1405 use iso_fortran_env, only: output_unit
1406# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1407
1408# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1409 print *, 'm_acoustic_src.fpp:432: ', '@:ACC_SETUP_source_spatials(source_spatials(ai))'
1410# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1411
1412# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1413 call flush (output_unit)
1414# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1415 end block
1416# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1417#endif
1418# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1419
1420# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1421
1422# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1423#if defined(MFC_OpenACC)
1424# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1425!$acc enter data copyin(source_spatials(ai))
1426# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1427#elif defined(MFC_OpenMP)
1428# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1429!$omp target enter data map(to:source_spatials(ai))
1430# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1431#endif
1432# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1433 if (associated(source_spatials(ai)%coord)) then
1434# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1435
1436# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1437#if defined(MFC_OpenACC)
1438# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1439!$acc enter data copyin(source_spatials(ai)%coord)
1440# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1441#elif defined(MFC_OpenMP)
1442# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1443!$omp target enter data map(to:source_spatials(ai)%coord)
1444# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1445#endif
1446# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1447 end if
1448# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1449 if (associated(source_spatials(ai)%val)) then
1450# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1451
1452# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1453#if defined(MFC_OpenACC)
1454# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1455!$acc enter data copyin(source_spatials(ai)%val)
1456# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1457#elif defined(MFC_OpenMP)
1458# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1459!$omp target enter data map(to:source_spatials(ai)%val)
1460# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1461#endif
1462# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1463 end if
1464# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1465 if (associated(source_spatials(ai)%angle)) then
1466# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1467
1468# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1469#if defined(MFC_OpenACC)
1470# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1471!$acc enter data copyin(source_spatials(ai)%angle)
1472# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1473#elif defined(MFC_OpenMP)
1474# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1475!$omp target enter data map(to:source_spatials(ai)%angle)
1476# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1477#endif
1478# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1479 end if
1480# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1481 if (associated(source_spatials(ai)%xyz_to_r_ratios)) then
1482# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1483
1484# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1485#if defined(MFC_OpenACC)
1486# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1487!$acc enter data copyin(source_spatials(ai)%xyz_to_r_ratios)
1488# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1489#elif defined(MFC_OpenMP)
1490# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1491!$omp target enter data map(to:source_spatials(ai)%xyz_to_r_ratios)
1492# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1493#endif
1494# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1495 end if
1496# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1497 end block
1498# 432 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1499#endif
1500
1501 ! Second pass: Store the values
1502 count = 0 ! Reset counter
1503 do l = 0, p
1504 do k = 0, n
1505 do j = 0, m
1506 call s_source_spatial(j, k, l, loc_acoustic(:,ai), ai, source_spatial, angle, xyz_to_r_ratios)
1507 if (abs(source_spatial) < threshold) cycle
1508 count = count + 1
1509 source_spatials(ai)%coord(1, count) = j
1510 source_spatials(ai)%coord(2, count) = k
1511 source_spatials(ai)%coord(3, count) = l
1512 source_spatials(ai)%val(count) = source_spatial
1513 if (support(ai) >= 5) then
1514 if (dim == 2) source_spatials(ai)%angle(count) = angle
1515 if (dim == 3) source_spatials(ai)%xyz_to_r_ratios(1:3,count) = xyz_to_r_ratios
1516 end if
1517 end do
1518 end do
1519 end do
1520
1521 if (source_spatials_num_points(ai) /= count) then
1522 call s_mpi_abort('Fatal Error: Inconsistent allocation of source_spatials')
1523 end if
1524
1525 if (count > 0) then
1526
1527# 459 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1528#if defined(MFC_OpenACC)
1529# 459 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1530!$acc update device(source_spatials(ai)%coord)
1531# 459 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1532#elif defined(MFC_OpenMP)
1533# 459 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1534!$omp target update to(source_spatials(ai)%coord)
1535# 459 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1536#endif
1537
1538# 460 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1539#if defined(MFC_OpenACC)
1540# 460 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1541!$acc update device(source_spatials(ai)%val)
1542# 460 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1543#elif defined(MFC_OpenMP)
1544# 460 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1545!$omp target update to(source_spatials(ai)%val)
1546# 460 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1547#endif
1548 if (support(ai) >= 5) then
1549 if (dim == 2) then
1550
1551# 463 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1552#if defined(MFC_OpenACC)
1553# 463 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1554!$acc update device(source_spatials(ai)%angle)
1555# 463 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1556#elif defined(MFC_OpenMP)
1557# 463 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1558!$omp target update to(source_spatials(ai)%angle)
1559# 463 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1560#endif
1561 end if
1562 if (dim == 3) then
1563
1564# 466 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1565#if defined(MFC_OpenACC)
1566# 466 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1567!$acc update device(source_spatials(ai)%xyz_to_r_ratios)
1568# 466 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1569#elif defined(MFC_OpenMP)
1570# 466 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1571!$omp target update to(source_spatials(ai)%xyz_to_r_ratios)
1572# 466 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1573#endif
1574 end if
1575 end if
1576 end if
1577 end do
1578
1579#ifdef MFC_DEBUG
1580 do ai = 1, num_source
1581 write (*, '(A,I2,A,I8,A)') 'Acoustic source ', ai, ' has ', source_spatials_num_points(ai), &
1582 & ' grid points with non-zero source term'
1583 end do
1584#endif
1585
1586 end subroutine s_precalculate_acoustic_spatial_sources
1587
1588 !> Compute the spatial support of the acoustic source
1589 subroutine s_source_spatial(j, k, l, loc, ai, source, angle, xyz_to_r_ratios)
1590
1591 integer, intent(in) :: j, k, l, ai
1592 real(wp), dimension(3), intent(in) :: loc
1593 real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3)
1594 real(wp) :: sig, r(3)
1595
1596 ! Calculate sig spatial support width
1597
1598 if (n == 0) then
1599 sig = dx(j)
1600 else if (p == 0) then
1601 sig = maxval((/dx(j), dy(k)/))
1602 else
1603 sig = maxval((/dx(j), dy(k), dz(l)/))
1604 end if
1605 sig = sig*acoustic_spatial_support_width
1606
1607 ! Calculate displacement from acoustic source location
1608 r(1) = x_cc(j) - loc(1)
1609 if (n /= 0) r(2) = y_cc(k) - loc(2)
1610 if (p /= 0) r(3) = z_cc(l) - loc(3)
1611
1612 if (any(support(ai) == (/1, 2, 3, 4/))) then
1613 call s_source_spatial_planar(ai, sig, r, source)
1614 else if (any(support(ai) == (/5, 6, 7/))) then
1615 call s_source_spatial_transducer(ai, sig, r, source, angle, xyz_to_r_ratios)
1616 else if (any(support(ai) == (/9, 10, 11/))) then
1617 call s_source_spatial_transducer_array(ai, sig, r, source, angle, xyz_to_r_ratios)
1618 end if
1619
1620 end subroutine s_source_spatial
1621
1622 !> Compute the spatial support for planar acoustic sources in 1D, 2D, and 3D
1623 subroutine s_source_spatial_planar(ai, sig, r, source)
1624
1625 integer, intent(in) :: ai
1626 real(wp), intent(in) :: sig, r(3)
1627 real(wp), intent(out) :: source
1628 real(wp) :: dist
1629
1630 source = 0._wp
1631
1632 ! Gaussian spatial pulse profile: exp(-0.5 * (d / sigma)^2) / (sqrt(2*pi) * sigma)
1633 if (support(ai) == 1) then ! 1D
1634 source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(r(1)/(sig/2._wp))**2._wp)
1635 else if (support(ai) == 2 .or. support(ai) == 3) then ! 2D or 3D
1636 ! If we let unit vector e = (cos(dir), sin(dir)),
1637 dist = r(1)*cos(dir(ai)) + r(2)*sin(dir(ai)) ! dot(r,e)
1638 ! |r - dist*e| < length/2
1639 if ((r(1) - dist*cos(dir(ai)))**2._wp + (r(2) - dist*sin(dir(ai)))**2._wp < 0.25_wp*length(ai)**2._wp) then
1640 if (support(ai) /= 3 .or. abs(r(3)) < 0.25_wp*height(ai)) then ! additional height constraint for 3D
1641 source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(dist/(sig/2._wp))**2._wp)
1642 end if
1643 end if
1644 end if
1645
1646 end subroutine s_source_spatial_planar
1647
1648 !> Compute the spatial support for a single transducer in 2D, 2D axisymmetric, and 3D
1649 subroutine s_source_spatial_transducer(ai, sig, r, source, angle, xyz_to_r_ratios)
1650
1651 integer, intent(in) :: ai
1652 real(wp), intent(in) :: sig, r(3)
1653 real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3)
1654 real(wp) :: current_angle, angle_half_aperture, dist, norm
1655
1656 source = 0._wp ! If not affected by transducer
1657 angle = 0._wp
1658 xyz_to_r_ratios = 0._wp
1659
1660 if (support(ai) == 5 .or. support(ai) == 6) then ! 2D or 2D axisymmetric
1661 current_angle = -atan(r(2)/(foc_length(ai) - r(1)))
1662 angle_half_aperture = asin((aperture(ai)/2._wp)/(foc_length(ai)))
1663
1664 if (abs(current_angle) < angle_half_aperture .and. r(1) < foc_length(ai)) then
1665 dist = foc_length(ai) - sqrt(r(2)**2._wp + (foc_length(ai) - r(1))**2._wp)
1666 source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(dist/(sig/2._wp))**2._wp)
1667 angle = -atan(r(2)/(foc_length(ai) - r(1)))
1668 end if
1669 else if (support(ai) == 7) then ! 3D
1670 current_angle = -atan(sqrt(r(2)**2 + r(3)**2)/(foc_length(ai) - r(1)))
1671 angle_half_aperture = asin((aperture(ai)/2._wp)/(foc_length(ai)))
1672
1673 if (abs(current_angle) < angle_half_aperture .and. r(1) < foc_length(ai)) then
1674 dist = foc_length(ai) - sqrt(r(2)**2._wp + r(3)**2._wp + (foc_length(ai) - r(1))**2._wp)
1675 source = 1._wp/(sqrt(2._wp*pi)*sig/2._wp)*exp(-0.5_wp*(dist/(sig/2._wp))**2._wp)
1676
1677 norm = sqrt(r(2)**2._wp + r(3)**2._wp + (foc_length(ai) - r(1))**2._wp)
1678 xyz_to_r_ratios(1) = -(r(1) - foc_length(ai))/norm
1679 xyz_to_r_ratios(2) = -r(2)/norm
1680 xyz_to_r_ratios(3) = -r(3)/norm
1681 end if
1682 end if
1683
1684 end subroutine s_source_spatial_transducer
1685
1686 !> Compute the spatial support for multiple transducers in 2D, 2D axisymmetric, and 3D
1687 subroutine s_source_spatial_transducer_array(ai, sig, r, source, angle, xyz_to_r_ratios)
1688
1689 integer, intent(in) :: ai
1690 real(wp), intent(in) :: sig, r(3)
1691 real(wp), intent(out) :: source, angle, xyz_to_r_ratios(3)
1692 integer :: elem, elem_min, elem_max
1693 real(wp) :: current_angle, angle_half_aperture, angle_per_elem, dist
1694 real(wp) :: angle_min, angle_max, norm
1695 real(wp) :: poly_side_length, aperture_element_3D, angle_elem
1696 real(wp) :: x2, y2, z2, x3, y3, z3, C, f, half_apert, dist_interp_to_elem_center
1697
1698 if (element_on(ai) == 0) then ! Full transducer
1699 elem_min = 1
1700 elem_max = num_elements(ai)
1701 else ! Transducer element specified
1702 elem_min = element_on(ai)
1703 elem_max = element_on(ai)
1704 end if
1705
1706 source = 0._wp ! If not affected by any transducer element
1707 angle = 0._wp
1708 xyz_to_r_ratios = 0._wp
1709
1710 if (support(ai) == 9 .or. support(ai) == 10) then ! 2D or 2D axisymmetric
1711 current_angle = -atan(r(2)/(foc_length(ai) - r(1)))
1712 angle_half_aperture = asin((aperture(ai)/2._wp)/(foc_length(ai)))
1713 angle_per_elem = (2._wp*angle_half_aperture - (num_elements(ai) - 1._wp)*element_spacing_angle(ai))/num_elements(ai)
1714 dist = foc_length(ai) - sqrt(r(2)**2._wp + (foc_length(ai) - r(1))**2._wp)
1715
1716 do elem = elem_min, elem_max
1717 angle_max = angle_half_aperture - (element_spacing_angle(ai) + angle_per_elem)*(elem - 1._wp)
1718 angle_min = angle_max - angle_per_elem
1719
1720 if (current_angle > angle_min .and. current_angle < angle_max .and. r(1) < foc_length(ai)) then
1721 source = exp(-0.5_wp*(dist/(sig/2._wp))**2._wp)/(sqrt(2._wp*pi)*sig/2._wp)
1722 angle = current_angle
1723 exit ! Assume elements don't overlap
1724 end if
1725 end do
1726 else if (support(ai) == 11) then ! 3D
1727 poly_side_length = aperture(ai)*sin(pi/num_elements(ai))
1728 aperture_element_3d = poly_side_length*element_polygon_ratio(ai)
1729 f = foc_length(ai)
1730 half_apert = aperture(ai)/2._wp
1731
1732 do elem = elem_min, elem_max
1733 angle_elem = 2._wp*pi*real(elem, wp)/real(num_elements(ai), wp) + rotate_angle(ai)
1734
1735 ! Point 2 is the elem center
1736 x2 = f - sqrt(f**2 - half_apert**2)
1737 y2 = half_apert*cos(angle_elem)
1738 z2 = half_apert*sin(angle_elem)
1739
1740 ! Construct a plane normal to the line from the focal point to the elem center, Point 3 is the intercept of the
1741 ! plane and the line from the focal point to the current location
1742 c = f**2._wp/((r(1) - f)*(x2 - f) + r(2)*y2 + r(3)*z2) ! Constant for intermediate step
1743 x3 = c*(r(1) - f) + f
1744 y3 = c*r(2)
1745 z3 = c*r(3)
1746
1747 dist_interp_to_elem_center = sqrt((x2 - x3)**2._wp + (y2 - y3)**2._wp + (z2 - z3)**2._wp)
1748 if ((dist_interp_to_elem_center < aperture_element_3d/2._wp) .and. (r(1) < f)) then
1749 dist = sqrt((x3 - r(1))**2._wp + (y3 - r(2))**2._wp + (z3 - r(3))**2._wp)
1750 source = exp(-0.5_wp*(dist/(sig/2._wp))**2._wp)/(sqrt(2._wp*pi)*sig/2._wp)
1751
1752 norm = sqrt(r(2)**2._wp + r(3)**2._wp + (f - r(1))**2._wp)
1753 xyz_to_r_ratios(1) = -(r(1) - f)/norm
1754 xyz_to_r_ratios(2) = -r(2)/norm
1755 xyz_to_r_ratios(3) = -r(3)/norm
1756 end if
1757 end do
1758 end if
1759
1760 end subroutine s_source_spatial_transducer_array
1761
1762 !> Convert wavelength to frequency
1763 elemental function f_frequency_local(freq_conv_flag, ai, c)
1764
1765
1766# 658 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1767#if MFC_OpenACC
1768# 658 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1769!$acc routine seq
1770# 658 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1771#elif MFC_OpenMP
1772# 658 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1773
1774# 658 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1775
1776# 658 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1777!$omp declare target device_type(any)
1778# 658 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1779#endif
1780 logical, intent(in) :: freq_conv_flag
1781 integer, intent(in) :: ai
1782 real(wp), intent(in) :: c
1783 real(wp) :: f_frequency_local
1784
1785 if (freq_conv_flag) then
1786 f_frequency_local = c/wavelength(ai)
1787 else
1788 f_frequency_local = frequency(ai)
1789 end if
1790
1791 end function f_frequency_local
1792
1793 !> Convert Gaussian sigma from distance to time
1794 function f_gauss_sigma_time_local(gauss_conv_flag, ai, c)
1795
1796
1797# 675 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1798#if MFC_OpenACC
1799# 675 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1800!$acc routine seq
1801# 675 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1802#elif MFC_OpenMP
1803# 675 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1804
1805# 675 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1806
1807# 675 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1808!$omp declare target device_type(any)
1809# 675 "/home/runner/work/MFC/MFC/src/simulation/m_acoustic_src.fpp"
1810#endif
1811 logical, intent(in) :: gauss_conv_flag
1812 integer, intent(in) :: ai
1813 real(wp), intent(in) :: c
1814 real(wp) :: f_gauss_sigma_time_local
1815
1816 if (gauss_conv_flag) then
1817 f_gauss_sigma_time_local = gauss_sigma_dist(ai)/c
1818 else
1819 f_gauss_sigma_time_local = gauss_sigma_time(ai)
1820 end if
1821
1822 end function f_gauss_sigma_time_local
1823
1824end module m_acoustic_src
q_cons_vf
type(scalar_field), dimension(sys_size), intent(inout) q_cons_vf
Definition m_phase_change.fpp.f90:1076
k
integer, intent(in) k
Definition m_phase_change.fpp.f90:1078
j
integer, intent(in) j
Definition m_phase_change.fpp.f90:1078
l
integer, intent(in) l
Definition m_phase_change.fpp.f90:1078
m_acoustic_src
One-way acoustic source injection, Maeda and Colonius JCP (2017).
Definition m_acoustic_src.fpp.f90:323
m_acoustic_src::gauss_sigma_time
real(wp), dimension(:), allocatable gauss_sigma_time
Definition m_acoustic_src.fpp.f90:376
m_acoustic_src::f_frequency_local
elemental real(wp) function f_frequency_local(freq_conv_flag, ai, c)
Convert wavelength to frequency.
Definition m_acoustic_src.fpp.f90:1764
m_acoustic_src::source_spatials
type(source_spatial_type), dimension(:), allocatable source_spatials
Data of non-zero source grid points for each source.
Definition m_acoustic_src.fpp.f90:482
m_acoustic_src::s_source_spatial_transducer
subroutine s_source_spatial_transducer(ai, sig, r, source, angle, xyz_to_r_ratios)
Compute the spatial support for a single transducer in 2D, 2D axisymmetric, and 3D.
Definition m_acoustic_src.fpp.f90:1650
m_acoustic_src::height
real(wp), dimension(:), allocatable height
Definition m_acoustic_src.fpp.f90:375
m_acoustic_src::pulse
integer, dimension(:), allocatable pulse
Definition m_acoustic_src.fpp.f90:336
m_acoustic_src::bb_num_freq
integer, dimension(:), allocatable bb_num_freq
Definition m_acoustic_src.fpp.f90:439
m_acoustic_src::dir
real(wp), dimension(:), allocatable dir
Definition m_acoustic_src.fpp.f90:376
m_acoustic_src::s_precalculate_acoustic_spatial_sources
impure subroutine, public s_precalculate_acoustic_spatial_sources
Pre-compute non-zero spatial source weights before time-stepping.
Definition m_acoustic_src.fpp.f90:1166
m_acoustic_src::length
real(wp), dimension(:), allocatable length
Definition m_acoustic_src.fpp.f90:375
m_acoustic_src::rotate_angle
real(wp), dimension(:), allocatable rotate_angle
Definition m_acoustic_src.fpp.f90:413
m_acoustic_src::support
integer, dimension(:), allocatable support
Definition m_acoustic_src.fpp.f90:336
m_acoustic_src::wavelength
real(wp), dimension(:), allocatable wavelength
Definition m_acoustic_src.fpp.f90:375
m_acoustic_src::s_acoustic_src_calculations
impure subroutine, public s_acoustic_src_calculations(q_cons_vf, q_prim_vf, rhs_vf)
Compute mass, momentum, and energy acoustic source terms and add to the RHS.
Definition m_acoustic_src.fpp.f90:741
m_acoustic_src::npulse
real(wp), dimension(:), allocatable npulse
Definition m_acoustic_src.fpp.f90:376
m_acoustic_src::element_on
integer, dimension(:), allocatable element_on
Definition m_acoustic_src.fpp.f90:439
m_acoustic_src::aperture
real(wp), dimension(:), allocatable aperture
Definition m_acoustic_src.fpp.f90:400
m_acoustic_src::foc_length
real(wp), dimension(:), allocatable foc_length
Definition m_acoustic_src.fpp.f90:400
m_acoustic_src::s_source_spatial_planar
subroutine s_source_spatial_planar(ai, sig, r, source)
Compute the spatial support for planar acoustic sources in 1D, 2D, and 3D.
Definition m_acoustic_src.fpp.f90:1624
m_acoustic_src::s_source_spatial_transducer_array
subroutine s_source_spatial_transducer_array(ai, sig, r, source, angle, xyz_to_r_ratios)
Compute the spatial support for multiple transducers in 2D, 2D axisymmetric, and 3D.
Definition m_acoustic_src.fpp.f90:1688
m_acoustic_src::bb_lowest_freq
real(wp), dimension(:), allocatable bb_lowest_freq
Definition m_acoustic_src.fpp.f90:426
m_acoustic_src::num_elements
integer, dimension(:), allocatable num_elements
Definition m_acoustic_src.fpp.f90:439
m_acoustic_src::s_initialize_acoustic_src
impure subroutine, public s_initialize_acoustic_src
Initialize the acoustic source module.
Definition m_acoustic_src.fpp.f90:499
m_acoustic_src::loc_acoustic
real(wp), dimension(:,:), allocatable, target loc_acoustic
Definition m_acoustic_src.fpp.f90:362
m_acoustic_src::dipole
logical, dimension(:), allocatable dipole
Definition m_acoustic_src.fpp.f90:349
m_acoustic_src::mass_src
real(wp), dimension(:,:,:), allocatable mass_src
Definition m_acoustic_src.fpp.f90:454
m_acoustic_src::mag
real(wp), dimension(:), allocatable mag
Definition m_acoustic_src.fpp.f90:375
m_acoustic_src::frequency
real(wp), dimension(:), allocatable frequency
Definition m_acoustic_src.fpp.f90:375
m_acoustic_src::s_source_temporal
elemental subroutine s_source_temporal(sim_time, c, ai, term_index, frequency_local, gauss_sigma_time_local, source, sum_bb)
Compute the temporally varying amplitude of the pulse.
Definition m_acoustic_src.fpp.f90:1094
m_acoustic_src::f_gauss_sigma_time_local
real(wp) function f_gauss_sigma_time_local(gauss_conv_flag, ai, c)
Convert Gaussian sigma from distance to time.
Definition m_acoustic_src.fpp.f90:1795
m_acoustic_src::e_src
real(wp), dimension(:,:,:), allocatable e_src
Definition m_acoustic_src.fpp.f90:454
m_acoustic_src::s_source_spatial
subroutine s_source_spatial(j, k, l, loc, ai, source, angle, xyz_to_r_ratios)
Compute the spatial support of the acoustic source.
Definition m_acoustic_src.fpp.f90:1590
m_acoustic_src::element_spacing_angle
real(wp), dimension(:), allocatable element_spacing_angle
Definition m_acoustic_src.fpp.f90:413
m_acoustic_src::source_spatials_num_points
integer, dimension(:), allocatable source_spatials_num_points
Number of non-zero source grid points for each source.
Definition m_acoustic_src.fpp.f90:469
m_acoustic_src::element_polygon_ratio
real(wp), dimension(:), allocatable element_polygon_ratio
Definition m_acoustic_src.fpp.f90:413
m_acoustic_src::bb_bandwidth
real(wp), dimension(:), allocatable bb_bandwidth
Definition m_acoustic_src.fpp.f90:426
m_acoustic_src::gauss_sigma_dist
real(wp), dimension(:), allocatable gauss_sigma_dist
Definition m_acoustic_src.fpp.f90:376
m_acoustic_src::delay
real(wp), dimension(:), allocatable delay
Definition m_acoustic_src.fpp.f90:376
m_acoustic_src::mom_src
real(wp), dimension(:,:,:,:), allocatable mom_src
Definition m_acoustic_src.fpp.f90:455
m_bubbles
Bubble-dynamics procedures for ensemble- and volume-averaged models.
Definition m_bubbles.fpp.f90:323
m_constants
Compile-time constant parameters: default values, tolerances, and physical constants.
Definition m_constants.fpp.f90:7
m_constants::dflt_int
integer, parameter dflt_int
Default integer value.
Definition m_constants.fpp.f90:23
m_derived_types
Shared derived types for field data, patch geometry, bubble dynamics, and MPI I/O structures.
Definition m_derived_types.fpp.f90:323
m_global_parameters
Global parameters for the computational domain, fluid properties, and simulation algorithm configurat...
Definition m_global_parameters.fpp.f90:334
m_helper_basic
Basic floating-point utilities: approximate equality, default detection, and coordinate bounds.
Definition m_helper_basic.fpp.f90:323
m_helper_basic::f_is_default
logical elemental function, public f_is_default(var)
Checks if a real(wp) variable is of default value.
Definition m_helper_basic.fpp.f90:428
m_variables_conversion
Conservative-to-primitive variable conversion, mixture property evaluation, and pressure computation.
Definition m_variables_conversion.fpp.f90:334
m_derived_types::source_spatial_type
Acoustic source source_spatial pre-calculated values.
Definition m_derived_types.fpp.f90:783