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