Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2025 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 3011 : DO ic = 1, nc
81 3011 : 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 87 : islot = -1
96 87 : DO ic = 1, nc
97 87 : 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 130299 : 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_open, keep_file_connection
132 :
133 130299 : keep_file_connection = .FALSE.
134 755 : IF (PRESENT(keep_preconnection)) keep_file_connection = keep_preconnection
135 :
136 130299 : INQUIRE (UNIT=unit_number, EXIST=exists, OPENED=is_open, IOSTAT=istat)
137 :
138 130299 : IF (istat /= 0) THEN
139 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
140 0 : "An error occurred inquiring the unit with the number ", unit_number, &
141 0 : " (IOSTAT = ", istat, ")"
142 0 : CPABORT(TRIM(message))
143 130299 : ELSE IF (.NOT. exists) THEN
144 : WRITE (UNIT=message, FMT="(A,I0,A)") &
145 0 : "The specified unit number ", unit_number, &
146 0 : " cannot be closed, because it does not exist."
147 0 : CPABORT(TRIM(message))
148 : END IF
149 :
150 : ! Close the specified file
151 :
152 130299 : IF (is_open) THEN
153 : ! Refuse to close any preconnected system unit
154 130295 : IF (unit_number == default_input_unit) THEN
155 : WRITE (UNIT=message, FMT="(A,I0)") &
156 0 : "Attempt to close the default input unit number ", unit_number
157 0 : CPABORT(TRIM(message))
158 : END IF
159 130295 : IF (unit_number == default_output_unit) THEN
160 : WRITE (UNIT=message, FMT="(A,I0)") &
161 0 : "Attempt to close the default output unit number ", unit_number
162 0 : CPABORT(TRIM(message))
163 : END IF
164 : ! Define status after closing the file
165 130295 : IF (PRESENT(file_status)) THEN
166 85921 : status_string = TRIM(file_status)
167 : ELSE
168 44374 : status_string = "KEEP"
169 : END IF
170 : ! Optionally, keep this unit preconnected
171 130295 : INQUIRE (UNIT=unit_number, NAME=file_name, IOSTAT=istat)
172 130295 : IF (istat /= 0) THEN
173 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
174 0 : "An error occurred inquiring the unit with the number ", unit_number, &
175 0 : " (IOSTAT = ", istat, ")."
176 0 : CPABORT(TRIM(message))
177 : END IF
178 : ! Manage preconnections
179 130295 : IF (keep_file_connection) THEN
180 755 : CALL assign_preconnection(file_name, unit_number)
181 : ELSE
182 129540 : CALL delete_preconnection(file_name, unit_number)
183 129540 : CLOSE (UNIT=unit_number, IOSTAT=istat, STATUS=TRIM(status_string))
184 129540 : IF (istat /= 0) THEN
185 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
186 0 : "An error occurred closing the file with the logical unit number ", &
187 0 : unit_number, " (IOSTAT = ", istat, ")."
188 0 : CPABORT(TRIM(message))
189 : END IF
190 : END IF
191 : END IF
192 :
193 130299 : END SUBROUTINE close_file
194 :
195 : ! **************************************************************************************************
196 : !> \brief Remove an entry from the list of preconnected units
197 : !> \param file_name ...
198 : !> \param unit_number ...
199 : !> \par History
200 : !> - Creation (22.02.2011,MK)
201 : !> \author Matthias Krack (MK)
202 : ! **************************************************************************************************
203 129540 : SUBROUTINE delete_preconnection(file_name, unit_number)
204 :
205 : CHARACTER(LEN=*), INTENT(IN) :: file_name
206 : INTEGER :: unit_number
207 :
208 : INTEGER :: ic, nc
209 :
210 129540 : nc = SIZE(preconnected)
211 :
212 : ! Search for preconnection entry and delete it when found
213 1424778 : DO ic = 1, nc
214 1424778 : IF (TRIM(preconnected(ic)%file_name) == TRIM(file_name)) THEN
215 21 : IF (preconnected(ic)%unit_number == unit_number) THEN
216 21 : preconnected(ic)%file_name = ""
217 21 : preconnected(ic)%unit_number = -1
218 21 : EXIT
219 : ELSE
220 0 : CALL print_preconnection_list()
221 : CALL cp_abort(__LOCATION__, &
222 : "Attempt to disconnect the file <"// &
223 : TRIM(file_name)// &
224 0 : "> from an unlisted unit.")
225 : END IF
226 : END IF
227 : END DO
228 :
229 129540 : END SUBROUTINE delete_preconnection
230 :
231 : ! **************************************************************************************************
232 : !> \brief Returns the first logical unit that is not preconnected
233 : !> \param file_name ...
234 : !> \return ...
235 : !> \author Matthias Krack (MK)
236 : !> \note
237 : !> -1 if no free unit exists
238 : ! **************************************************************************************************
239 132640 : FUNCTION get_unit_number(file_name) RESULT(unit_number)
240 :
241 : CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_name
242 : INTEGER :: unit_number
243 :
244 : INTEGER :: ic, istat, nc
245 : LOGICAL :: exists, is_open
246 :
247 132640 : IF (PRESENT(file_name)) THEN
248 : nc = SIZE(preconnected)
249 : ! Check for preconnected units
250 1143629 : DO ic = 3, nc ! Exclude the preconnected system units (< 3)
251 1143629 : IF (TRIM(preconnected(ic)%file_name) == TRIM(file_name)) THEN
252 17 : unit_number = preconnected(ic)%unit_number
253 17 : RETURN
254 : END IF
255 : END DO
256 : END IF
257 :
258 : ! Get a new unit number
259 314238 : DO unit_number = 1, max_unit_number
260 3343946 : IF (ANY(unit_number == preconnected(:)%unit_number)) CYCLE
261 302099 : INQUIRE (UNIT=unit_number, EXIST=exists, OPENED=is_open, IOSTAT=istat)
262 302099 : IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) RETURN
263 : END DO
264 :
265 132640 : unit_number = -1
266 :
267 : END FUNCTION get_unit_number
268 :
269 : ! **************************************************************************************************
270 : !> \brief Allocate and initialise the list of preconnected units
271 : !> \par History
272 : !> - Creation (22.02.2011,MK)
273 : !> \author Matthias Krack (MK)
274 : ! **************************************************************************************************
275 9284 : SUBROUTINE init_preconnection_list()
276 :
277 : INTEGER :: ic, nc
278 :
279 9284 : nc = SIZE(preconnected)
280 :
281 102124 : DO ic = 1, nc
282 92840 : preconnected(ic)%file_name = ""
283 102124 : preconnected(ic)%unit_number = -1
284 : END DO
285 :
286 : ! Define reserved unit numbers
287 9284 : preconnected(1)%file_name = "stdin"
288 9284 : preconnected(1)%unit_number = default_input_unit
289 9284 : preconnected(2)%file_name = "stdout"
290 9284 : preconnected(2)%unit_number = default_output_unit
291 :
292 9284 : END SUBROUTINE init_preconnection_list
293 :
294 : ! **************************************************************************************************
295 : !> \brief Opens the requested file using a free unit number
296 : !> \param file_name ...
297 : !> \param file_status ...
298 : !> \param file_form ...
299 : !> \param file_action ...
300 : !> \param file_position ...
301 : !> \param file_pad ...
302 : !> \param unit_number ...
303 : !> \param debug ...
304 : !> \param skip_get_unit_number ...
305 : !> \param file_access file access mode
306 : !> \author Matthias Krack (MK)
307 : ! **************************************************************************************************
308 132195 : SUBROUTINE open_file(file_name, file_status, file_form, file_action, &
309 : file_position, file_pad, unit_number, debug, &
310 : skip_get_unit_number, file_access)
311 :
312 : CHARACTER(LEN=*), INTENT(IN) :: file_name
313 : CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_status, file_form, file_action, &
314 : file_position, file_pad
315 : INTEGER, INTENT(INOUT) :: unit_number
316 : INTEGER, INTENT(IN), OPTIONAL :: debug
317 : LOGICAL, INTENT(IN), OPTIONAL :: skip_get_unit_number
318 : CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file_access
319 :
320 : CHARACTER(LEN=*), PARAMETER :: routineN = 'open_file'
321 :
322 : CHARACTER(LEN=11) :: access_string, action_string, current_action, current_form, &
323 : form_string, pad_string, position_string, status_string
324 : CHARACTER(LEN=2*default_path_length) :: message
325 : CHARACTER(LEN=default_path_length) :: cwd, iomsgstr, real_file_name
326 : INTEGER :: debug_unit, istat
327 : LOGICAL :: exists, get_a_new_unit, is_open
328 :
329 132195 : IF (PRESENT(file_access)) THEN
330 19 : access_string = TRIM(file_access)
331 : ELSE
332 132176 : access_string = "SEQUENTIAL"
333 : END IF
334 :
335 132195 : IF (PRESENT(file_status)) THEN
336 102307 : status_string = TRIM(file_status)
337 : ELSE
338 29888 : status_string = "OLD"
339 : END IF
340 :
341 132195 : IF (PRESENT(file_form)) THEN
342 93279 : form_string = TRIM(file_form)
343 : ELSE
344 38916 : form_string = "FORMATTED"
345 : END IF
346 :
347 132195 : IF (PRESENT(file_pad)) THEN
348 0 : pad_string = file_pad
349 0 : IF (form_string == "UNFORMATTED") THEN
350 : WRITE (UNIT=message, FMT="(A)") &
351 0 : "The PAD specifier is not allowed for an UNFORMATTED file."
352 0 : CPABORT(TRIM(message))
353 : END IF
354 : ELSE
355 132195 : pad_string = "YES"
356 : END IF
357 :
358 132195 : IF (PRESENT(file_action)) THEN
359 102307 : action_string = TRIM(file_action)
360 : ELSE
361 29888 : action_string = "READ"
362 : END IF
363 :
364 132195 : IF (PRESENT(file_position)) THEN
365 96641 : position_string = TRIM(file_position)
366 : ELSE
367 35554 : position_string = "REWIND"
368 : END IF
369 :
370 132195 : IF (PRESENT(debug)) THEN
371 138 : debug_unit = debug
372 : ELSE
373 132057 : debug_unit = 0 ! use default_output_unit for debugging
374 : END IF
375 :
376 132195 : IF (file_name(1:1) == " ") THEN
377 : WRITE (UNIT=message, FMT="(A)") &
378 0 : "The file name <"//TRIM(file_name)//"> has leading blanks."
379 0 : CPABORT(TRIM(message))
380 : END IF
381 :
382 132195 : IF (status_string == "OLD") THEN
383 37248 : real_file_name = discover_file(file_name)
384 : ELSE
385 : ! Strip leading and trailing blanks from file name
386 94947 : real_file_name = TRIM(ADJUSTL(file_name))
387 94947 : IF (LEN_TRIM(real_file_name) == 0) THEN
388 0 : CPABORT("A file name length of zero for a new file is invalid.")
389 : END IF
390 : END IF
391 :
392 : ! Check the specified input file name
393 132195 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exists, OPENED=is_open, IOSTAT=istat)
394 :
395 132195 : IF (istat /= 0) THEN
396 : WRITE (UNIT=message, FMT="(A,I0,A)") &
397 : "An error occurred inquiring the file <"//TRIM(real_file_name)// &
398 0 : "> (IOSTAT = ", istat, ")"
399 0 : CPABORT(TRIM(message))
400 132195 : ELSE IF (status_string == "OLD") THEN
401 37248 : IF (.NOT. exists) THEN
402 : WRITE (UNIT=message, FMT="(A)") &
403 : "The specified OLD file <"//TRIM(real_file_name)// &
404 : "> cannot be opened. It does not exist. "// &
405 0 : "Data directory path: "//TRIM(get_data_dir())
406 0 : CPABORT(TRIM(message))
407 : END IF
408 : END IF
409 :
410 : ! Open the specified input file
411 132195 : IF (is_open) THEN
412 : INQUIRE (FILE=TRIM(real_file_name), NUMBER=unit_number, &
413 2303 : ACTION=current_action, FORM=current_form)
414 2303 : IF (TRIM(position_string) == "REWIND") REWIND (UNIT=unit_number)
415 2303 : IF (TRIM(status_string) == "NEW") THEN
416 : CALL cp_abort(__LOCATION__, &
417 : "Attempt to re-open the existing OLD file <"// &
418 0 : TRIM(real_file_name)//"> with status attribute NEW.")
419 : END IF
420 2303 : IF (TRIM(current_form) /= TRIM(form_string)) THEN
421 : CALL cp_abort(__LOCATION__, &
422 : "Attempt to re-open the existing "// &
423 : TRIM(current_form)//" file <"//TRIM(real_file_name)// &
424 0 : "> as "//TRIM(form_string)//" file.")
425 : END IF
426 2303 : IF (TRIM(current_action) /= TRIM(action_string)) THEN
427 : CALL cp_abort(__LOCATION__, &
428 : "Attempt to re-open the existing file <"// &
429 : TRIM(real_file_name)//"> with the modified ACTION attribute "// &
430 : TRIM(action_string)//". The current ACTION attribute is "// &
431 0 : TRIM(current_action)//".")
432 : END IF
433 : ELSE
434 : ! Find an unused unit number
435 129892 : get_a_new_unit = .TRUE.
436 129892 : IF (PRESENT(skip_get_unit_number)) THEN
437 2807 : IF (skip_get_unit_number) get_a_new_unit = .FALSE.
438 : END IF
439 127085 : IF (get_a_new_unit) unit_number = get_unit_number(TRIM(real_file_name))
440 129892 : IF (unit_number < 1) THEN
441 : WRITE (UNIT=message, FMT="(A)") &
442 : "Cannot open the file <"//TRIM(real_file_name)// &
443 0 : ">, because no unused logical unit number could be obtained."
444 0 : CPABORT(TRIM(message))
445 : END IF
446 129892 : IF (TRIM(form_string) == "FORMATTED") THEN
447 : OPEN (UNIT=unit_number, &
448 : FILE=TRIM(real_file_name), &
449 : STATUS=TRIM(status_string), &
450 : ACCESS=TRIM(access_string), &
451 : FORM=TRIM(form_string), &
452 : POSITION=TRIM(position_string), &
453 : ACTION=TRIM(action_string), &
454 : PAD=TRIM(pad_string), &
455 : IOMSG=iomsgstr, &
456 110299 : IOSTAT=istat)
457 : ELSE
458 : OPEN (UNIT=unit_number, &
459 : FILE=TRIM(real_file_name), &
460 : STATUS=TRIM(status_string), &
461 : ACCESS=TRIM(access_string), &
462 : FORM=TRIM(form_string), &
463 : POSITION=TRIM(position_string), &
464 : ACTION=TRIM(action_string), &
465 : IOMSG=iomsgstr, &
466 19593 : IOSTAT=istat)
467 : END IF
468 129892 : IF (istat /= 0) THEN
469 0 : CALL m_getcwd(cwd)
470 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
471 : "An error occurred opening the file '"//TRIM(real_file_name)// &
472 0 : "' (UNIT = ", unit_number, ", IOSTAT = ", istat, "). "//TRIM(iomsgstr)//". "// &
473 0 : "Current working directory: "//TRIM(cwd)
474 :
475 0 : CPABORT(TRIM(message))
476 : END IF
477 : END IF
478 :
479 132195 : IF (debug_unit > 0) THEN
480 : INQUIRE (FILE=TRIM(real_file_name), OPENED=is_open, NUMBER=unit_number, &
481 : POSITION=position_string, NAME=message, ACCESS=access_string, &
482 138 : FORM=form_string, ACTION=action_string)
483 138 : WRITE (UNIT=debug_unit, FMT="(T2,A)") "BEGIN DEBUG "//TRIM(routineN)
484 138 : WRITE (UNIT=debug_unit, FMT="(T3,A,I0)") "NUMBER : ", unit_number
485 138 : WRITE (UNIT=debug_unit, FMT="(T3,A,L1)") "OPENED : ", is_open
486 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "NAME : "//TRIM(message)
487 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "POSITION: "//TRIM(position_string)
488 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "ACCESS : "//TRIM(access_string)
489 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "FORM : "//TRIM(form_string)
490 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "ACTION : "//TRIM(action_string)
491 138 : WRITE (UNIT=debug_unit, FMT="(T2,A)") "END DEBUG "//TRIM(routineN)
492 138 : CALL print_preconnection_list(debug_unit)
493 : END IF
494 :
495 132195 : END SUBROUTINE open_file
496 :
497 : ! **************************************************************************************************
498 : !> \brief Checks if file exists, considering also the file discovery mechanism.
499 : !> \param file_name ...
500 : !> \return ...
501 : !> \author Ole Schuett
502 : ! **************************************************************************************************
503 608 : FUNCTION file_exists(file_name) RESULT(exist)
504 : CHARACTER(LEN=*), INTENT(IN) :: file_name
505 : LOGICAL :: exist
506 :
507 : CHARACTER(LEN=default_path_length) :: real_file_name
508 :
509 608 : real_file_name = discover_file(file_name)
510 608 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exist)
511 :
512 608 : END FUNCTION file_exists
513 :
514 : ! **************************************************************************************************
515 : !> \brief Checks various locations for a file name.
516 : !> \param file_name ...
517 : !> \return ...
518 : !> \author Ole Schuett
519 : ! **************************************************************************************************
520 37878 : FUNCTION discover_file(file_name) RESULT(real_file_name)
521 : CHARACTER(LEN=*), INTENT(IN) :: file_name
522 : CHARACTER(LEN=default_path_length) :: real_file_name
523 :
524 : CHARACTER(LEN=default_path_length) :: candidate, data_dir
525 : INTEGER :: stat
526 : LOGICAL :: exists
527 :
528 : ! Strip leading and trailing blanks from file name
529 37878 : real_file_name = TRIM(ADJUSTL(file_name))
530 :
531 37878 : IF (LEN_TRIM(real_file_name) == 0) THEN
532 0 : CPABORT("A file name length of zero for an existing file is invalid.")
533 : END IF
534 :
535 : ! First try file name directly
536 37878 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exists, IOSTAT=stat)
537 51646 : IF (stat == 0 .AND. exists) RETURN
538 :
539 : ! Then try the data directory
540 13847 : data_dir = get_data_dir()
541 13847 : IF (LEN_TRIM(data_dir) > 0) THEN
542 13847 : candidate = join_paths(data_dir, real_file_name)
543 13847 : INQUIRE (FILE=TRIM(candidate), EXIST=exists, IOSTAT=stat)
544 13847 : IF (stat == 0 .AND. exists) THEN
545 13768 : real_file_name = candidate
546 13768 : RETURN
547 : END IF
548 : END IF
549 :
550 37878 : END FUNCTION discover_file
551 :
552 : ! **************************************************************************************************
553 : !> \brief Returns path of data directory if set, otherwise an empty string
554 : !> \return ...
555 : !> \author Ole Schuett
556 : ! **************************************************************************************************
557 18891 : FUNCTION get_data_dir() RESULT(res)
558 : CHARACTER(len=default_path_length) :: res
559 :
560 : CHARACTER(LEN=1, KIND=C_CHAR), DIMENSION(:), &
561 18891 : POINTER :: path_f
562 : INTEGER :: i
563 : TYPE(C_PTR) :: path_c
564 : INTERFACE
565 : FUNCTION get_data_dir_c() BIND(C, name="get_data_dir")
566 : IMPORT :: C_PTR
567 : TYPE(C_PTR) :: get_data_dir_c
568 : END FUNCTION get_data_dir_c
569 : END INTERFACE
570 :
571 18891 : path_c = get_data_dir_c()
572 37782 : CALL C_F_POINTER(path_c, path_f, shape=[default_path_length])
573 :
574 18891 : res = ""
575 491166 : DO i = 1, default_path_length
576 491166 : IF (path_f(i) == C_NULL_CHAR) RETURN
577 472275 : res(i:i) = path_f(i)
578 : END DO
579 :
580 0 : CPABORT("CP2K_DATA_DIR path is too long")
581 :
582 18891 : END FUNCTION get_data_dir
583 :
584 : ! **************************************************************************************************
585 : !> \brief Joins two file-paths, inserting '/' as needed.
586 : !> \param path1 ...
587 : !> \param path2 ...
588 : !> \return ...
589 : !> \author Ole Schuett
590 : ! **************************************************************************************************
591 13847 : FUNCTION join_paths(path1, path2) RESULT(joined_path)
592 : CHARACTER(LEN=*), INTENT(IN) :: path1, path2
593 : CHARACTER(LEN=default_path_length) :: joined_path
594 :
595 : INTEGER :: n
596 :
597 13847 : n = LEN_TRIM(path1)
598 13847 : IF (path2(1:1) == '/') THEN
599 0 : joined_path = path2
600 13847 : ELSE IF (n == 0 .OR. path1(n:n) == '/') THEN
601 0 : joined_path = TRIM(path1)//path2
602 : ELSE
603 13847 : joined_path = TRIM(path1)//'/'//path2
604 : END IF
605 13847 : END FUNCTION join_paths
606 :
607 : ! **************************************************************************************************
608 : !> \brief Print the list of preconnected units
609 : !> \param output_unit which unit to print to (optional)
610 : !> \par History
611 : !> - Creation (22.02.2011,MK)
612 : !> \author Matthias Krack (MK)
613 : ! **************************************************************************************************
614 138 : SUBROUTINE print_preconnection_list(output_unit)
615 : INTEGER, INTENT(IN), OPTIONAL :: output_unit
616 :
617 : INTEGER :: ic, nc, unit
618 :
619 138 : IF (PRESENT(output_unit)) THEN
620 138 : unit = output_unit
621 : ELSE
622 138 : unit = default_output_unit
623 : END IF
624 :
625 138 : nc = SIZE(preconnected)
626 :
627 138 : IF (output_unit > 0) THEN
628 :
629 : WRITE (UNIT=output_unit, FMT="(A,/,A)") &
630 138 : " LIST OF PRECONNECTED LOGICAL UNITS", &
631 276 : " Slot Unit number File name"
632 1518 : DO ic = 1, nc
633 1518 : IF (preconnected(ic)%unit_number > 0) THEN
634 : WRITE (UNIT=output_unit, FMT="(I6,3X,I6,8X,A)") &
635 391 : ic, preconnected(ic)%unit_number, &
636 782 : TRIM(preconnected(ic)%file_name)
637 : ELSE
638 : WRITE (UNIT=output_unit, FMT="(I6,17X,A)") &
639 989 : ic, "UNUSED"
640 : END IF
641 : END DO
642 : END IF
643 138 : END SUBROUTINE print_preconnection_list
644 :
645 0 : END MODULE cp_files
|
