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