(git:374b731)
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-2024 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 cpwarn(trim(message))
377 END IF
378
379 real_file_name = adjustl(file_name)
380 IF (status_string == "OLD") real_file_name = discover_file(file_name)
381
382 ! Check the specified input file name
383 INQUIRE (file=trim(real_file_name), exist=exists, opened=is_open, iostat=istat)
384
385 IF (istat /= 0) THEN
386 WRITE (unit=message, fmt="(A,I0,A)") &
387 "An error occurred inquiring the file <"//trim(real_file_name)// &
388 "> (IOSTAT = ", istat, ")"
389 cpabort(trim(message))
390 ELSE IF (status_string == "OLD") THEN
391 IF (.NOT. exists) THEN
392 WRITE (unit=message, fmt="(A)") &
393 "The specified OLD file <"//trim(real_file_name)// &
394 "> cannot be opened. It does not exist. "// &
395 "Data directory path: "//trim(get_data_dir())
396 cpabort(trim(message))
397 END IF
398 END IF
399
400 ! Open the specified input file
401 IF (is_open) THEN
402 INQUIRE (file=trim(real_file_name), number=unit_number, &
403 action=current_action, form=current_form)
404 IF (trim(position_string) == "REWIND") rewind(unit=unit_number)
405 IF (trim(status_string) == "NEW") THEN
406 CALL cp_abort(__location__, &
407 "Attempt to re-open the existing OLD file <"// &
408 trim(real_file_name)//"> with status attribute NEW.")
409 END IF
410 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 "> as "//trim(form_string)//" file.")
415 END IF
416 IF (trim(current_action) /= trim(action_string)) THEN
417 CALL cp_abort(__location__, &
418 "Attempt to re-open the existing file <"// &
419 trim(real_file_name)//"> with the modified ACTION attribute "// &
420 trim(action_string)//". The current ACTION attribute is "// &
421 trim(current_action)//".")
422 END IF
423 ELSE
424 ! Find an unused unit number
425 get_a_new_unit = .true.
426 IF (PRESENT(skip_get_unit_number)) THEN
427 IF (skip_get_unit_number) get_a_new_unit = .false.
428 END IF
429 IF (get_a_new_unit) unit_number = get_unit_number(trim(real_file_name))
430 IF (unit_number < 1) THEN
431 WRITE (unit=message, fmt="(A)") &
432 "Cannot open the file <"//trim(real_file_name)// &
433 ">, because no unused logical unit number could be obtained."
434 cpabort(trim(message))
435 END IF
436 IF (trim(form_string) == "FORMATTED") THEN
437 OPEN (unit=unit_number, &
438 file=trim(real_file_name), &
439 status=trim(status_string), &
440 access=trim(access_string), &
441 form=trim(form_string), &
442 position=trim(position_string), &
443 action=trim(action_string), &
444 pad=trim(pad_string), &
445 iomsg=iomsgstr, &
446 iostat=istat)
447 ELSE
448 OPEN (unit=unit_number, &
449 file=trim(real_file_name), &
450 status=trim(status_string), &
451 access=trim(access_string), &
452 form=trim(form_string), &
453 position=trim(position_string), &
454 action=trim(action_string), &
455 iomsg=iomsgstr, &
456 iostat=istat)
457 END IF
458 IF (istat /= 0) THEN
459 CALL m_getcwd(cwd)
460 WRITE (unit=message, fmt="(A,I0,A,I0,A)") &
461 "An error occurred opening the file '"//trim(real_file_name)// &
462 "' (UNIT = ", unit_number, ", IOSTAT = ", istat, "). "//trim(iomsgstr)//". "// &
463 "Current working directory: "//trim(cwd)
464
465 cpabort(trim(message))
466 END IF
467 END IF
468
469 IF (debug_unit > 0) THEN
470 INQUIRE (file=trim(real_file_name), opened=is_open, number=unit_number, &
471 position=position_string, name=message, access=access_string, &
472 form=form_string, action=action_string)
473 WRITE (unit=debug_unit, fmt="(T2,A)") "BEGIN DEBUG "//trim(routinen)
474 WRITE (unit=debug_unit, fmt="(T3,A,I0)") "NUMBER : ", unit_number
475 WRITE (unit=debug_unit, fmt="(T3,A,L1)") "OPENED : ", is_open
476 WRITE (unit=debug_unit, fmt="(T3,A)") "NAME : "//trim(message)
477 WRITE (unit=debug_unit, fmt="(T3,A)") "POSITION: "//trim(position_string)
478 WRITE (unit=debug_unit, fmt="(T3,A)") "ACCESS : "//trim(access_string)
479 WRITE (unit=debug_unit, fmt="(T3,A)") "FORM : "//trim(form_string)
480 WRITE (unit=debug_unit, fmt="(T3,A)") "ACTION : "//trim(action_string)
481 WRITE (unit=debug_unit, fmt="(T2,A)") "END DEBUG "//trim(routinen)
482 CALL print_preconnection_list(debug_unit)
483 END IF
484
485 END SUBROUTINE open_file
486
487! **************************************************************************************************
488!> \brief Checks if file exists, considering also the file discovery mechanism.
489!> \param file_name ...
490!> \return ...
491!> \author Ole Schuett
492! **************************************************************************************************
493 FUNCTION file_exists(file_name) RESULT(exist)
494 CHARACTER(LEN=*), INTENT(IN) :: file_name
495 LOGICAL :: exist
496
497 CHARACTER(LEN=default_path_length) :: real_file_name
498
499 real_file_name = discover_file(file_name)
500 INQUIRE (file=trim(real_file_name), exist=exist)
501 END FUNCTION file_exists
502
503! **************************************************************************************************
504!> \brief Checks various locations for a file name.
505!> \param file_name ...
506!> \return ...
507!> \author Ole Schuett
508! **************************************************************************************************
509 FUNCTION discover_file(file_name) RESULT(real_file_name)
510 CHARACTER(LEN=*), INTENT(IN) :: file_name
511 CHARACTER(LEN=default_path_length) :: real_file_name
512
513 CHARACTER(LEN=default_path_length) :: candidate, data_dir
514 INTEGER :: stat
515 LOGICAL :: exists
516
517 real_file_name = trim(adjustl(file_name))
518
519 ! first try file-name directly
520 INQUIRE (file=trim(real_file_name), exist=exists, iostat=stat)
521 IF (stat == 0 .AND. exists) RETURN
522
523 ! then try the data-dir
524 data_dir = get_data_dir()
525 IF (len_trim(data_dir) > 0) THEN
526 candidate = join_paths(data_dir, real_file_name)
527 INQUIRE (file=trim(candidate), exist=exists, iostat=stat)
528 IF (stat == 0 .AND. exists) THEN
529 real_file_name = candidate
530 RETURN
531 END IF
532 END IF
533
534 END FUNCTION discover_file
535
536! **************************************************************************************************
537!> \brief Returns path of data directory if set, otherwise an empty string
538!> \return ...
539!> \author Ole Schuett
540! **************************************************************************************************
541 FUNCTION get_data_dir() RESULT(data_dir_path)
542 CHARACTER(LEN=default_path_length) :: data_dir_path
543
544 INTEGER :: stat
545
546 CALL get_environment_variable("CP2K_DATA_DIR", data_dir_path, status=stat)
547 IF (stat == 0) RETURN
548
549#if defined(__DATA_DIR)
550 data_dir_path = __data_dir
551#else
552 data_dir_path = "" !data-dir not set
553#endif
554
555 END FUNCTION get_data_dir
556
557! **************************************************************************************************
558!> \brief Joins two file-paths, inserting '/' as needed.
559!> \param path1 ...
560!> \param path2 ...
561!> \return ...
562!> \author Ole Schuett
563! **************************************************************************************************
564 FUNCTION join_paths(path1, path2) RESULT(joined_path)
565 CHARACTER(LEN=*), INTENT(IN) :: path1, path2
566 CHARACTER(LEN=default_path_length) :: joined_path
567
568 INTEGER :: n
569
570 n = len_trim(path1)
571 IF (path2(1:1) == '/') THEN
572 joined_path = path2
573 ELSE IF (n == 0 .OR. path1(n:n) == '/') THEN
574 joined_path = trim(path1)//path2
575 ELSE
576 joined_path = trim(path1)//'/'//path2
577 END IF
578 END FUNCTION join_paths
579
580! **************************************************************************************************
581!> \brief Print the list of preconnected units
582!> \param output_unit which unit to print to (optional)
583!> \par History
584!> - Creation (22.02.2011,MK)
585!> \author Matthias Krack (MK)
586! **************************************************************************************************
587 SUBROUTINE print_preconnection_list(output_unit)
588 INTEGER, INTENT(IN), OPTIONAL :: output_unit
589
590 INTEGER :: ic, nc, unit
591
592 IF (PRESENT(output_unit)) THEN
593 unit = output_unit
594 ELSE
596 END IF
597
598 nc = SIZE(preconnected)
599
600 IF (output_unit > 0) THEN
601
602 WRITE (unit=output_unit, fmt="(A,/,A)") &
603 " LIST OF PRECONNECTED LOGICAL UNITS", &
604 " Slot Unit number File name"
605 DO ic = 1, nc
606 IF (preconnected(ic)%unit_number > 0) THEN
607 WRITE (unit=output_unit, fmt="(I6,3X,I6,8X,A)") &
608 ic, preconnected(ic)%unit_number, &
609 trim(preconnected(ic)%file_name)
610 ELSE
611 WRITE (unit=output_unit, fmt="(I6,17X,A)") &
612 ic, "UNUSED"
613 END IF
614 END DO
615 END IF
616 END SUBROUTINE print_preconnection_list
617
618END 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:510
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:494
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:542
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:45
integer, parameter, public default_input_unit
Definition machine.F:45
subroutine, public m_getcwd(curdir)
...
Definition machine.F:507