Line data Source code
1 : !> \file mo_os.f90
2 : !> \brief \copybrief mo_os
3 : !> \details \copydetails mo_os
4 :
5 : !> \brief Path and directory management.
6 : !> \details Path handling and existence checks for files and directories.
7 : !> \changelog
8 : !! - Nicola Doering, Aug 2020
9 : !! - module implementation
10 : !! - Sebastian Mueller, Jan 2023
11 : !! - changed signatures (path, answer, verbose, raise) for path_exists, path_isfile and path_isdir
12 : !! - respect show_msg and show_err from mo_message
13 : !! - simplify inquire logic
14 : !> \copyright Copyright 2005-\today, the CHS Developers, Sabine Attinger: All rights reserved.
15 : !! FORCES is released under the LGPLv3+ license \license_note
16 : module mo_os
17 :
18 : use mo_kind, only: i4
19 :
20 : implicit none
21 :
22 : public :: get_cwd
23 : public :: change_dir
24 : public :: check_path_exists
25 : public :: check_path_isfile
26 : public :: check_path_isdir
27 : public :: path_exists
28 : public :: path_isfile
29 : public :: path_isdir
30 : public :: path_isabs
31 : public :: path_isroot
32 : public :: path_splitext
33 : public :: path_split
34 : public :: path_parts
35 : public :: path_dirname
36 : public :: path_basename
37 : public :: path_root
38 : public :: path_ext
39 : public :: path_stem
40 : public :: path_as_posix
41 : public :: path_normpath
42 : public :: path_abspath
43 : public :: path_join
44 :
45 : !> \brief Join given path segments with separator if needed.
46 : !> \details If a segment is an absolute path, the previous ones will be ignored.
47 : !> \author Sebastian Müller
48 : !> \date Mar 2023
49 : interface path_join
50 : module procedure :: path_join_char_opt
51 : module procedure :: path_join_arr
52 : end interface
53 :
54 : !> The constant string used by the operating system to refer to the current directory.
55 : character(len = *), public, parameter :: curdir = '.'
56 : !> The constant string used by the operating system to refer to the parent directory.
57 : character(len = *), public, parameter :: pardir = '..'
58 : !> The character used by the operating system to separate pathname components.
59 : character(len = *), public, parameter :: sep = '/'
60 : !> The character which separates the base filename from the extension.
61 : character(len = *), public, parameter :: extsep = '.'
62 : !> The string used to separate (or, rather, terminate) lines on the current platform.
63 : character(len = *), public, parameter :: linesep = '\n'
64 : !> The file path of the null device.
65 : character(len = *), public, parameter :: devnull = '/dev/null'
66 : !> Maximum length of a path component (folder/file names).
67 : integer(i4), public, save :: max_path_comp_len = 256_i4
68 : !> Maximum length of a path (16 max. length components).
69 : integer(i4), public, save :: max_path_len = 4096_i4
70 :
71 : private
72 :
73 : ! ------------------------------------------------------------------
74 :
75 : contains
76 :
77 : ! ------------------------------------------------------------------
78 : !> \brief Get the current working directory.
79 : !> \author Sebastian Müller
80 : !> \date Mar 2023
81 11 : subroutine get_cwd(path, status, verbose, raise)
82 : #ifdef NAG
83 : use f90_unix_dir, only : getcwd
84 : #endif
85 : #ifdef INTEL
86 : use ifport, only : getcwd
87 : #endif
88 : implicit none
89 :
90 : character(*), intent(out) :: path !< the current working directory
91 : integer(i4), intent(out), optional :: status !< error status (will prevent error raise if present)
92 : logical, intent(in), optional :: verbose !< Be verbose or not (default: setting of SHOW_MSG/SHOW_ERR)
93 : logical, intent(in), optional :: raise !< Throw an error if current directory can't be determined (default: .true.)
94 :
95 : integer(i4) :: status_
96 : logical :: raise_
97 :
98 11 : raise_ = .true.
99 1 : if ( present(raise) ) raise_ = raise
100 : ! prevent raise if error code should be returned
101 11 : raise_ = raise_ .and. .not. present(status)
102 :
103 : #ifdef NAG
104 : call getcwd(path, errno=status_)
105 : #else
106 : ! gfortran and intel can use a function
107 11 : status_ = getcwd(path)
108 : #endif
109 :
110 11 : if (status_ /= 0) call path_msg("Can't determine current working directory.", verbose=verbose, raise=raise_)
111 11 : if ( present(status) ) status = status_
112 :
113 11 : end subroutine get_cwd
114 :
115 : ! ------------------------------------------------------------------
116 : !> \brief Change current working directory.
117 : !> \author Sebastian Müller
118 : !> \date Mar 2023
119 3 : subroutine change_dir(path, status, verbose, raise)
120 : #ifdef NAG
121 : use f90_unix_dir, only : chdir
122 : #endif
123 : #ifdef INTEL
124 : use ifport, only : chdir
125 : #endif
126 : implicit none
127 :
128 : character(*), intent(in) :: path !< path to change CWD to
129 : integer(i4), intent(out), optional :: status !< error status (will prevent error raise if present)
130 : logical, intent(in), optional :: verbose !< Be verbose or not (default: setting of SHOW_MSG/SHOW_ERR)
131 : logical, intent(in), optional :: raise !< Throw an error if directory can't be opened (default: .true.)
132 :
133 : integer(i4) :: status_
134 : logical :: raise_
135 :
136 3 : raise_ = .true.
137 1 : if ( present(raise) ) raise_ = raise
138 : ! prevent raise if error code should be returned
139 3 : raise_ = raise_ .and. .not. present(status)
140 :
141 : #ifdef NAG
142 : call chdir(trim(path), errno=status_)
143 : #else
144 : ! gfortran and intel can use a function
145 3 : status_ = chdir(path)
146 : #endif
147 :
148 3 : if (status_ /= 0) call path_msg("Can't open directory: ", trim(path), verbose, raise_)
149 3 : if ( present(status) ) status = status_
150 :
151 11 : end subroutine change_dir
152 :
153 : ! ------------------------------------------------------------------
154 : !> \brief Checks whether a given path exists.
155 : !> \author Nicola Doering
156 : !> \date Aug 2020
157 6 : subroutine check_path_exists(path, answer, verbose, raise)
158 :
159 : implicit none
160 :
161 : character(len=*), intent(in) :: path !< given path
162 : logical, intent(out), optional :: answer !< result
163 : logical, intent(in), optional :: verbose !< Be verbose or not (default: setting of SHOW_MSG/SHOW_ERR)
164 : logical, intent(in), optional :: raise !< Throw an error if path does not exist (default: .false.)
165 :
166 : LOGICAL :: exists
167 :
168 12 : exists = path_exists(path)
169 6 : if (.not. exists) call path_msg("Path does not exist: ", path, verbose, raise)
170 6 : if (present(answer)) answer = exists
171 :
172 3 : end subroutine check_path_exists
173 :
174 : ! ------------------------------------------------------------------
175 : !> \brief Checks whether a given path exists and describes a file.
176 : !> \author Nicola Doering
177 : !> \date Aug 2020
178 5 : subroutine check_path_isfile(path, answer, verbose, raise)
179 :
180 : implicit none
181 :
182 : character(len=*), intent(in) :: path !< given path
183 : logical, intent(out), optional :: answer !< result
184 : logical, intent(in), optional :: verbose !< Be verbose or not (default: setting of SHOW_MSG/SHOW_ERR)
185 : logical, intent(in), optional :: raise !< Throw an error if file does not exist (default: .false.)
186 :
187 : LOGICAL :: isfile
188 :
189 10 : isfile = path_isfile(path)
190 5 : if (.not. isfile) call path_msg("File does not exist: ", path, verbose, raise)
191 5 : if (present(answer)) answer = isfile
192 :
193 6 : end subroutine check_path_isfile
194 :
195 : ! ------------------------------------------------------------------
196 : !> \brief Checks whether a given path exists and describes a directory.
197 : !> \author Nicola Doering
198 : !> \date Aug 2020
199 6 : subroutine check_path_isdir(path, answer, verbose, raise)
200 :
201 : implicit none
202 :
203 : character(len=*), intent(in) :: path !< given path
204 : logical, intent(out), optional :: answer !< result
205 : logical, intent(in), optional :: verbose !< Be verbose or not (default: setting of SHOW_MSG/SHOW_ERR)
206 : logical, intent(in), optional :: raise !< Throw an error if dir does not exist (default: .false.)
207 :
208 : logical :: isdir
209 :
210 12 : isdir = path_isdir(path)
211 6 : if (.not. isdir) call path_msg("Directory does not exist: ", path, verbose, raise)
212 6 : if (present(answer)) answer = isdir
213 :
214 5 : end subroutine check_path_isdir
215 :
216 : ! ------------------------------------------------------------------
217 : !> \brief Return .true. if path refers to an existing path.
218 : !> \author Sebastian Mueller
219 : !> \date Mar 2023
220 6 : logical function path_exists(path)
221 : implicit none
222 : character(len=*), intent(in) :: path !< given path
223 :
224 6 : path_exists = path_isfile(path) .or. path_isdir(path)
225 :
226 6 : end function path_exists
227 :
228 : ! ------------------------------------------------------------------
229 : !> \brief Return .true. if path is an existing regular file.
230 : !> \author Sebastian Mueller
231 : !> \date Mar 2023
232 11 : logical function path_isfile(path)
233 : implicit none
234 : character(len=*), intent(in) :: path !< given path
235 :
236 11 : inquire(file=trim(path), exist=path_isfile)
237 : ! gfortran/NAG need the check if it is not a directory explicitly
238 11 : path_isfile = path_isfile .and. (.not. path_isdir(path))
239 :
240 6 : end function path_isfile
241 :
242 : ! ------------------------------------------------------------------
243 : !> \brief Return .true. if path is an existing directory.
244 : !> \author Sebastian Mueller
245 : !> \date Mar 2023
246 23 : logical function path_isdir(path)
247 : implicit none
248 : character(len=*), intent(in) :: path !< given path
249 :
250 : #ifdef INTEL
251 : ! intel has non-standard 'directory' argument
252 : inquire(directory=trim(path), exist=path_isdir)
253 : #else
254 : ! append "/" and check if it still exists
255 23 : inquire(file=trim(path)//sep, exist=path_isdir)
256 : #endif
257 :
258 11 : end function path_isdir
259 :
260 : ! ------------------------------------------------------------------
261 : !> \brief Return .true. if path is an absolute pathname.
262 : !> \author Sebastian Müller
263 : !> \date Mar 2023
264 112 : logical function path_isabs(path)
265 23 : use mo_string_utils, only : startswith
266 : implicit none
267 : character(len=*), intent(in) :: path !< given path
268 :
269 : ! absolute posix path starts with '/'
270 112 : path_isabs = startswith(path, sep)
271 :
272 112 : end function path_isabs
273 :
274 : ! ------------------------------------------------------------------
275 : !> \brief Return .true. if path is root ('/' or '//' or '///' and so on).
276 : !> \author Sebastian Müller
277 : !> \date Mar 2023
278 132 : logical function path_isroot(path)
279 112 : use mo_string_utils, only : startswith
280 : implicit none
281 : character(len=*), intent(in) :: path !< given path
282 :
283 : integer :: i
284 :
285 163 : do i=len_trim(path), 0, -1
286 163 : if (i == 0) exit ! only sep found or empty
287 163 : if (path(i:i) /= sep) exit
288 : end do
289 132 : path_isroot = (i == 0) .and. (len_trim(path) > 0)
290 :
291 132 : end function path_isroot
292 :
293 : ! ------------------------------------------------------------------
294 : !> \brief Splitting the path into root and ext
295 : !> \details Splitting the path name into a pair root and ext.
296 : !! Here, ext stands for extension and has the extension string
297 : !! of the specified path while root is everything except this extension.
298 : !> \changelog
299 : !! - Sebastian Müller Mar 2023
300 : !! - don't check for folder
301 : !! - ignore leading dots in tail of the path
302 : !! - make root and ext optional
303 : !> \author Nicola Doering
304 : !> \date Aug 2020
305 6 : subroutine path_splitext(path, root, ext)
306 :
307 132 : use mo_string_utils, only: endswith
308 : implicit none
309 :
310 : character(len=*), intent(in) :: path !< given path
311 : character(len=*), intent(out), optional :: root !< root part of path without extension
312 : character(len=*), intent(out), optional :: ext !< extension of given path (starting with ".")
313 :
314 : integer :: lead_i, dot_i, sep_i
315 6 : character(len=len_trim(path)) :: head, tail
316 :
317 : ! find last '/' and split there
318 6 : sep_i = index(trim(path), sep, back=.true.)
319 6 : head = path(1:sep_i)
320 6 : tail = path(sep_i+1:len_trim(path))
321 :
322 : ! ignore leading dots of the tail ("...a" has no extension)
323 7 : do lead_i = 1, len_trim(tail) + 1
324 7 : if ( lead_i > len_trim(tail) ) exit ! only dots
325 7 : if ( tail(lead_i:lead_i) /= extsep ) exit
326 : end do
327 :
328 : ! check for last dot in tail to split extension
329 6 : dot_i = index(trim(tail), extsep, back=.true.)
330 : ! last dot needs to come after leading dots to indicate an extension
331 6 : if ( dot_i > lead_i ) then
332 : ! dot_i is at least 2 here
333 4 : if (present(ext)) ext = tail(dot_i:len_trim(tail))
334 4 : if (present(root)) root = trim(head) // tail(1:dot_i-1)
335 : else
336 : ! no dot found at all or the leading dots are found
337 2 : if (present(ext)) ext = ""
338 2 : if (present(root)) root = trim(head) // trim(tail)
339 : end if
340 :
341 12 : end subroutine path_splitext
342 :
343 : ! ------------------------------------------------------------------
344 : !>\brief Splitting the path into head and tail
345 : !>\details Splitting the path name into a pair head and tail.
346 : !! Here, tail is the last path name component and head is
347 : !! everything leading up to that.
348 : !! If the path ends with an '/' tail is returned empty and
349 : !! if there is no '/' in path head is returned empty.
350 : !! Trailing '/'es are stripped from head unless it is the root.
351 : !> \changelog
352 : !! - Sebastian Müller Mar 2023
353 : !! - remove trailing '/' from head unleass it is root (e.g. '/' or '//' or '///' and so on)
354 : !! - make head and tail optional
355 : !>\author Nicola Doering
356 : !>\date Aug 2020
357 110 : subroutine path_split(path, head, tail)
358 :
359 : implicit none
360 :
361 : character(len=*), intent(in) :: path !< given path
362 : character(len=*), intent(out), optional :: head !< everything leading up to the last path component
363 : character(len=*), intent(out), optional :: tail !< last pathname component
364 :
365 : integer :: i
366 110 : character(len=len_trim(path)) :: head_
367 :
368 : ! find last '/'
369 110 : i = index(trim(path), sep, back=.true.)
370 :
371 110 : if (i == 0) then
372 : ! no '/' found
373 7 : if (present(tail)) tail = trim(path)
374 7 : if (present(head)) head = ''
375 : else
376 103 : if (present(tail)) tail = path((i+1):len_trim(path))
377 103 : if (.not. present(head)) return
378 99 : head_ = path(1:i)
379 : ! remove trailing '/' from head unless it is root
380 204 : do i=len_trim(head_), 0, -1
381 204 : if (i == 0) exit ! only sep found
382 204 : if (head_(i:i) /= sep) exit
383 : end do
384 99 : if (i == 0) i = len_trim(head_) ! all characters are '/'
385 99 : head = head_(1:i)
386 : endif
387 :
388 116 : end subroutine path_split
389 :
390 : ! ------------------------------------------------------------------
391 : !>\brief Splitting the path into its components.
392 : !>\author Sebastian Müller
393 : !>\date Mar 2023
394 15 : subroutine path_parts(path, parts)
395 110 : use mo_append, only : append
396 : implicit none
397 : character(len=*), intent(in) :: path !< given path
398 : character(len=len_trim(path)), allocatable, intent(out) :: parts(:) !< parts of the given path
399 :
400 : integer :: i
401 15 : character(len=len_trim(path)) :: temp, comp
402 :
403 : ! create array to join
404 15 : temp = trim(path)
405 15 : allocate(parts(0))
406 : ! stop if we can't further split the path
407 116 : do while (len_trim(temp) > 0)
408 109 : if (path_isroot(temp)) then
409 : ! POSIX allows one or two initial slashes, but treats three or more as single slash.
410 8 : if (len_trim(temp) == 2) then
411 1 : call append(parts, temp)
412 : else
413 7 : call append(parts, sep)
414 : end if
415 : exit
416 : end if
417 : ! get next component
418 101 : call path_split(temp, temp, comp)
419 101 : if (len_trim(comp) > 0) call append(parts, comp)
420 : end do
421 :
422 : ! reverse only if 2 or more elements
423 361 : if (size(parts) > 1) parts = [(parts(i), i = size(parts), 1, -1)]
424 :
425 15 : end subroutine path_parts
426 :
427 : ! ------------------------------------------------------------------
428 : !> \brief Return the directory name of pathname path.
429 : !> \details This is the first element of the pair returned by passing path to the subroutine path_split.
430 : !> \author Sebastian Müller
431 : !> \date Mar 2023
432 2 : function path_dirname(path) result(dirname)
433 : implicit none
434 : character(len=*), intent(in) :: path !< given path
435 : character(:), allocatable :: dirname !< dirname
436 :
437 2 : character(len=len_trim(path)) :: temp
438 :
439 2 : call path_split(path, head=temp)
440 2 : dirname = trim(temp)
441 :
442 15 : end function path_dirname
443 :
444 : ! ------------------------------------------------------------------
445 : !> \brief Return the base name of pathname path.
446 : !> \details This is the second element of the pair returned by passing path to the subroutine path_split.
447 : !> \author Sebastian Müller
448 : !> \date Mar 2023
449 2 : function path_basename(path) result(basename)
450 : implicit none
451 : character(len=*), intent(in) :: path !< given path
452 : character(:), allocatable :: basename !< basename
453 :
454 2 : character(len=len_trim(path)) :: temp
455 :
456 2 : call path_split(path, tail=temp)
457 2 : basename = trim(temp)
458 :
459 2 : end function path_basename
460 :
461 : ! ------------------------------------------------------------------
462 : !> \brief Return the path without its suffix.
463 : !> \author Sebastian Müller
464 : !> \date Mar 2023
465 1 : function path_root(path) result(root)
466 : implicit none
467 : character(len=*), intent(in) :: path !< given path
468 : character(:), allocatable :: root !< root
469 :
470 1 : character(len=len_trim(path)) :: temp
471 :
472 1 : call path_splitext(path, root=temp)
473 1 : root = trim(temp)
474 :
475 2 : end function path_root
476 :
477 : ! ------------------------------------------------------------------
478 : !> \brief Return the file extension of the final path component.
479 : !> \author Sebastian Müller
480 : !> \date Mar 2023
481 1 : function path_ext(path) result(ext)
482 : implicit none
483 : character(len=*), intent(in) :: path !< given path
484 : character(:), allocatable :: ext !< ext
485 :
486 1 : character(len=len_trim(path)) :: temp
487 :
488 1 : call path_splitext(path, ext=temp)
489 1 : ext = trim(temp)
490 :
491 1 : end function path_ext
492 :
493 : ! ------------------------------------------------------------------
494 : !> \brief Return the final path component without its suffix.
495 : !> \author Sebastian Müller
496 : !> \date Mar 2023
497 1 : function path_stem(path) result(stem)
498 : implicit none
499 : character(len=*), intent(in) :: path !< given path
500 : character(:), allocatable :: stem !< stem
501 :
502 1 : character(len=len_trim(path)) :: temp, tail
503 :
504 1 : call path_split(path, tail=tail)
505 1 : call path_splitext(tail, root=temp)
506 1 : stem = trim(temp)
507 :
508 1 : end function path_stem
509 :
510 : ! ------------------------------------------------------------------
511 : !> \brief Return the string representation of the path with forward (/) slashes.
512 : !> \author Sebastian Müller
513 : !> \date Mar 2023
514 1 : function path_as_posix(path) result(posix)
515 1 : use mo_string_utils, only : replace_text
516 : implicit none
517 : character(len=*), intent(in) :: path !< given path
518 : character(:), allocatable :: posix !< posix version of the path
519 :
520 1 : posix = trim(replace_text(path, "\\", sep))
521 :
522 1 : end function path_as_posix
523 :
524 : ! ------------------------------------------------------------------
525 : !> \brief Normalize a pathname by collapsing redundant separators and up-level references.
526 : !> \details Normalize a pathname by collapsing redundant separators and up-level references so that
527 : !! A//B, A/B/, A/./B and A/foo/../B all become A/B.
528 : !! This string manipulation may change the meaning of a path that contains symbolic links.
529 : !> \author Sebastian Müller
530 : !> \date Mar 2023
531 15 : function path_normpath(path) result(normpath)
532 1 : use mo_append, only : append
533 : implicit none
534 : character(len=*), intent(in) :: path !< given path
535 : character(:), allocatable :: normpath !< normalized path
536 :
537 15 : character(len=len_trim(path)) :: temp, comp, root
538 15 : character(len=len_trim(path)), allocatable :: comps_raw(:), comps(:)
539 : integer :: i
540 : logical :: has_root ! flag to indicate an absolute path
541 :
542 : ! get path components
543 : call path_parts(path, comps_raw)
544 : ! return '.' for empty path
545 15 : if (size(comps_raw) == 0) then
546 1 : normpath = curdir
547 2 : return
548 : end if
549 :
550 14 : has_root = path_isroot(comps_raw(1))
551 :
552 14 : allocate(comps(0))
553 : ! care about '.' and '..'
554 120 : do i = 1, size(comps_raw)
555 106 : comp = comps_raw(i)
556 106 : if ( len_trim(comp) == 0 ) cycle ! skip empty
557 106 : if ( trim(comp) == curdir ) cycle ! skip '.'
558 : ! handle '..'
559 116 : if ( trim(comp) /= pardir ) then
560 : ! append normal component
561 91 : call append(comps, comp)
562 11 : else if (.not. has_root .and. (size(comps) == 0)) then
563 : ! if '..' but we can't pop anything, append
564 1 : call append(comps, comp)
565 10 : else if ( size(comps) > 0 ) then
566 10 : if (comps(size(comps)) == pardir) then
567 : ! if '..' but previous is also '..', append
568 1 : call append(comps, comp)
569 9 : else if (.not. path_isroot(comps(size(comps)))) then
570 : ! if '..' pop previous folder if it is not root
571 5 : call pop(comps)
572 : end if
573 : end if
574 : ! in all other cases, don't append anything
575 : end do
576 :
577 14 : if (size(comps) > 0) then
578 13 : normpath = path_join_arr(comps)
579 : else
580 : ! '.' if no components given
581 1 : normpath = curdir
582 : end if
583 :
584 17 : end function path_normpath
585 :
586 : ! ------------------------------------------------------------------
587 : !> \brief Return a normalized absolutized version of the given path.
588 : !> \author Sebastian Müller
589 : !> \date Mar 2023
590 6 : function path_abspath(path) result(abspath)
591 : implicit none
592 : character(len=*), intent(in) :: path !< given path
593 : character(:), allocatable :: abspath !< stem
594 :
595 6 : character(len=max_path_len) :: cwd
596 :
597 6 : call get_cwd(cwd)
598 6 : abspath = path_normpath(path_join_char(cwd, path))
599 :
600 15 : end function path_abspath
601 :
602 : ! ------------------------------------------------------------------
603 : !> \brief Join two path segments with separator if needed.
604 : !> \details If the second segment is an absolute path, the first one will be ignored.
605 : !> \author Sebastian Müller
606 : !> \date Mar 2023
607 109 : function path_join_char(p1, p2) result(join)
608 6 : use mo_string_utils, only : endswith
609 : implicit none
610 : character(len=*), intent(in) :: p1, p2 ! given paths
611 : character(:), allocatable :: join !< joined paths
612 :
613 109 : if (path_isabs(p2)) then
614 : ! if second path is absolute, first path gets ignored
615 14 : join = trim(p2)
616 : else
617 : ! check if sep should be added (p1 not empty and not ending with sep)
618 95 : if ( (len_trim(p1) > 0) .and. .not. endswith(p1, sep) ) then
619 82 : join = trim(p1) // sep // trim(p2)
620 : else
621 13 : join = trim(p1) // trim(p2)
622 : end if
623 : end if
624 :
625 109 : end function path_join_char
626 :
627 : ! ------------------------------------------------------------------
628 : !> \brief Join given path segments with separator if needed.
629 : !> \details If a segment is an absolute path, the previous ones will be ignored.
630 : !> \author Sebastian Müller
631 : !> \date Mar 2023
632 4 : function path_join_char_opt(p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16) result(join)
633 109 : use mo_string_utils, only : endswith
634 : implicit none
635 : character(len=*), intent(in) :: p1 !< initial path
636 : character(len=*), intent(in), optional :: p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16 ! given paths
637 : character(:), allocatable :: join !< joined paths
638 :
639 4 : join = p1
640 4 : if (present(p2)) join = path_join_char(join, p2)
641 4 : if (present(p3)) join = path_join_char(join, p3)
642 4 : if (present(p4)) join = path_join_char(join, p4)
643 4 : if (present(p5)) join = path_join_char(join, p5)
644 4 : if (present(p6)) join = path_join_char(join, p6)
645 4 : if (present(p7)) join = path_join_char(join, p7)
646 4 : if (present(p8)) join = path_join_char(join, p8)
647 4 : if (present(p9)) join = path_join_char(join, p9)
648 4 : if (present(p10)) join = path_join_char(join, p10)
649 4 : if (present(p11)) join = path_join_char(join, p11)
650 4 : if (present(p12)) join = path_join_char(join, p12)
651 4 : if (present(p13)) join = path_join_char(join, p13)
652 4 : if (present(p14)) join = path_join_char(join, p14)
653 4 : if (present(p15)) join = path_join_char(join, p15)
654 4 : if (present(p16)) join = path_join_char(join, p16)
655 :
656 8 : end function path_join_char_opt
657 :
658 : ! ------------------------------------------------------------------
659 : !> \brief Join given path segments with separator if needed.
660 : !> \details If a segment is an absolute path, the previous ones will be ignored.
661 : !> \author Sebastian Müller
662 : !> \date Mar 2023
663 16 : function path_join_arr(paths) result(join)
664 : implicit none
665 : character(len=*), dimension(:), intent(in) :: paths !< given paths
666 : character(:), allocatable :: join !< joined paths
667 :
668 : integer(i4) :: i
669 :
670 16 : join = ""
671 113 : do i = 1, size(paths)
672 113 : join = path_join_char(join, paths(i))
673 : end do
674 4 : end function path_join_arr
675 :
676 : ! ------------------------------------------------------------------
677 :
678 10 : subroutine path_msg(msg, path, verbose, raise)
679 16 : use mo_message, only: error_message, message
680 : implicit none
681 : character(len=*), intent(in), optional :: msg
682 : character(len=*), intent(in), optional :: path
683 : logical, intent(in), optional :: verbose
684 : logical, intent(in), optional :: raise
685 :
686 : logical :: raise_
687 :
688 10 : raise_ = .false.
689 10 : if (present(raise)) raise_ = raise
690 : if (raise_) then ! LCOV_EXCL_LINE
691 : call error_message(msg, trim(path), show=verbose) ! LCOV_EXCL_LINE
692 : else
693 10 : call message(msg, trim(path), show=verbose)
694 : endif
695 :
696 10 : end subroutine path_msg
697 :
698 : !> \brief character array pop
699 5 : subroutine pop(arr)
700 : ! TODO: move to mo_utils; add other type versions
701 : implicit none
702 : character(len=*), allocatable, intent(inout) :: arr(:)
703 :
704 5 : character(:), allocatable :: temp(:)
705 :
706 5 : if (.not.allocated(arr)) return
707 5 : if (size(arr) == 0) return
708 :
709 14 : allocate(character(len(arr(1))) :: temp(size(arr)-1))
710 43 : temp(:) = arr(1:size(arr)-1)
711 5 : call move_alloc(temp, arr)
712 :
713 20 : end subroutine pop
714 :
715 : end module mo_os
|
