(git:9ccafda)
Loading...
Searching...
No Matches
cp_files.F
Go to the documentation of this file.
1!--------------------------------------------------------------------------------------------------!
2! CP2K: A general program to perform molecular dynamics simulations !
3! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
8! **************************************************************************************************
9!> \brief Utility routines to open and close files.
10!> \par History
11!> - Creation CP2K_WORKSHOP 1.0 TEAM
12!> - Revised (18.02.2011, MK)
13!> - Enhanced error checking (22.02.2011, MK)
14!> - Preconnected units removed (03.10.2026, MK)
15!> \note Positive unit numbers are used instead of OPEN(NEWUNIT=...), because NEWUNIT returns
16!> negative numbers and CP2K treats a unit number > 0 as "output enabled".
17!> open_file is thread-safe: finding a free unit and connecting the file are done within
18!> the OpenMP critical region cp_files_connect. Concurrent use of the same unit (I/O,
19!> REWIND, close_file) must be avoided by the caller.
20!> \author Matthias Krack (MK)
21! **************************************************************************************************
22MODULE cp_files
23 USE iso_c_binding, ONLY: c_char,&
24 c_f_pointer,&
25 c_null_char,&
26 c_ptr
27 USE kinds, ONLY: default_path_length
28 USE machine, ONLY: default_error_unit,&
29 default_input_unit,&
30 default_output_unit,&
31 m_getcwd
32 USE string_utilities, ONLY: uppercase
33#include "../base/base_uses.f90"
34
35 IMPLICIT NONE
36
37 PRIVATE
38
39 PUBLIC :: close_file, &
40 open_file, &
41 file_exists, &
42 get_data_dir, &
43 discover_file, &
44 join_paths
45
46 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_files'
47
48 ! Upper bound for the search of a free logical unit number
49 INTEGER, PARAMETER :: max_unit_number = 1024
50
51CONTAINS
52
53! **************************************************************************************************
54!> \brief Closes an open file given by its logical unit number.
55!> \param unit_number Logical unit number of the file to be closed
56!> \param file_status File status after closing: KEEP or DELETE (default: KEEP for named,
57!> DELETE for unnamed SCRATCH files)
58!> \author Matthias Krack (MK)
59!> \note The program is aborted, if the unit is one of the default units (stdin, stdout,
60!> stderr). A unit which is not open is ignored silently.
61! **************************************************************************************************
62 SUBROUTINE close_file(unit_number, file_status)
63
64 INTEGER, INTENT(IN) :: unit_number
65 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_status
66
67 CHARACTER(LEN=11) :: status_string
68 CHARACTER(LEN=2*default_path_length) :: message
69 CHARACTER(LEN=default_path_length) :: iomsg_string
70 INTEGER :: istat
71 LOGICAL :: exists, is_named, is_open
72
73 INQUIRE (unit=unit_number, exist=exists, named=is_named, opened=is_open, iostat=istat)
74
75 IF (istat /= 0) THEN
76 WRITE (unit=message, fmt="(A,I0,A,I0,A)") &
77 "An error occurred inquiring the unit with the number ", unit_number, &
78 " (IOSTAT = ", istat, ")"
79 CALL cp_abort(__location__, trim(message))
80 ELSE IF (.NOT. exists) THEN
81 WRITE (unit=message, fmt="(A,I0,A)") &
82 "The specified unit number ", unit_number, &
83 " cannot be closed, because it does not exist."
84 CALL cp_abort(__location__, trim(message))
85 END IF
86
87 ! Close the specified file
88
89 IF (is_open) THEN
90
91 ! Refuse to close any default unit
92 SELECT CASE (unit_number)
93 CASE (default_error_unit)
94 WRITE (unit=message, fmt="(A,I0)") &
95 "Attempt to close the default error unit number ", unit_number
96 CALL cp_abort(__location__, trim(message))
97 CASE (default_input_unit)
98 WRITE (unit=message, fmt="(A,I0)") &
99 "Attempt to close the default input unit number ", unit_number
100 CALL cp_abort(__location__, trim(message))
101 CASE (default_output_unit)
102 WRITE (unit=message, fmt="(A,I0)") &
103 "Attempt to close the default output unit number ", unit_number
104 CALL cp_abort(__location__, trim(message))
105 END SELECT
106
107 ! Define status after closing the file (KEEP for named, DELETE for unnamed SCRATCH files)
108 IF (PRESENT(file_status)) THEN
109 IF (len_trim(adjustl(file_status)) > len(status_string)) THEN
110 CALL cp_abort(__location__, &
111 "An invalid file STATUS="//trim(adjustl(file_status))// &
112 " was specified.")
113 END IF
114 status_string = trim(adjustl(file_status))
115 CALL uppercase(status_string)
116 ELSE IF (.NOT. is_named) THEN
117 status_string = "DELETE"
118 ELSE
119 status_string = "KEEP"
120 END IF
121
122 SELECT CASE (status_string)
123 CASE ("DELETE", "KEEP")
124 CLOSE (unit=unit_number, iostat=istat, iomsg=iomsg_string, status=trim(status_string))
125 IF (istat /= 0) THEN
126 CALL cp_abort(__location__, &
127 "An error occurred closing the file with the logical unit number "// &
128 trim(int_to_string(unit_number))//" (IOSTAT="// &
129 trim(int_to_string(istat))//"): "//trim(iomsg_string))
130 END IF
131 CASE DEFAULT
132 CALL cp_abort(__location__, &
133 "An invalid file STATUS="//trim(status_string)//" was specified.")
134 END SELECT
135
136 END IF
137
138 ! A unit which is not open is ignored silently. close_file is called by cp_logger_release,
139 ! e.g. for a unit shared by several loggers and already closed by one of them. No warning can
140 ! be issued at that point, since the logger being released might still be the default logger.
141
142 END SUBROUTINE close_file
143
144! **************************************************************************************************
145!> \brief Returns the first free positive logical unit number.
146!> \return First free unit in 1..max_unit_number (excluding the default units), or -1 if none
147!> is free
148!> \author Matthias Krack (MK)
149!> \note Must be called within the critical region cp_files_connect together with the OPEN
150!> statement, so that no other thread can obtain the same unit number in between.
151! **************************************************************************************************
152 FUNCTION get_unit_number() RESULT(unit_number)
153
154 INTEGER :: unit_number
155
156 INTEGER :: istat
157 LOGICAL :: exists, is_open
158
159 DO unit_number = 1, max_unit_number
160 SELECT CASE (unit_number)
161 CASE (default_error_unit, default_input_unit, default_output_unit)
162 cycle
163 CASE DEFAULT
164 INQUIRE (unit=unit_number, exist=exists, opened=is_open, iostat=istat)
165 IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) RETURN
166 END SELECT
167 END DO
168
169 unit_number = -1
170
171 END FUNCTION get_unit_number
172
173! **************************************************************************************************
174!> \brief Opens a file and returns its logical unit number.
175!> \param file_name File name; must be omitted for an anonymous SCRATCH file
176!> \param unit_number Logical unit number of the opened file
177!> \param file_status Fortran file status OLD, NEW, REPLACE, UNKNOWN, or SCRATCH for an
178!> anonymous temporary file (default: OLD)
179!> \param file_form FORMATTED or UNFORMATTED (default: FORMATTED)
180!> \param file_action READ, WRITE, or READWRITE (default: WRITE for STATUS=NEW, REPLACE, and
181!> SCRATCH, otherwise READ)
182!> \param file_position ASIS, REWIND, or APPEND (default: REWIND)
183!> \param file_pad YES or NO (default: YES); only allowed for FORMATTED files
184!> \param file_access SEQUENTIAL or STREAM (default: SEQUENTIAL); DIRECT is not supported
185!> \param debug Print the connection properties to the default output unit
186!> \author Matthias Krack (MK)
187!> \note - If the file is already open, its unit number is returned and no new connection is
188!> made. ACTION, FORM, and ACCESS must match the existing connection; with
189!> POSITION=REWIND the file is rewound.
190!> - For STATUS=OLD and ACTION=READ, the file is also looked up in the data directory
191!> (see discover_file). Files opened for writing are never taken from there.
192!> - Any error aborts the program; there is no IOSTAT return.
193! **************************************************************************************************
194 SUBROUTINE open_file(file_name, unit_number, file_status, file_form, file_action, &
195 file_position, file_pad, file_access, debug)
196
197 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_name
198 INTEGER, INTENT(OUT) :: unit_number
199 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_status, file_form, file_action, &
200 file_position, file_pad, file_access
201 LOGICAL, INTENT(IN), OPTIONAL :: debug
202
203 CHARACTER(LEN=*), PARAMETER :: routinen = 'open_file'
204
205 CHARACTER(LEN=11) :: access_string, action_string, current_access, current_action, &
206 current_form, form_string, pad_string, position_string, status_string
207 CHARACTER(LEN=2*default_path_length) :: message
208 CHARACTER(LEN=default_path_length) :: cwd, iomsg_string, real_file_name
209 INTEGER :: inquire_stat, open_stat
210 LOGICAL :: connect, exists, is_named, is_open
211
212 real_file_name = ""
213 unit_number = -1
214
215 IF (PRESENT(file_access)) THEN
216 access_string = trim(adjustl(file_access))
217 CALL uppercase(access_string)
218 IF (access_string == "DIRECT") THEN
219 CALL cp_abort(__location__, &
220 "ACCESS=DIRECT is not supported.")
221 END IF
222 ELSE
223 access_string = "SEQUENTIAL"
224 END IF
225
226 IF (PRESENT(file_status)) THEN
227 status_string = trim(adjustl(file_status))
228 CALL uppercase(status_string)
229 ELSE
230 status_string = "OLD"
231 END IF
232
233 IF (PRESENT(file_form)) THEN
234 form_string = trim(adjustl(file_form))
235 CALL uppercase(form_string)
236 ELSE
237 form_string = "FORMATTED"
238 END IF
239
240 IF (PRESENT(file_pad)) THEN
241 pad_string = trim(adjustl(file_pad))
242 CALL uppercase(pad_string)
243 IF (form_string == "UNFORMATTED") THEN
244 CALL cp_abort(__location__, &
245 "The PAD specifier is not allowed for an UNFORMATTED file.")
246 END IF
247 ELSE
248 pad_string = "YES"
249 END IF
250
251 IF (PRESENT(file_action)) THEN
252 action_string = trim(adjustl(file_action))
253 CALL uppercase(action_string)
254 ELSE
255 ! A new or emptied file cannot be read, thus WRITE is the only sensible default
256 SELECT CASE (status_string)
257 CASE ("NEW", "REPLACE", "SCRATCH")
258 action_string = "WRITE"
259 CASE DEFAULT
260 action_string = "READ"
261 END SELECT
262 END IF
263
264 IF (PRESENT(file_position)) THEN
265 position_string = trim(adjustl(file_position))
266 CALL uppercase(position_string)
267 ELSE
268 position_string = "REWIND"
269 END IF
270
271 IF (PRESENT(file_name)) THEN
272 IF (len_trim(file_name) == 0) THEN
273 CALL cp_abort(__location__, &
274 "The specified FILE name is empty.")
275 END IF
276 IF (len_trim(file_name) > len(real_file_name)) THEN
277 CALL cp_abort(__location__, &
278 "The FILE name <"//trim(file_name)//"> exceeds the maximum length of "// &
279 trim(int_to_string(len(real_file_name)))//" characters.")
280 END IF
281 IF (file_name(1:1) == " ") THEN
282 CALL cp_abort(__location__, &
283 "The FILE name <"//trim(file_name)//"> has leading blanks.")
284 END IF
285 IF (status_string == "SCRATCH") THEN
286 CALL cp_abort(__location__, &
287 "A FILE name specifier is not allowed for SCRATCH files.")
288 END IF
289 ! Resolve the file name. The data directory is only searched for existing files
290 ! opened read-only, so that installed data files are never modified.
291 IF ((status_string == "OLD") .AND. (action_string == "READ")) THEN
292 real_file_name = discover_file(file_name)
293 ELSE
294 real_file_name = trim(adjustl(file_name))
295 END IF
296 END IF
297
298 SELECT CASE (status_string)
299 CASE ("SCRATCH")
300 ! No file name required
301 CASE ("NEW", "OLD", "REPLACE", "UNKNOWN")
302 IF (len_trim(real_file_name) == 0) THEN
303 CALL cp_abort(__location__, &
304 "A FILE name length of zero for a file with STATUS="// &
305 trim(status_string)//" is not allowed.")
306 END IF
307 CASE DEFAULT
308 CALL cp_abort(__location__, "A file STATUS="//trim(status_string)//" is not supported.")
309 END SELECT
310
311 ! Inquire the file, find a free unit, and connect the file atomically with respect to other
312 ! threads. All checks and error messages follow outside the critical region, because
313 ! cp_abort and cp_warn may call open_file again via the logger, which would deadlock.
314 connect = .false.
315 exists = .false.
316 is_open = .false.
317 inquire_stat = 0
318 open_stat = 0
319 iomsg_string = ""
320!$OMP CRITICAL(cp_files_connect)
321 IF (status_string == "SCRATCH") THEN
322 connect = .true.
323 ELSE
324 INQUIRE (file=trim(real_file_name), exist=exists, opened=is_open, iostat=inquire_stat)
325 IF (inquire_stat == 0) THEN
326 IF (is_open) THEN
327 INQUIRE (file=trim(real_file_name), number=unit_number, &
328 action=current_action, form=current_form, access=current_access)
329 ELSE
330 SELECT CASE (status_string)
331 CASE ("NEW")
332 connect = (.NOT. exists)
333 CASE ("OLD")
334 connect = exists
335 CASE DEFAULT
336 connect = .true.
337 END SELECT
338 END IF
339 END IF
340 END IF
341 IF (connect) THEN
342 unit_number = get_unit_number()
343 IF (unit_number > 0) THEN
344 IF (status_string == "SCRATCH") THEN
345 IF (form_string == "FORMATTED") THEN
346 OPEN (unit=unit_number, &
347 status=trim(status_string), &
348 access=trim(access_string), &
349 form=trim(form_string), &
350 position=trim(position_string), &
351 action=trim(action_string), &
352 pad=trim(pad_string), &
353 iomsg=iomsg_string, &
354 iostat=open_stat)
355 ELSE
356 OPEN (unit=unit_number, &
357 status=trim(status_string), &
358 access=trim(access_string), &
359 form=trim(form_string), &
360 position=trim(position_string), &
361 action=trim(action_string), &
362 iomsg=iomsg_string, &
363 iostat=open_stat)
364 END IF
365 ELSE
366 IF (form_string == "FORMATTED") THEN
367 OPEN (unit=unit_number, &
368 file=trim(real_file_name), &
369 status=trim(status_string), &
370 access=trim(access_string), &
371 form=trim(form_string), &
372 position=trim(position_string), &
373 action=trim(action_string), &
374 pad=trim(pad_string), &
375 iomsg=iomsg_string, &
376 iostat=open_stat)
377 ELSE
378 OPEN (unit=unit_number, &
379 file=trim(real_file_name), &
380 status=trim(status_string), &
381 access=trim(access_string), &
382 form=trim(form_string), &
383 position=trim(position_string), &
384 action=trim(action_string), &
385 iomsg=iomsg_string, &
386 iostat=open_stat)
387 END IF
388 END IF
389 END IF
390 END IF
391!$OMP END CRITICAL(cp_files_connect)
392
393 IF (inquire_stat /= 0) THEN
394 CALL cp_abort(__location__, &
395 "An error occurred inquiring the file <"//trim(real_file_name)// &
396 "> (IOSTAT="//trim(int_to_string(inquire_stat))//").")
397 END IF
398
399 IF (is_open) THEN
400 ! The file is already connected: check the connection and reuse it
401 CALL uppercase(current_action)
402 IF (trim(current_action) /= trim(action_string)) THEN
403 CALL cp_abort(__location__, &
404 "Attempt to re-open the existing file <"// &
405 trim(real_file_name)//"> with the modified ACTION attribute "// &
406 trim(action_string)//". The current ACTION attribute is "// &
407 trim(current_action)//".")
408 END IF
409 CALL uppercase(current_form)
410 IF (trim(current_form) /= trim(form_string)) THEN
411 CALL cp_abort(__location__, &
412 "Attempt to re-open the existing "// &
413 trim(current_form)//" file <"//trim(real_file_name)// &
414 "> as "//trim(form_string)//" file.")
415 END IF
416 CALL uppercase(current_access)
417 IF (trim(current_access) /= trim(access_string)) THEN
418 CALL cp_abort(__location__, &
419 "Attempt to re-open the existing "// &
420 trim(current_access)//" file <"//trim(real_file_name)// &
421 "> with ACCESS="//trim(access_string)//".")
422 END IF
423 IF (status_string == "NEW") THEN
424 CALL cp_abort(__location__, &
425 "Attempt to re-open the existing file <"// &
426 trim(real_file_name)//"> with STATUS=NEW.")
427 END IF
428 IF (position_string == "REWIND") rewind(unit=unit_number)
429 ELSE
430 ! Check the outcome of the connection attempt
431 SELECT CASE (status_string)
432 CASE ("NEW")
433 IF (exists) THEN
434 CALL cp_abort(__location__, &
435 "The file <"//trim(real_file_name)// &
436 "> cannot be opened with STATUS=NEW, because it already exists.")
437 END IF
438 CASE ("OLD")
439 IF (.NOT. exists) THEN
440 IF (action_string == "READ") THEN
441 CALL cp_abort(__location__, &
442 "The specified file <"//trim(real_file_name)// &
443 "> cannot be opened with STATUS=OLD. It does not exist. "// &
444 "Data directory path: "//trim(get_data_dir()))
445 ELSE
446 CALL cp_abort(__location__, &
447 "The specified file <"//trim(real_file_name)// &
448 "> cannot be opened with STATUS=OLD and ACTION="// &
449 trim(action_string)//". It does not exist.")
450 END IF
451 END IF
452 END SELECT
453 IF (unit_number < 1) THEN
454 IF (status_string == "SCRATCH") THEN
455 CALL cp_abort(__location__, &
456 "Could not obtain a unit number to open a SCRATCH file.")
457 ELSE
458 CALL cp_abort(__location__, &
459 "Cannot open the file <"//trim(real_file_name)// &
460 ">, because no unused logical unit number could be obtained.")
461 END IF
462 END IF
463 IF (open_stat /= 0) THEN
464 IF (status_string == "SCRATCH") THEN
465 CALL cp_abort(__location__, &
466 "An error occurred opening a SCRATCH file (UNIT="// &
467 trim(int_to_string(unit_number))//", IOSTAT="// &
468 trim(int_to_string(open_stat))//"): "//trim(iomsg_string))
469 ELSE
470 CALL m_getcwd(cwd)
471 CALL cp_abort(__location__, &
472 "An error occurred opening the file <"//trim(real_file_name)// &
473 "> (UNIT="//trim(int_to_string(unit_number))// &
474 ", IOSTAT="//trim(int_to_string(open_stat))//"): "// &
475 trim(iomsg_string)//". Current working directory: "//trim(cwd))
476 END IF
477 END IF
478 END IF
479
480 IF (PRESENT(debug)) THEN
481 IF (debug) THEN
482 INQUIRE (unit=unit_number, &
483 opened=is_open, &
484 named=is_named, &
485 position=position_string, &
486 access=access_string, &
487 form=form_string, &
488 action=action_string)
489 ! The NAME specifier is undefined for unnamed (SCRATCH) files
490 IF (is_named) THEN
491 INQUIRE (unit=unit_number, name=message)
492 ELSE
493 message = "<unnamed>"
494 END IF
495 WRITE (unit=default_output_unit, fmt="(T2,A)") "BEGIN DEBUG "//trim(routinen)
496 WRITE (unit=default_output_unit, fmt="(T3,A,I0)") "NUMBER : ", unit_number
497 WRITE (unit=default_output_unit, fmt="(T3,A,L1)") "OPENED : ", is_open
498 WRITE (unit=default_output_unit, fmt="(T3,A)") &
499 "NAME : "//trim(message), &
500 "POSITION: "//trim(position_string), &
501 "ACCESS : "//trim(access_string), &
502 "FORM : "//trim(form_string), &
503 "ACTION : "//trim(action_string), &
504 "END DEBUG "//trim(routinen)
505 END IF
506 END IF
507
508 END SUBROUTINE open_file
509
510! **************************************************************************************************
511!> \brief Checks if a file exists, considering also the file discovery mechanism.
512!> \param file_name Name of the file
513!> \return True, if the file exists in the current or the data directory
514!> \author Ole Schuett
515! **************************************************************************************************
516 FUNCTION file_exists(file_name) RESULT(exist)
517 CHARACTER(LEN=*), INTENT(IN) :: file_name
518 LOGICAL :: exist
519
520 CHARACTER(LEN=default_path_length) :: real_file_name
521 INTEGER :: istat
522
523 real_file_name = discover_file(file_name)
524 INQUIRE (file=trim(real_file_name), exist=exist, iostat=istat)
525 IF (istat /= 0) exist = .false.
526
527 END FUNCTION file_exists
528
529! **************************************************************************************************
530!> \brief Searches for a file in the current directory and then in the data directory.
531!> \param file_name Name of the file
532!> \return File name as given, if it exists, otherwise its path in the data directory, if
533!> it exists there, else the file name stripped of blanks
534!> \author Ole Schuett
535! **************************************************************************************************
536 FUNCTION discover_file(file_name) RESULT(real_file_name)
537 CHARACTER(LEN=*), INTENT(IN) :: file_name
538 CHARACTER(LEN=default_path_length) :: real_file_name
539
540 CHARACTER(LEN=default_path_length) :: candidate, data_dir
541 INTEGER :: stat
542 LOGICAL :: exists
543
544 ! Strip leading and trailing blanks from file name
545 real_file_name = trim(adjustl(file_name))
546
547 IF (len_trim(real_file_name) == 0) THEN
548 CALL cp_abort(__location__, "A file name length of zero for an existing file is invalid.")
549 END IF
550
551 ! First try file name directly
552 INQUIRE (file=trim(real_file_name), exist=exists, iostat=stat)
553 IF (stat == 0 .AND. exists) RETURN
554
555 ! Then try the data directory
556 data_dir = get_data_dir()
557 IF (len_trim(data_dir) > 0) THEN
558 candidate = join_paths(data_dir, real_file_name)
559 INQUIRE (file=trim(candidate), exist=exists, iostat=stat)
560 IF (stat == 0 .AND. exists) THEN
561 real_file_name = candidate
562 RETURN
563 END IF
564 END IF
565
566 END FUNCTION discover_file
567
568! **************************************************************************************************
569!> \brief Returns path of data directory if set, otherwise an empty string
570!> \return Path of the data directory or an empty string
571!> \author Ole Schuett
572! **************************************************************************************************
573 FUNCTION get_data_dir() RESULT(res)
574 CHARACTER(len=default_path_length) :: res
575
576 CHARACTER(LEN=1, KIND=C_CHAR), DIMENSION(:), &
577 POINTER :: path_f
578 INTEGER :: i
579 TYPE(c_ptr) :: path_c
580 INTERFACE
581 FUNCTION get_data_dir_c() BIND(C, name="get_data_dir")
582 IMPORT :: c_ptr
583 TYPE(c_ptr) :: get_data_dir_c
584 END FUNCTION get_data_dir_c
585 END INTERFACE
586
587 path_c = get_data_dir_c()
588 CALL c_f_pointer(path_c, path_f, shape=[default_path_length])
589
590 res = ""
591 DO i = 1, default_path_length
592 IF (path_f(i) == c_null_char) RETURN
593 res(i:i) = path_f(i)
594 END DO
595
596 CALL cp_abort(__location__, "The CP2K_DATA_DIR path is too long")
597
598 END FUNCTION get_data_dir
599
600! **************************************************************************************************
601!> \brief Joins two file paths, inserting '/' as needed.
602!> \param path1 Leading path, e.g. a directory
603!> \param path2 Trailing path; returned unchanged if it is an absolute path
604!> \return Joined path; the program is aborted, if it exceeds default_path_length
605!> \author Ole Schuett
606! **************************************************************************************************
607 FUNCTION join_paths(path1, path2) RESULT(joined_path)
608 CHARACTER(LEN=*), INTENT(IN) :: path1, path2
609 CHARACTER(LEN=default_path_length) :: joined_path
610
611 INTEGER :: joined_length, n1, n2
612 LOGICAL :: absolute
613
614 n1 = len_trim(path1)
615 n2 = len_trim(path2)
616
617 absolute = .false.
618 IF (n2 > 0) absolute = (path2(1:1) == '/')
619
620 ! Determine the length of the joined path before assigning it to avoid silent truncation
621 IF (absolute .OR. (n1 == 0)) THEN
622 joined_length = n2
623 ELSE IF (path1(n1:n1) == '/') THEN
624 joined_length = n1 + n2
625 ELSE
626 joined_length = n1 + 1 + n2
627 END IF
628 IF (joined_length > len(joined_path)) THEN
629 CALL cp_abort(__location__, &
630 "The joined path of <"//path1(1:n1)//"> and <"//path2(1:n2)// &
631 "> exceeds the maximum length of "// &
632 trim(int_to_string(len(joined_path)))//" characters.")
633 END IF
634
635 IF (absolute .OR. (n1 == 0)) THEN
636 joined_path = path2(1:n2)
637 ELSE IF (path1(n1:n1) == '/') THEN
638 joined_path = path1(1:n1)//path2(1:n2)
639 ELSE
640 joined_path = path1(1:n1)//'/'//path2(1:n2)
641 END IF
642
643 END FUNCTION join_paths
644
645! **************************************************************************************************
646!> \brief Converts an integer to a left-adjusted string.
647!> \param i Integer value
648!> \return String representation of i
649!> \author Matthias Krack (MK)
650! **************************************************************************************************
651 FUNCTION int_to_string(i) RESULT(string)
652 INTEGER, INTENT(IN) :: i
653 CHARACTER(LEN=11) :: string
654
655 WRITE (unit=string, fmt="(I0)") i
656
657 END FUNCTION int_to_string
658
659END MODULE cp_files
cp_files
Utility routines to open and close files.
Definition cp_files.F:22
cp_files::discover_file
character(len=default_path_length) function, public discover_file(file_name)
Searches for a file in the current directory and then in the data directory.
Definition cp_files.F:537
cp_files::file_exists
logical function, public file_exists(file_name)
Checks if a file exists, considering also the file discovery mechanism.
Definition cp_files.F:517
cp_files::open_file
subroutine, public open_file(file_name, unit_number, file_status, file_form, file_action, file_position, file_pad, file_access, debug)
Opens a file and returns its logical unit number.
Definition cp_files.F:196
cp_files::join_paths
character(len=default_path_length) function, public join_paths(path1, path2)
Joins two file paths, inserting '/' as needed.
Definition cp_files.F:608
cp_files::close_file
subroutine, public close_file(unit_number, file_status)
Closes an open file given by its logical unit number.
Definition cp_files.F:63
cp_files::get_data_dir
character(len=default_path_length) function, public get_data_dir()
Returns path of data directory if set, otherwise an empty string.
Definition cp_files.F:574
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::default_path_length
integer, parameter, public default_path_length
Definition kinds.F:58
machine
Machine interface based on Fortran 2003 and POSIX.
Definition machine.F:17
machine::default_output_unit
integer, parameter, public default_output_unit
Definition machine.F:47
machine::default_input_unit
integer, parameter, public default_input_unit
Definition machine.F:47
machine::m_getcwd
subroutine, public m_getcwd(curdir)
...
Definition machine.F:609
machine::default_error_unit
integer, parameter, public default_error_unit
Definition machine.F:47
string_utilities
Utilities for string manipulations.
Definition string_utilities.F:16
string_utilities::uppercase
elemental subroutine, public uppercase(string)
Convert all lower case characters in a string to upper case.
Definition string_utilities.F:3362