Neko 1.99.1
A portable framework for high-order spectral element flow simulations
Loading...
Searching...
No Matches
utils.f90
Go to the documentation of this file.
1! Copyright (c) 2019-2021, 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!
35module utils
36 use, intrinsic :: iso_fortran_env, only: error_unit, output_unit
37 implicit none
38 private
39
40 integer, parameter :: neko_fname_len = 1024
41
42 interface neko_error
43 module procedure neko_error_plain, neko_error_msg
44 end interface neko_error
45
52
53
54contains
55
57 pure function filename_suffix_pos(fname) result(suffix_pos)
58 character(len=*), intent(in) :: fname
59 integer :: suffix_pos
60 suffix_pos = scan(trim(fname), '.', back = .true.)
61 end function filename_suffix_pos
62
64 pure function filename_tslash_pos(fname) result(tslash_pos)
65 character(len=*), intent(in) :: fname
66 integer :: tslash_pos
67 tslash_pos = scan(trim(fname), '/', back = .true.)
68 end function filename_tslash_pos
69
71 subroutine filename_path(fname, path)
72 character(len=*), intent(in) :: fname
73 character(len=*), intent(out) :: path
74 integer :: tslash_pos
75
76 tslash_pos = filename_tslash_pos(fname)
77 if (tslash_pos .gt. 0) then
78 path = trim(fname(1:tslash_pos))
79 else
80 path = './'
81 end if
82
83 end subroutine filename_path
84
86 subroutine filename_name(fname, name)
87 character(len=*), intent(in) :: fname
88 character(len=*), intent(out) :: name
89 integer :: tslash_pos, suffix_pos, start, end
90
91 tslash_pos = filename_tslash_pos(fname)
92 suffix_pos = filename_suffix_pos(fname)
93 if (tslash_pos .eq. 0) then
94 start = 1
95 else
96 start = tslash_pos + 1
97 end if
98 if (suffix_pos .eq. 0) then
99 end = len_trim(fname)
100 else
101 end = suffix_pos - 1
102 end if
103 name = trim(fname(start:end))
104 end subroutine filename_name
105
107 subroutine filename_suffix(fname, suffix)
108 character(len=*) :: fname
109 character(len=*) :: suffix
110 suffix = trim(fname(filename_suffix_pos(fname) + 1:len_trim(fname)))
111 end subroutine filename_suffix
112
114 subroutine filename_split(fname, path, name, suffix)
115 character(len=*), intent(in) :: fname
116 character(len=*), intent(out) :: path, name, suffix
117 integer :: tslash_pos, suffix_pos
118
119 tslash_pos = filename_tslash_pos(fname)
120 suffix_pos = filename_suffix_pos(fname)
121
122 if (tslash_pos .gt. 0) then
123 path = trim(fname(1:tslash_pos))
124 else
125 path = './'
126 end if
127
128 if (suffix_pos .gt. 0) then
129 name = trim(fname(tslash_pos + 1:suffix_pos - 1))
130 suffix = trim(fname(suffix_pos:len_trim(fname)))
131 else
132 name = trim(fname(tslash_pos + 1:len_trim(fname)))
133 suffix = ''
134 end if
135
136 end subroutine filename_split
137
139 subroutine filename_chsuffix(fname, new_fname, new_suffix)
140 character(len=*) :: fname
141 character(len=*) :: new_fname
142 character(len=*) :: new_suffix
143 integer :: suffix_pos
144
145 suffix_pos = filename_suffix_pos(fname)
146 new_fname = trim(fname(1:suffix_pos))//new_suffix
147
148 end subroutine filename_chsuffix
149
156 function extract_fld_file_index(fld_filename, default_index) result(index)
157 character(len=*), intent(in) :: fld_filename
158 integer, intent(in) :: default_index
159
160 character(len=80) :: suffix
161 integer :: index, fpos, i
162 logical :: valid
163
164 call filename_suffix(fld_filename, suffix)
165
166 valid = .true.
167
168 ! This value will be modified when reading the file name extension
169 ! e.g. "field0.f00035" will set sample_idx = 35
170 index = default_index
171
172 !
173 ! Try to extract the index of the field file from the suffix "fxxxxx"
174 !
175 fpos = scan(trim(suffix), 'f')
176 if (fpos .eq. 1) then
177 ! Make sure that the suffix only contains integers from 0 to 9
178 do i = 2, len(trim(suffix))
179 if (.not. (iachar(suffix(i:i)) >= iachar('0') &
180 .and. iachar(suffix(i:i)) <= iachar('9'))) then
181 valid = .false.
182 end if
183 end do
184 else
185 valid = .false.
186 end if
187
188 ! Must be exactly 6 characters long, i.e. an 'f' with 5 integers after
189 if (len(trim(suffix)) .ne. 6) valid = .false.
190
191 if (valid) read (suffix(2:), "(I5.5)") index
192
193 end function extract_fld_file_index
194
198 function split_string(string, delimiter) result(split_str)
199 character(len=*) :: string
200 character(len=*) :: delimiter
201 character(len=100), allocatable :: split_str(:)
202 integer :: length, i, i2, offset, j
203 i = 0
204 offset = 1
205 length = 1
206 if (len(trim(string)) .eq. 0) then
207 allocate(split_str(1))
208 split_str(1) = trim(string)
209 return
210 end if
211 do while (.true.)
212 i = scan(string(offset:), delimiter, back = .false.)
213 if (i .eq. 0) exit
214 length = length + 1
215 offset = offset + i
216 end do
217
218 allocate(split_str(length))
219 i = 0
220 j = 1
221 offset = 1
222 do while (.true.)
223 i2 = scan(trim(string(offset:)), delimiter, back = .false.)
224 if (i2 .eq. 0) then
225 split_str(j) = trim(string(offset:))
226 exit
227 end if
228 split_str(j) = trim(string(offset:offset+i2-2))
229 offset = offset+i2
230 j = j + 1
231 end do
232 end function split_string
233
236 pure function linear_index(i, j, k, l, lx, ly, lz) result(index)
237 integer, intent(in) :: i, j, k, l, lx, ly, lz
238 integer :: index
239
240 index = (i + lx * ((j - 1) + ly * ((k - 1) + lz * ((l - 1)))))
241 end function linear_index
242
245 pure function nonlinear_index(linear_index, lx, ly, lz) result(index)
246 integer, intent(in) :: linear_index, lx, ly, lz
247 integer :: index(4)
248 integer :: lin_idx
249 lin_idx = linear_index -1
250 index(4) = lin_idx/(lx*ly*lz)
251 index(3) = (lin_idx-(lx*ly*lz)*index(4))/(lx*ly)
252 index(2) = (lin_idx-(lx*ly*lz)*index(4)-(lx*ly)*index(3))/lx
253 index(1) = (lin_idx-(lx*ly*lz)*index(4)-(lx*ly)*index(3)-lx*index(2))
254 index(1) = index(1) + 1
255 index(2) = index(2) + 1
256 index(3) = index(3) + 1
257 index(4) = index(4) + 1
258
259 end function nonlinear_index
260
261 pure function index_is_on_facet(i, j, k, lx, ly, lz, facet) result(is_on)
262 integer, intent(in) :: i, j, k, lx, ly, lz, facet
263 logical :: is_on
264
265 is_on = .false.
266 select case (facet)
267 case (1)
268 if (i .eq. 1) is_on = .true.
269 case (2)
270 if (i .eq. lx) is_on = .true.
271 case (3)
272 if (j .eq. 1) is_on = .true.
273 case (4)
274 if (j .eq. ly) is_on = .true.
275 case (5)
276 if (k .eq. 1) is_on = .true.
277 case (6)
278 if (k .eq. lz) is_on = .true.
279 end select
280
281 end function index_is_on_facet
282
285 subroutine neko_error_plain(error_code)
286 integer, optional :: error_code
287
288 if (present(error_code)) then
289 write(error_unit, *) '*** ERROR ***', error_code
290 error stop
291 else
292 write(error_unit, *) '*** ERROR ***'
293 error stop
294 end if
295
296 end subroutine neko_error_plain
297
300 subroutine neko_error_msg(error_msg)
301 character(len=*) :: error_msg
302 write(error_unit, *) '*** ERROR: ', error_msg, ' ***'
303 error stop
304 end subroutine neko_error_msg
305
312 subroutine neko_type_error(base_type, wrong_type, known_types)
313 character(len=*), intent(in) :: base_type
314 character(len=*), intent(in) :: wrong_type
315 character(len=*), intent(in) :: known_types(:)
316 integer :: i
317
318 write(error_unit, *) '*** ERROR WHEN SELECTING TYPE ***'
319 write(error_unit, *) 'Type ', wrong_type, ' does not exist for ', base_type
320 write(error_unit, *) 'Valid types are:'
321 do i = 1, size(known_types)
322 write(error_unit, *) " ", known_types(i)
323 end do
324 error stop
325 end subroutine neko_type_error
326
327 subroutine neko_type_registration_error(base_type, wrong_type, known)
328 character(len=*), intent(in) :: base_type
329 character(len=*),intent(in) :: wrong_type
330 logical, intent(in) :: known
331
332 write(error_unit, *) '*** ERROR WHEN REGISTERING TYPE ***'
333 write(error_unit, *) 'Type name ', wrong_type, &
334 ' conflicts with and already existing ', base_type, " type"
335 if (known) then
336 write(error_unit, *) 'Please rename your custom type.'
337 else
338 write(error_unit, *) 'The already existing type is also custom.' // &
339 ' Make all custom type names unique!'
340 end if
341 error stop
342 end subroutine neko_type_registration_error
343
345 subroutine neko_warning(warning_msg)
346 character(len=*) :: warning_msg
347 write(output_unit, *) '*** WARNING: ', warning_msg, ' ***'
348 end subroutine neko_warning
349
355 function concat_string_array(array, sep, prepend) result(result)
356 character(len=*), intent(in) :: array(:)
357 character(len=*), intent(in) :: sep
358 logical, intent(in) :: prepend
359 character(:), allocatable :: result
360 integer :: i
361
362 result = trim(array(1))
363 do i = 2, size(array)
364 result = result // sep // trim(array(i))
365 end do
366
367 if (prepend .eqv. .true.) then
368 result = sep // result
369 end if
370
371 end function concat_string_array
372
373end module utils
__inline__ __device__ void nonlinear_index(const int idx, const int lx, int *index)
Definition bc_utils.h:44
Utilities.
Definition utils.f90:35
integer function, public extract_fld_file_index(fld_filename, default_index)
Extracts the index of a field file. For example, "myfield.f00045" will return 45. If the suffix of th...
Definition utils.f90:157
character(:) function, allocatable, public concat_string_array(array, sep, prepend)
Concatenate an array of strings into one string with array items separated by spaces.
Definition utils.f90:356
subroutine, public neko_type_registration_error(base_type, wrong_type, known)
Definition utils.f90:328
subroutine, public filename_name(fname, name)
Extract the base name of a file (without path and suffix)
Definition utils.f90:87
character(len=100) function, dimension(:), allocatable, public split_string(string, delimiter)
Split a string based on delimiter (tokenizer) OBS: very hacky, this should really be improved,...
Definition utils.f90:199
pure logical function, public index_is_on_facet(i, j, k, lx, ly, lz, facet)
Definition utils.f90:262
subroutine neko_error_msg(error_msg)
Reports an error and stops execution.
Definition utils.f90:301
pure integer function, public linear_index(i, j, k, l, lx, ly, lz)
Compute the address of a (i,j,k,l) array with sizes (1:lx, 1:ly, 1:lz, :)
Definition utils.f90:237
integer, parameter, public neko_fname_len
Definition utils.f90:40
subroutine filename_split(fname, path, name, suffix)
Extract file name components.
Definition utils.f90:115
subroutine, public neko_warning(warning_msg)
Reports a warning to standard output.
Definition utils.f90:346
subroutine, public filename_chsuffix(fname, new_fname, new_suffix)
Change a filename's suffix.
Definition utils.f90:140
subroutine, public filename_suffix(fname, suffix)
Extract a filename's suffix.
Definition utils.f90:108
subroutine, public neko_type_error(base_type, wrong_type, known_types)
Reports an error allocating a type for a particular base pointer class.
Definition utils.f90:313
pure integer function, public filename_tslash_pos(fname)
Find position (in the string) of a filename's trailing slash.
Definition utils.f90:65
subroutine neko_error_plain(error_code)
Reports an error and stops execution.
Definition utils.f90:286
pure integer function, public filename_suffix_pos(fname)
Find position (in the string) of a filename's suffix.
Definition utils.f90:58
subroutine, public filename_path(fname, path)
Extract the path to a file.
Definition utils.f90:72