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_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 :
51 : CONTAINS
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 139465 : 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 139465 : INQUIRE (UNIT=unit_number, EXIST=exists, NAMED=is_named, OPENED=is_open, IOSTAT=istat)
74 :
75 139465 : IF (istat /= 0) THEN
76 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
77 0 : "An error occurred inquiring the unit with the number ", unit_number, &
78 0 : " (IOSTAT = ", istat, ")"
79 0 : CALL cp_abort(__LOCATION__, TRIM(message))
80 139465 : ELSE IF (.NOT. exists) THEN
81 : WRITE (UNIT=message, FMT="(A,I0,A)") &
82 0 : "The specified unit number ", unit_number, &
83 0 : " cannot be closed, because it does not exist."
84 0 : CALL cp_abort(__LOCATION__, TRIM(message))
85 : END IF
86 :
87 : ! Close the specified file
88 :
89 139465 : IF (is_open) THEN
90 :
91 : ! Refuse to close any default unit
92 0 : SELECT CASE (unit_number)
93 : CASE (default_error_unit)
94 : WRITE (UNIT=message, FMT="(A,I0)") &
95 0 : "Attempt to close the default error unit number ", unit_number
96 0 : CALL cp_abort(__LOCATION__, TRIM(message))
97 : CASE (default_input_unit)
98 : WRITE (UNIT=message, FMT="(A,I0)") &
99 0 : "Attempt to close the default input unit number ", unit_number
100 0 : CALL cp_abort(__LOCATION__, TRIM(message))
101 : CASE (default_output_unit)
102 : WRITE (UNIT=message, FMT="(A,I0)") &
103 0 : "Attempt to close the default output unit number ", unit_number
104 139462 : 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 139462 : IF (PRESENT(file_status)) THEN
109 90444 : 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 0 : " was specified.")
113 : END IF
114 90444 : status_string = TRIM(ADJUSTL(file_status))
115 90444 : CALL uppercase(status_string)
116 49018 : ELSE IF (.NOT. is_named) THEN
117 4 : status_string = "DELETE"
118 : ELSE
119 49014 : status_string = "KEEP"
120 : END IF
121 :
122 139462 : SELECT CASE (status_string)
123 : CASE ("DELETE", "KEEP")
124 139462 : CLOSE (UNIT=unit_number, IOSTAT=istat, IOMSG=iomsg_string, STATUS=TRIM(status_string))
125 139462 : 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 0 : TRIM(int_to_string(istat))//"): "//TRIM(iomsg_string))
130 : END IF
131 : CASE DEFAULT
132 : CALL cp_abort(__LOCATION__, &
133 139462 : "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 139465 : 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 140199 : FUNCTION get_unit_number() RESULT(unit_number)
153 :
154 : INTEGER :: unit_number
155 :
156 : INTEGER :: istat
157 : LOGICAL :: exists, is_open
158 :
159 766115 : DO unit_number = 1, max_unit_number
160 0 : SELECT CASE (unit_number)
161 : CASE (default_error_unit, default_input_unit, default_output_unit)
162 699613 : CYCLE
163 : CASE DEFAULT
164 699613 : INQUIRE (UNIT=unit_number, EXIST=exists, OPENED=is_open, IOSTAT=istat)
165 1465728 : IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) RETURN
166 : END SELECT
167 : END DO
168 :
169 140199 : 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 142186 : 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 142186 : real_file_name = ""
213 142186 : unit_number = -1
214 :
215 142186 : IF (PRESENT(file_access)) THEN
216 25 : access_string = TRIM(ADJUSTL(file_access))
217 25 : CALL uppercase(access_string)
218 25 : IF (access_string == "DIRECT") THEN
219 : CALL cp_abort(__LOCATION__, &
220 0 : "ACCESS=DIRECT is not supported.")
221 : END IF
222 : ELSE
223 142161 : access_string = "SEQUENTIAL"
224 : END IF
225 :
226 142186 : IF (PRESENT(file_status)) THEN
227 108256 : status_string = TRIM(ADJUSTL(file_status))
228 108256 : CALL uppercase(status_string)
229 : ELSE
230 33930 : status_string = "OLD"
231 : END IF
232 :
233 142186 : IF (PRESENT(file_form)) THEN
234 99226 : form_string = TRIM(ADJUSTL(file_form))
235 99226 : CALL uppercase(form_string)
236 : ELSE
237 42960 : form_string = "FORMATTED"
238 : END IF
239 :
240 142186 : IF (PRESENT(file_pad)) THEN
241 2 : pad_string = TRIM(ADJUSTL(file_pad))
242 2 : CALL uppercase(pad_string)
243 2 : IF (form_string == "UNFORMATTED") THEN
244 : CALL cp_abort(__LOCATION__, &
245 0 : "The PAD specifier is not allowed for an UNFORMATTED file.")
246 : END IF
247 : ELSE
248 142184 : pad_string = "YES"
249 : END IF
250 :
251 142186 : IF (PRESENT(file_action)) THEN
252 108255 : action_string = TRIM(ADJUSTL(file_action))
253 108255 : CALL uppercase(action_string)
254 : ELSE
255 : ! A new or emptied file cannot be read, thus WRITE is the only sensible default
256 0 : SELECT CASE (status_string)
257 : CASE ("NEW", "REPLACE", "SCRATCH")
258 0 : action_string = "WRITE"
259 : CASE DEFAULT
260 33931 : action_string = "READ"
261 : END SELECT
262 : END IF
263 :
264 142186 : IF (PRESENT(file_position)) THEN
265 102055 : position_string = TRIM(ADJUSTL(file_position))
266 102055 : CALL uppercase(position_string)
267 : ELSE
268 40131 : position_string = "REWIND"
269 : END IF
270 :
271 142186 : IF (PRESENT(file_name)) THEN
272 142182 : IF (LEN_TRIM(file_name) == 0) THEN
273 : CALL cp_abort(__LOCATION__, &
274 0 : "The specified FILE name is empty.")
275 : END IF
276 142182 : 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 0 : TRIM(int_to_string(LEN(real_file_name)))//" characters.")
280 : END IF
281 142182 : IF (file_name(1:1) == " ") THEN
282 : CALL cp_abort(__LOCATION__, &
283 0 : "The FILE name <"//TRIM(file_name)//"> has leading blanks.")
284 : END IF
285 142182 : IF (status_string == "SCRATCH") THEN
286 : CALL cp_abort(__LOCATION__, &
287 0 : "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 142182 : IF ((status_string == "OLD") .AND. (action_string == "READ")) THEN
292 39033 : real_file_name = discover_file(file_name)
293 : ELSE
294 103149 : real_file_name = TRIM(ADJUSTL(file_name))
295 : END IF
296 : END IF
297 :
298 142182 : SELECT CASE (status_string)
299 : CASE ("SCRATCH")
300 : ! No file name required
301 : CASE ("NEW", "OLD", "REPLACE", "UNKNOWN")
302 142182 : 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 0 : TRIM(status_string)//" is not allowed.")
306 : END IF
307 : CASE DEFAULT
308 142186 : 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 142186 : connect = .FALSE.
315 142186 : exists = .FALSE.
316 142186 : is_open = .FALSE.
317 142186 : inquire_stat = 0
318 142186 : open_stat = 0
319 142186 : iomsg_string = ""
320 284372 : !$OMP CRITICAL(cp_files_connect)
321 142186 : IF (status_string == "SCRATCH") THEN
322 : connect = .TRUE.
323 : ELSE
324 142182 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exists, OPENED=is_open, IOSTAT=inquire_stat)
325 142182 : IF (inquire_stat == 0) THEN
326 142182 : IF (is_open) THEN
327 : INQUIRE (FILE=TRIM(real_file_name), NUMBER=unit_number, &
328 1987 : ACTION=current_action, FORM=current_form, ACCESS=current_access)
329 : ELSE
330 12 : SELECT CASE (status_string)
331 : CASE ("NEW")
332 12 : connect = (.NOT. exists)
333 : CASE ("OLD")
334 41888 : connect = exists
335 : CASE DEFAULT
336 140195 : connect = .TRUE.
337 : END SELECT
338 : END IF
339 : END IF
340 : END IF
341 41900 : IF (connect) THEN
342 140199 : unit_number = get_unit_number()
343 140199 : IF (unit_number > 0) THEN
344 140199 : IF (status_string == "SCRATCH") THEN
345 4 : 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 2 : 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 2 : IOSTAT=open_stat)
364 : END IF
365 : ELSE
366 140195 : 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 117836 : 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 22359 : IOSTAT=open_stat)
387 : END IF
388 : END IF
389 : END IF
390 : END IF
391 : !$OMP END CRITICAL(cp_files_connect)
392 :
393 142186 : IF (inquire_stat /= 0) THEN
394 : CALL cp_abort(__LOCATION__, &
395 : "An error occurred inquiring the file <"//TRIM(real_file_name)// &
396 0 : "> (IOSTAT="//TRIM(int_to_string(inquire_stat))//").")
397 : END IF
398 :
399 142186 : IF (is_open) THEN
400 : ! The file is already connected: check the connection and reuse it
401 1987 : CALL uppercase(current_action)
402 1987 : 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 0 : TRIM(current_action)//".")
408 : END IF
409 1987 : CALL uppercase(current_form)
410 1987 : 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 0 : "> as "//TRIM(form_string)//" file.")
415 : END IF
416 1987 : CALL uppercase(current_access)
417 1987 : 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 0 : "> with ACCESS="//TRIM(access_string)//".")
422 : END IF
423 1987 : IF (status_string == "NEW") THEN
424 : CALL cp_abort(__LOCATION__, &
425 : "Attempt to re-open the existing file <"// &
426 0 : TRIM(real_file_name)//"> with STATUS=NEW.")
427 : END IF
428 1987 : IF (position_string == "REWIND") REWIND (UNIT=unit_number)
429 : ELSE
430 : ! Check the outcome of the connection attempt
431 12 : SELECT CASE (status_string)
432 : CASE ("NEW")
433 12 : IF (exists) THEN
434 : CALL cp_abort(__LOCATION__, &
435 : "The file <"//TRIM(real_file_name)// &
436 0 : "> cannot be opened with STATUS=NEW, because it already exists.")
437 : END IF
438 : CASE ("OLD")
439 140199 : IF (.NOT. exists) THEN
440 0 : 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 0 : "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 0 : TRIM(action_string)//". It does not exist.")
450 : END IF
451 : END IF
452 : END SELECT
453 140199 : IF (unit_number < 1) THEN
454 0 : IF (status_string == "SCRATCH") THEN
455 : CALL cp_abort(__LOCATION__, &
456 0 : "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 0 : ">, because no unused logical unit number could be obtained.")
461 : END IF
462 : END IF
463 140199 : IF (open_stat /= 0) THEN
464 0 : 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 0 : TRIM(int_to_string(open_stat))//"): "//TRIM(iomsg_string))
469 : ELSE
470 0 : 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 0 : TRIM(iomsg_string)//". Current working directory: "//TRIM(cwd))
476 : END IF
477 : END IF
478 : END IF
479 :
480 142186 : IF (PRESENT(debug)) THEN
481 157 : 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 144 : ACTION=action_string)
489 : ! The NAME specifier is undefined for unnamed (SCRATCH) files
490 144 : IF (is_named) THEN
491 144 : INQUIRE (UNIT=unit_number, NAME=message)
492 : ELSE
493 0 : message = "<unnamed>"
494 : END IF
495 144 : WRITE (UNIT=default_output_unit, FMT="(T2,A)") "BEGIN DEBUG "//TRIM(routineN)
496 144 : WRITE (UNIT=default_output_unit, FMT="(T3,A,I0)") "NUMBER : ", unit_number
497 144 : WRITE (UNIT=default_output_unit, FMT="(T3,A,L1)") "OPENED : ", is_open
498 : WRITE (UNIT=default_output_unit, FMT="(T3,A)") &
499 144 : "NAME : "//TRIM(message), &
500 144 : "POSITION: "//TRIM(position_string), &
501 144 : "ACCESS : "//TRIM(access_string), &
502 144 : "FORM : "//TRIM(form_string), &
503 144 : "ACTION : "//TRIM(action_string), &
504 288 : "END DEBUG "//TRIM(routineN)
505 : END IF
506 : END IF
507 :
508 142186 : 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 713 : 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 713 : real_file_name = discover_file(file_name)
524 713 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exist, IOSTAT=istat)
525 713 : IF (istat /= 0) exist = .FALSE.
526 :
527 713 : 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 39771 : 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 39771 : real_file_name = TRIM(ADJUSTL(file_name))
546 :
547 39771 : IF (LEN_TRIM(real_file_name) == 0) THEN
548 0 : 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 39771 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exists, IOSTAT=stat)
553 56327 : IF (stat == 0 .AND. exists) RETURN
554 :
555 : ! Then try the data directory
556 16647 : data_dir = get_data_dir()
557 16647 : IF (LEN_TRIM(data_dir) > 0) THEN
558 16647 : candidate = join_paths(data_dir, real_file_name)
559 16647 : INQUIRE (FILE=TRIM(candidate), EXIST=exists, IOSTAT=stat)
560 16647 : IF (stat == 0 .AND. exists) THEN
561 16556 : real_file_name = candidate
562 16556 : RETURN
563 : END IF
564 : END IF
565 :
566 39771 : 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 22611 : FUNCTION get_data_dir() RESULT(res)
574 : CHARACTER(len=default_path_length) :: res
575 :
576 : CHARACTER(LEN=1, KIND=C_CHAR), DIMENSION(:), &
577 22611 : 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 22611 : path_c = get_data_dir_c()
588 45222 : CALL C_F_POINTER(path_c, path_f, shape=[default_path_length])
589 :
590 22611 : res = ""
591 339165 : DO i = 1, default_path_length
592 339165 : IF (path_f(i) == C_NULL_CHAR) RETURN
593 316554 : res(i:i) = path_f(i)
594 : END DO
595 :
596 0 : CALL cp_abort(__LOCATION__, "The CP2K_DATA_DIR path is too long")
597 :
598 22611 : 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 16655 : 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 16655 : n1 = LEN_TRIM(path1)
615 16655 : n2 = LEN_TRIM(path2)
616 :
617 16655 : absolute = .FALSE.
618 16655 : IF (n2 > 0) absolute = (path2(1:1) == '/')
619 :
620 : ! Determine the length of the joined path before assigning it to avoid silent truncation
621 16655 : IF (absolute .OR. (n1 == 0)) THEN
622 : joined_length = n2
623 16647 : ELSE IF (path1(n1:n1) == '/') THEN
624 0 : joined_length = n1 + n2
625 : ELSE
626 16647 : joined_length = n1 + 1 + n2
627 : END IF
628 16655 : 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 0 : TRIM(int_to_string(LEN(joined_path)))//" characters.")
633 : END IF
634 :
635 16655 : IF (absolute .OR. (n1 == 0)) THEN
636 8 : joined_path = path2(1:n2)
637 16647 : ELSE IF (path1(n1:n1) == '/') THEN
638 0 : joined_path = path1(1:n1)//path2(1:n2)
639 : ELSE
640 16647 : joined_path = path1(1:n1)//'/'//path2(1:n2)
641 : END IF
642 :
643 16655 : 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 0 : FUNCTION int_to_string(i) RESULT(string)
652 : INTEGER, INTENT(IN) :: i
653 : CHARACTER(LEN=11) :: string
654 :
655 0 : WRITE (UNIT=string, FMT="(I0)") i
656 :
657 0 : END FUNCTION int_to_string
658 :
659 : END MODULE cp_files
|
