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. Tracking of preconnections.
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 : !> \author Matthias Krack (MK)
15 : ! **************************************************************************************************
16 : MODULE cp_files
17 : USE ISO_C_BINDING, ONLY: C_CHAR,&
18 : C_F_POINTER,&
19 : C_NULL_CHAR,&
20 : C_PTR
21 : USE kinds, ONLY: default_path_length
22 : USE machine, ONLY: default_input_unit,&
23 : default_output_unit,&
24 : m_getcwd
25 : #include "../base/base_uses.f90"
26 :
27 : IMPLICIT NONE
28 :
29 : PRIVATE
30 :
31 : PUBLIC :: close_file, &
32 : init_preconnection_list, &
33 : open_file, &
34 : get_unit_number, &
35 : file_exists, &
36 : get_data_dir, &
37 : discover_file
38 :
39 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_files'
40 :
41 : INTEGER, PARAMETER :: max_preconnections = 10, &
42 : max_unit_number = 999
43 :
44 : TYPE preconnection_type
45 : PRIVATE
46 : CHARACTER(LEN=default_path_length) :: file_name = ""
47 : INTEGER :: unit_number = -1
48 : END TYPE preconnection_type
49 :
50 : TYPE(preconnection_type), DIMENSION(max_preconnections) :: preconnected
51 :
52 : CONTAINS
53 :
54 : ! **************************************************************************************************
55 : !> \brief Add an entry to the list of preconnected units
56 : !> \param file_name ...
57 : !> \param unit_number ...
58 : !> \par History
59 : !> - Creation (22.02.2011,MK)
60 : !> \author Matthias Krack (MK)
61 : ! **************************************************************************************************
62 755 : SUBROUTINE assign_preconnection(file_name, unit_number)
63 :
64 : CHARACTER(LEN=*), INTENT(IN) :: file_name
65 : INTEGER, INTENT(IN) :: unit_number
66 :
67 : INTEGER :: ic, islot, nc
68 :
69 755 : IF ((unit_number < 1) .OR. (unit_number > max_unit_number)) THEN
70 0 : CPABORT("An invalid logical unit number was specified.")
71 : END IF
72 :
73 755 : IF (LEN_TRIM(file_name) == 0) THEN
74 0 : CPABORT("No valid file name was specified.")
75 : END IF
76 :
77 : nc = SIZE(preconnected)
78 :
79 : ! Check if a preconnection already exists
80 3442 : DO ic = 1, nc
81 3442 : IF (TRIM(preconnected(ic)%file_name) == TRIM(file_name)) THEN
82 : ! Return if the entry already exists
83 728 : IF (preconnected(ic)%unit_number == unit_number) THEN
84 : RETURN
85 : ELSE
86 0 : CALL print_preconnection_list()
87 : CALL cp_abort(__LOCATION__, &
88 : "Attempt to connect the already connected file <"// &
89 0 : TRIM(file_name)//"> to another unit.")
90 : END IF
91 : END IF
92 : END DO
93 :
94 : ! Search for an unused entry
95 163 : islot = -1
96 163 : DO ic = 1, nc
97 163 : IF (preconnected(ic)%unit_number == -1) THEN
98 : islot = ic
99 : EXIT
100 : END IF
101 : END DO
102 :
103 27 : IF (islot == -1) THEN
104 0 : CALL print_preconnection_list()
105 0 : CPABORT("No free slot found in the list of preconnected units.")
106 : END IF
107 :
108 27 : preconnected(islot)%file_name = TRIM(file_name)
109 27 : preconnected(islot)%unit_number = unit_number
110 :
111 755 : END SUBROUTINE assign_preconnection
112 :
113 : ! **************************************************************************************************
114 : !> \brief Close an open file given by its logical unit number.
115 : !> Optionally, keep the file and unit preconnected.
116 : !> \param unit_number ...
117 : !> \param file_status ...
118 : !> \param keep_preconnection ...
119 : !> \author Matthias Krack (MK)
120 : ! **************************************************************************************************
121 138617 : SUBROUTINE close_file(unit_number, file_status, keep_preconnection)
122 :
123 : INTEGER, INTENT(IN) :: unit_number
124 : CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_status
125 : LOGICAL, INTENT(IN), OPTIONAL :: keep_preconnection
126 :
127 : CHARACTER(LEN=2*default_path_length) :: message
128 : CHARACTER(LEN=6) :: status_string
129 : CHARACTER(LEN=default_path_length) :: file_name
130 : INTEGER :: istat
131 : LOGICAL :: exists, is_named, is_open, &
132 : keep_file_connection
133 :
134 138617 : keep_file_connection = .FALSE.
135 755 : IF (PRESENT(keep_preconnection)) keep_file_connection = keep_preconnection
136 :
137 138617 : INQUIRE (UNIT=unit_number, EXIST=exists, OPENED=is_open, IOSTAT=istat)
138 :
139 138617 : IF (istat /= 0) THEN
140 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
141 0 : "An error occurred inquiring the unit with the number ", unit_number, &
142 0 : " (IOSTAT = ", istat, ")"
143 0 : CPABORT(TRIM(message))
144 138617 : ELSE IF (.NOT. exists) THEN
145 : WRITE (UNIT=message, FMT="(A,I0,A)") &
146 0 : "The specified unit number ", unit_number, &
147 0 : " cannot be closed, because it does not exist."
148 0 : CPABORT(TRIM(message))
149 : END IF
150 :
151 : ! Close the specified file
152 :
153 138617 : IF (is_open) THEN
154 : ! Refuse to close any preconnected system unit
155 138614 : IF (unit_number == default_input_unit) THEN
156 : WRITE (UNIT=message, FMT="(A,I0)") &
157 0 : "Attempt to close the default input unit number ", unit_number
158 0 : CPABORT(TRIM(message))
159 : END IF
160 138614 : IF (unit_number == default_output_unit) THEN
161 : WRITE (UNIT=message, FMT="(A,I0)") &
162 0 : "Attempt to close the default output unit number ", unit_number
163 0 : CPABORT(TRIM(message))
164 : END IF
165 : ! Anonymous scratch files cannot be retained or preconnected by name.
166 138614 : INQUIRE (UNIT=unit_number, NAMED=is_named, IOSTAT=istat)
167 138614 : CPASSERT(istat == 0)
168 138614 : IF (.NOT. is_named .AND. keep_file_connection) THEN
169 0 : CPABORT("Cannot keep a preconnection for an anonymous scratch file")
170 : END IF
171 : ! Define status after closing the file
172 138614 : IF (PRESENT(file_status)) THEN
173 89904 : status_string = TRIM(file_status)
174 48710 : ELSE IF (.NOT. is_named) THEN
175 4 : status_string = "DELETE"
176 : ELSE
177 48706 : status_string = "KEEP"
178 : END IF
179 : ! Optionally, keep this unit preconnected
180 138614 : IF (is_named) THEN
181 138610 : INQUIRE (UNIT=unit_number, NAME=file_name, IOSTAT=istat)
182 138610 : IF (istat /= 0) THEN
183 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
184 0 : "An error occurred inquiring the unit with the number ", unit_number, &
185 0 : " (IOSTAT = ", istat, ")."
186 0 : CPABORT(TRIM(message))
187 : END IF
188 : END IF
189 : ! Manage preconnections
190 138614 : IF (keep_file_connection) THEN
191 755 : CALL assign_preconnection(file_name, unit_number)
192 : ELSE
193 137859 : IF (is_named) CALL delete_preconnection(file_name, unit_number)
194 137859 : CLOSE (UNIT=unit_number, IOSTAT=istat, STATUS=TRIM(status_string))
195 137859 : IF (istat /= 0) THEN
196 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
197 0 : "An error occurred closing the file with the logical unit number ", &
198 0 : unit_number, " (IOSTAT = ", istat, ")."
199 0 : CPABORT(TRIM(message))
200 : END IF
201 : END IF
202 : END IF
203 :
204 138617 : END SUBROUTINE close_file
205 :
206 : ! **************************************************************************************************
207 : !> \brief Remove an entry from the list of preconnected units
208 : !> \param file_name ...
209 : !> \param unit_number ...
210 : !> \par History
211 : !> - Creation (22.02.2011,MK)
212 : !> \author Matthias Krack (MK)
213 : ! **************************************************************************************************
214 137855 : SUBROUTINE delete_preconnection(file_name, unit_number)
215 :
216 : CHARACTER(LEN=*), INTENT(IN) :: file_name
217 : INTEGER :: unit_number
218 :
219 : INTEGER :: ic, nc
220 :
221 137855 : nc = SIZE(preconnected)
222 :
223 : ! Search for preconnection entry and delete it when found
224 1516301 : DO ic = 1, nc
225 1516301 : IF (TRIM(preconnected(ic)%file_name) == TRIM(file_name)) THEN
226 22 : IF (preconnected(ic)%unit_number == unit_number) THEN
227 22 : preconnected(ic)%file_name = ""
228 22 : preconnected(ic)%unit_number = -1
229 22 : EXIT
230 : ELSE
231 0 : CALL print_preconnection_list()
232 : CALL cp_abort(__LOCATION__, &
233 : "Attempt to disconnect the file <"// &
234 : TRIM(file_name)// &
235 0 : "> from an unlisted unit.")
236 : END IF
237 : END IF
238 : END DO
239 :
240 137855 : END SUBROUTINE delete_preconnection
241 :
242 : ! **************************************************************************************************
243 : !> \brief Returns the first logical unit that is not preconnected
244 : !> \param file_name ...
245 : !> \return ...
246 : !> \author Matthias Krack (MK)
247 : !> \note
248 : !> -1 if no free unit exists
249 : ! **************************************************************************************************
250 142361 : FUNCTION get_unit_number(file_name) RESULT(unit_number)
251 :
252 : CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_name
253 : INTEGER :: unit_number
254 :
255 : INTEGER :: ic, istat, nc
256 : LOGICAL :: exists, is_open
257 :
258 142361 : IF (PRESENT(file_name)) THEN
259 : nc = SIZE(preconnected)
260 : ! Check for preconnected units
261 1221933 : DO ic = 3, nc ! Exclude the preconnected system units (< 3)
262 1221933 : IF (TRIM(preconnected(ic)%file_name) == TRIM(file_name)) THEN
263 18 : unit_number = preconnected(ic)%unit_number
264 18 : RETURN
265 : END IF
266 : END DO
267 : END IF
268 :
269 : ! Get a new unit number
270 708357 : DO unit_number = 1, max_unit_number
271 7096309 : IF (ANY(unit_number == preconnected(:)%unit_number)) CYCLE
272 630143 : INQUIRE (UNIT=unit_number, EXIST=exists, OPENED=is_open, IOSTAT=istat)
273 630143 : IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) RETURN
274 : END DO
275 :
276 142361 : unit_number = -1
277 :
278 : END FUNCTION get_unit_number
279 :
280 : ! **************************************************************************************************
281 : !> \brief Allocate and initialise the list of preconnected units
282 : !> \par History
283 : !> - Creation (22.02.2011,MK)
284 : !> \author Matthias Krack (MK)
285 : ! **************************************************************************************************
286 1382 : SUBROUTINE init_preconnection_list()
287 :
288 : INTEGER :: ic, nc
289 :
290 1382 : nc = SIZE(preconnected)
291 :
292 15202 : DO ic = 1, nc
293 13820 : preconnected(ic)%file_name = ""
294 15202 : preconnected(ic)%unit_number = -1
295 : END DO
296 :
297 : ! Define reserved unit numbers
298 1382 : preconnected(1)%file_name = "stdin"
299 1382 : preconnected(1)%unit_number = default_input_unit
300 1382 : preconnected(2)%file_name = "stdout"
301 1382 : preconnected(2)%unit_number = default_output_unit
302 :
303 1382 : END SUBROUTINE init_preconnection_list
304 :
305 : ! **************************************************************************************************
306 : !> \brief Opens the requested file using a free unit number
307 : !> \param file_name File name; must be empty for an anonymous SCRATCH file
308 : !> \param file_status Fortran file status, including SCRATCH for temporary files
309 : !> \param file_form ...
310 : !> \param file_action ...
311 : !> \param file_position ...
312 : !> \param file_pad ...
313 : !> \param unit_number ...
314 : !> \param debug ...
315 : !> \param skip_get_unit_number ...
316 : !> \param file_access file access mode
317 : !> \author Matthias Krack (MK)
318 : ! **************************************************************************************************
319 141165 : SUBROUTINE open_file(file_name, file_status, file_form, file_action, &
320 : file_position, file_pad, unit_number, debug, &
321 : skip_get_unit_number, file_access)
322 :
323 : CHARACTER(LEN=*), INTENT(IN) :: file_name
324 : CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_status, file_form, file_action, &
325 : file_position, file_pad
326 : INTEGER, INTENT(INOUT) :: unit_number
327 : INTEGER, INTENT(IN), OPTIONAL :: debug
328 : LOGICAL, INTENT(IN), OPTIONAL :: skip_get_unit_number
329 : CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_access
330 :
331 : CHARACTER(LEN=*), PARAMETER :: routineN = 'open_file'
332 :
333 : CHARACTER(LEN=11) :: access_string, action_string, current_action, current_form, &
334 : form_string, pad_string, position_string, status_string
335 : CHARACTER(LEN=2*default_path_length) :: message
336 : CHARACTER(LEN=default_path_length) :: cwd, iomsgstr, real_file_name
337 : INTEGER :: debug_unit, istat
338 : LOGICAL :: exists, get_a_new_unit, is_open
339 :
340 141165 : IF (PRESENT(file_access)) THEN
341 25 : access_string = TRIM(file_access)
342 : ELSE
343 141140 : access_string = "SEQUENTIAL"
344 : END IF
345 :
346 141165 : IF (PRESENT(file_status)) THEN
347 107517 : status_string = TRIM(file_status)
348 : ELSE
349 33648 : status_string = "OLD"
350 : END IF
351 :
352 141165 : IF (PRESENT(file_form)) THEN
353 98574 : form_string = TRIM(file_form)
354 : ELSE
355 42591 : form_string = "FORMATTED"
356 : END IF
357 :
358 141165 : IF (PRESENT(file_pad)) THEN
359 2 : pad_string = file_pad
360 2 : IF (form_string == "UNFORMATTED") THEN
361 : WRITE (UNIT=message, FMT="(A)") &
362 0 : "The PAD specifier is not allowed for an UNFORMATTED file."
363 0 : CPABORT(TRIM(message))
364 : END IF
365 : ELSE
366 141163 : pad_string = "YES"
367 : END IF
368 :
369 141165 : IF (PRESENT(file_action)) THEN
370 107517 : action_string = TRIM(file_action)
371 : ELSE
372 33648 : action_string = "READ"
373 : END IF
374 :
375 141165 : IF (PRESENT(file_position)) THEN
376 101450 : position_string = TRIM(file_position)
377 : ELSE
378 39715 : position_string = "REWIND"
379 : END IF
380 :
381 141165 : IF (PRESENT(debug)) THEN
382 138 : debug_unit = debug
383 : ELSE
384 141027 : debug_unit = 0 ! use default_output_unit for debugging
385 : END IF
386 :
387 141165 : IF (status_string == "SCRATCH") THEN
388 4 : CPASSERT(LEN_TRIM(file_name) == 0)
389 4 : get_a_new_unit = .TRUE.
390 4 : IF (PRESENT(skip_get_unit_number)) get_a_new_unit = .NOT. skip_get_unit_number
391 4 : IF (get_a_new_unit) unit_number = get_unit_number()
392 4 : CPASSERT(unit_number > 0)
393 4 : IF (form_string == "FORMATTED") THEN
394 : OPEN (UNIT=unit_number, STATUS="SCRATCH", ACCESS=access_string, FORM=form_string, &
395 2 : POSITION=position_string, ACTION=action_string, PAD=pad_string, IOMSG=iomsgstr, IOSTAT=istat)
396 : ELSE
397 : OPEN (UNIT=unit_number, STATUS="SCRATCH", ACCESS=access_string, FORM=form_string, &
398 2 : POSITION=position_string, ACTION=action_string, IOMSG=iomsgstr, IOSTAT=istat)
399 : END IF
400 4 : IF (istat /= 0) THEN
401 0 : CALL cp_abort(__LOCATION__, "Error opening an anonymous scratch file: "//TRIM(iomsgstr))
402 : END IF
403 4 : RETURN
404 : END IF
405 :
406 141161 : IF (file_name(1:1) == " ") THEN
407 : WRITE (UNIT=message, FMT="(A)") &
408 0 : "The file name <"//TRIM(file_name)//"> has leading blanks."
409 0 : CPABORT(TRIM(message))
410 : END IF
411 :
412 141161 : IF (status_string == "OLD") THEN
413 41760 : real_file_name = discover_file(file_name)
414 : ELSE
415 : ! Strip leading and trailing blanks from file name
416 99401 : real_file_name = TRIM(ADJUSTL(file_name))
417 99401 : IF (LEN_TRIM(real_file_name) == 0) THEN
418 0 : CPABORT("A file name length of zero for a new file is invalid.")
419 : END IF
420 : END IF
421 :
422 : ! Check the specified input file name
423 141161 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exists, OPENED=is_open, IOSTAT=istat)
424 :
425 141161 : IF (istat /= 0) THEN
426 : WRITE (UNIT=message, FMT="(A,I0,A)") &
427 : "An error occurred inquiring the file <"//TRIM(real_file_name)// &
428 0 : "> (IOSTAT = ", istat, ")"
429 0 : CPABORT(TRIM(message))
430 141161 : ELSE IF (status_string == "OLD") THEN
431 41760 : IF (.NOT. exists) THEN
432 : WRITE (UNIT=message, FMT="(A)") &
433 : "The specified OLD file <"//TRIM(real_file_name)// &
434 : "> cannot be opened. It does not exist. "// &
435 0 : "Data directory path: "//TRIM(get_data_dir())
436 0 : CPABORT(TRIM(message))
437 : END IF
438 : END IF
439 :
440 : ! Open the specified input file
441 141161 : IF (is_open) THEN
442 : INQUIRE (FILE=TRIM(real_file_name), NUMBER=unit_number, &
443 2581 : ACTION=current_action, FORM=current_form)
444 2581 : IF (TRIM(position_string) == "REWIND") REWIND (UNIT=unit_number)
445 2581 : IF (TRIM(status_string) == "NEW") THEN
446 : CALL cp_abort(__LOCATION__, &
447 : "Attempt to re-open the existing OLD file <"// &
448 0 : TRIM(real_file_name)//"> with status attribute NEW.")
449 : END IF
450 2581 : IF (TRIM(current_form) /= TRIM(form_string)) THEN
451 : CALL cp_abort(__LOCATION__, &
452 : "Attempt to re-open the existing "// &
453 : TRIM(current_form)//" file <"//TRIM(real_file_name)// &
454 0 : "> as "//TRIM(form_string)//" file.")
455 : END IF
456 2581 : IF (TRIM(current_action) /= TRIM(action_string)) THEN
457 : CALL cp_abort(__LOCATION__, &
458 : "Attempt to re-open the existing file <"// &
459 : TRIM(real_file_name)//"> with the modified ACTION attribute "// &
460 : TRIM(action_string)//". The current ACTION attribute is "// &
461 0 : TRIM(current_action)//".")
462 : END IF
463 : ELSE
464 : ! Find an unused unit number
465 138580 : get_a_new_unit = .TRUE.
466 138580 : IF (PRESENT(skip_get_unit_number)) THEN
467 2801 : IF (skip_get_unit_number) get_a_new_unit = .FALSE.
468 : END IF
469 135779 : IF (get_a_new_unit) unit_number = get_unit_number(TRIM(real_file_name))
470 138580 : IF (unit_number < 1) THEN
471 : WRITE (UNIT=message, FMT="(A)") &
472 : "Cannot open the file <"//TRIM(real_file_name)// &
473 0 : ">, because no unused logical unit number could be obtained."
474 0 : CPABORT(TRIM(message))
475 : END IF
476 138580 : IF (TRIM(form_string) == "FORMATTED") THEN
477 : OPEN (UNIT=unit_number, &
478 : FILE=TRIM(real_file_name), &
479 : STATUS=TRIM(status_string), &
480 : ACCESS=TRIM(access_string), &
481 : FORM=TRIM(form_string), &
482 : POSITION=TRIM(position_string), &
483 : ACTION=TRIM(action_string), &
484 : PAD=TRIM(pad_string), &
485 : IOMSG=iomsgstr, &
486 116329 : IOSTAT=istat)
487 : ELSE
488 : OPEN (UNIT=unit_number, &
489 : FILE=TRIM(real_file_name), &
490 : STATUS=TRIM(status_string), &
491 : ACCESS=TRIM(access_string), &
492 : FORM=TRIM(form_string), &
493 : POSITION=TRIM(position_string), &
494 : ACTION=TRIM(action_string), &
495 : IOMSG=iomsgstr, &
496 22251 : IOSTAT=istat)
497 : END IF
498 138580 : IF (istat /= 0) THEN
499 0 : CALL m_getcwd(cwd)
500 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
501 : "An error occurred opening the file '"//TRIM(real_file_name)// &
502 0 : "' (UNIT = ", unit_number, ", IOSTAT = ", istat, "). "//TRIM(iomsgstr)//". "// &
503 0 : "Current working directory: "//TRIM(cwd)
504 :
505 0 : CPABORT(TRIM(message))
506 : END IF
507 : END IF
508 :
509 141161 : IF (debug_unit > 0) THEN
510 : INQUIRE (FILE=TRIM(real_file_name), OPENED=is_open, NUMBER=unit_number, &
511 : POSITION=position_string, NAME=message, ACCESS=access_string, &
512 138 : FORM=form_string, ACTION=action_string)
513 138 : WRITE (UNIT=debug_unit, FMT="(T2,A)") "BEGIN DEBUG "//TRIM(routineN)
514 138 : WRITE (UNIT=debug_unit, FMT="(T3,A,I0)") "NUMBER : ", unit_number
515 138 : WRITE (UNIT=debug_unit, FMT="(T3,A,L1)") "OPENED : ", is_open
516 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "NAME : "//TRIM(message)
517 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "POSITION: "//TRIM(position_string)
518 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "ACCESS : "//TRIM(access_string)
519 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "FORM : "//TRIM(form_string)
520 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "ACTION : "//TRIM(action_string)
521 138 : WRITE (UNIT=debug_unit, FMT="(T2,A)") "END DEBUG "//TRIM(routineN)
522 138 : CALL print_preconnection_list(debug_unit)
523 : END IF
524 :
525 141165 : END SUBROUTINE open_file
526 :
527 : ! **************************************************************************************************
528 : !> \brief Checks if file exists, considering also the file discovery mechanism.
529 : !> \param file_name ...
530 : !> \return ...
531 : !> \author Ole Schuett
532 : ! **************************************************************************************************
533 713 : FUNCTION file_exists(file_name) RESULT(exist)
534 : CHARACTER(LEN=*), INTENT(IN) :: file_name
535 : LOGICAL :: exist
536 :
537 : CHARACTER(LEN=default_path_length) :: real_file_name
538 :
539 713 : real_file_name = discover_file(file_name)
540 713 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exist)
541 :
542 713 : END FUNCTION file_exists
543 :
544 : ! **************************************************************************************************
545 : !> \brief Checks various locations for a file name.
546 : !> \param file_name ...
547 : !> \return ...
548 : !> \author Ole Schuett
549 : ! **************************************************************************************************
550 42498 : FUNCTION discover_file(file_name) RESULT(real_file_name)
551 : CHARACTER(LEN=*), INTENT(IN) :: file_name
552 : CHARACTER(LEN=default_path_length) :: real_file_name
553 :
554 : CHARACTER(LEN=default_path_length) :: candidate, data_dir
555 : INTEGER :: stat
556 : LOGICAL :: exists
557 :
558 : ! Strip leading and trailing blanks from file name
559 42498 : real_file_name = TRIM(ADJUSTL(file_name))
560 :
561 42498 : IF (LEN_TRIM(real_file_name) == 0) THEN
562 0 : CPABORT("A file name length of zero for an existing file is invalid.")
563 : END IF
564 :
565 : ! First try file name directly
566 42498 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exists, IOSTAT=stat)
567 58890 : IF (stat == 0 .AND. exists) RETURN
568 :
569 : ! Then try the data directory
570 16483 : data_dir = get_data_dir()
571 16483 : IF (LEN_TRIM(data_dir) > 0) THEN
572 16483 : candidate = join_paths(data_dir, real_file_name)
573 16483 : INQUIRE (FILE=TRIM(candidate), EXIST=exists, IOSTAT=stat)
574 16483 : IF (stat == 0 .AND. exists) THEN
575 16392 : real_file_name = candidate
576 16392 : RETURN
577 : END IF
578 : END IF
579 :
580 42498 : END FUNCTION discover_file
581 :
582 : ! **************************************************************************************************
583 : !> \brief Returns path of data directory if set, otherwise an empty string
584 : !> \return ...
585 : !> \author Ole Schuett
586 : ! **************************************************************************************************
587 22381 : FUNCTION get_data_dir() RESULT(res)
588 : CHARACTER(len=default_path_length) :: res
589 :
590 : CHARACTER(LEN=1, KIND=C_CHAR), DIMENSION(:), &
591 22381 : POINTER :: path_f
592 : INTEGER :: i
593 : TYPE(C_PTR) :: path_c
594 : INTERFACE
595 : FUNCTION get_data_dir_c() BIND(C, name="get_data_dir")
596 : IMPORT :: C_PTR
597 : TYPE(C_PTR) :: get_data_dir_c
598 : END FUNCTION get_data_dir_c
599 : END INTERFACE
600 :
601 22381 : path_c = get_data_dir_c()
602 44762 : CALL C_F_POINTER(path_c, path_f, shape=[default_path_length])
603 :
604 22381 : res = ""
605 335715 : DO i = 1, default_path_length
606 335715 : IF (path_f(i) == C_NULL_CHAR) RETURN
607 313334 : res(i:i) = path_f(i)
608 : END DO
609 :
610 0 : CPABORT("CP2K_DATA_DIR path is too long")
611 :
612 22381 : END FUNCTION get_data_dir
613 :
614 : ! **************************************************************************************************
615 : !> \brief Joins two file-paths, inserting '/' as needed.
616 : !> \param path1 ...
617 : !> \param path2 ...
618 : !> \return ...
619 : !> \author Ole Schuett
620 : ! **************************************************************************************************
621 16483 : FUNCTION join_paths(path1, path2) RESULT(joined_path)
622 : CHARACTER(LEN=*), INTENT(IN) :: path1, path2
623 : CHARACTER(LEN=default_path_length) :: joined_path
624 :
625 : INTEGER :: n
626 :
627 16483 : n = LEN_TRIM(path1)
628 16483 : IF (path2(1:1) == '/') THEN
629 0 : joined_path = path2
630 16483 : ELSE IF (n == 0 .OR. path1(n:n) == '/') THEN
631 0 : joined_path = TRIM(path1)//path2
632 : ELSE
633 16483 : joined_path = TRIM(path1)//'/'//path2
634 : END IF
635 16483 : END FUNCTION join_paths
636 :
637 : ! **************************************************************************************************
638 : !> \brief Print the list of preconnected units
639 : !> \param output_unit which unit to print to (optional)
640 : !> \par History
641 : !> - Creation (22.02.2011,MK)
642 : !> \author Matthias Krack (MK)
643 : ! **************************************************************************************************
644 138 : SUBROUTINE print_preconnection_list(output_unit)
645 : INTEGER, INTENT(IN), OPTIONAL :: output_unit
646 :
647 : INTEGER :: ic, nc, unit
648 :
649 : IF (PRESENT(output_unit)) THEN
650 138 : unit = output_unit
651 : ELSE
652 138 : unit = default_output_unit
653 : END IF
654 :
655 138 : nc = SIZE(preconnected)
656 :
657 138 : IF (output_unit > 0) THEN
658 :
659 : WRITE (UNIT=output_unit, FMT="(A,/,A)") &
660 138 : " LIST OF PRECONNECTED LOGICAL UNITS", &
661 276 : " Slot Unit number File name"
662 1518 : DO ic = 1, nc
663 1518 : IF (preconnected(ic)%unit_number > 0) THEN
664 : WRITE (UNIT=output_unit, FMT="(I6,3X,I6,8X,A)") &
665 871 : ic, preconnected(ic)%unit_number, &
666 1742 : TRIM(preconnected(ic)%file_name)
667 : ELSE
668 : WRITE (UNIT=output_unit, FMT="(I6,17X,A)") &
669 509 : ic, "UNUSED"
670 : END IF
671 : END DO
672 : END IF
673 138 : END SUBROUTINE print_preconnection_list
674 :
675 0 : END MODULE cp_files
|
