Line data Source code
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 : ! **************************************************************************************************
16 : MODULE cp_files
17 :
18 : USE kinds, ONLY: default_path_length
19 : USE machine, ONLY: default_input_unit,&
20 : default_output_unit,&
21 : m_getcwd
22 : #include "../base/base_uses.f90"
23 :
24 : IMPLICIT NONE
25 :
26 : PRIVATE
27 :
28 : PUBLIC :: close_file, &
29 : init_preconnection_list, &
30 : open_file, &
31 : get_unit_number, &
32 : file_exists, &
33 : get_data_dir, &
34 : discover_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 :
49 : CONTAINS
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 755 : 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 755 : IF ((unit_number < 1) .OR. (unit_number > max_unit_number)) THEN
67 0 : CPABORT("An invalid logical unit number was specified.")
68 : END IF
69 :
70 755 : IF (LEN_TRIM(file_name) == 0) THEN
71 0 : CPABORT("No valid file name was specified.")
72 : END IF
73 :
74 : nc = SIZE(preconnected)
75 :
76 : ! Check if a preconnection already exists
77 3011 : DO ic = 1, nc
78 3011 : IF (TRIM(preconnected(ic)%file_name) == TRIM(file_name)) THEN
79 : ! Return if the entry already exists
80 728 : IF (preconnected(ic)%unit_number == unit_number) THEN
81 : RETURN
82 : ELSE
83 0 : CALL print_preconnection_list()
84 : CALL cp_abort(__LOCATION__, &
85 : "Attempt to connect the already connected file <"// &
86 0 : TRIM(file_name)//"> to another unit.")
87 : END IF
88 : END IF
89 : END DO
90 :
91 : ! Search for an unused entry
92 87 : islot = -1
93 87 : DO ic = 1, nc
94 87 : IF (preconnected(ic)%unit_number == -1) THEN
95 : islot = ic
96 : EXIT
97 : END IF
98 : END DO
99 :
100 27 : IF (islot == -1) THEN
101 0 : CALL print_preconnection_list()
102 0 : CPABORT("No free slot found in the list of preconnected units.")
103 : END IF
104 :
105 27 : preconnected(islot)%file_name = TRIM(file_name)
106 27 : preconnected(islot)%unit_number = unit_number
107 :
108 755 : 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 126849 : 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 126849 : keep_file_connection = .FALSE.
131 755 : IF (PRESENT(keep_preconnection)) keep_file_connection = keep_preconnection
132 :
133 126849 : INQUIRE (UNIT=unit_number, EXIST=exists, OPENED=is_open, IOSTAT=istat)
134 :
135 126849 : IF (istat /= 0) THEN
136 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
137 0 : "An error occurred inquiring the unit with the number ", unit_number, &
138 0 : " (IOSTAT = ", istat, ")"
139 0 : CPABORT(TRIM(message))
140 126849 : ELSE IF (.NOT. exists) THEN
141 : WRITE (UNIT=message, FMT="(A,I0,A)") &
142 0 : "The specified unit number ", unit_number, &
143 0 : " cannot be closed, because it does not exist."
144 0 : CPABORT(TRIM(message))
145 : END IF
146 :
147 : ! Close the specified file
148 :
149 126849 : IF (is_open) THEN
150 : ! Refuse to close any preconnected system unit
151 126846 : IF (unit_number == default_input_unit) THEN
152 : WRITE (UNIT=message, FMT="(A,I0)") &
153 0 : "Attempt to close the default input unit number ", unit_number
154 0 : CPABORT(TRIM(message))
155 : END IF
156 126846 : IF (unit_number == default_output_unit) THEN
157 : WRITE (UNIT=message, FMT="(A,I0)") &
158 0 : "Attempt to close the default output unit number ", unit_number
159 0 : CPABORT(TRIM(message))
160 : END IF
161 : ! Define status after closing the file
162 126846 : IF (PRESENT(file_status)) THEN
163 85538 : status_string = TRIM(file_status)
164 : ELSE
165 41308 : status_string = "KEEP"
166 : END IF
167 : ! Optionally, keep this unit preconnected
168 126846 : INQUIRE (UNIT=unit_number, NAME=file_name, IOSTAT=istat)
169 126846 : IF (istat /= 0) THEN
170 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
171 0 : "An error occurred inquiring the unit with the number ", unit_number, &
172 0 : " (IOSTAT = ", istat, ")."
173 0 : CPABORT(TRIM(message))
174 : END IF
175 : ! Manage preconnections
176 126846 : IF (keep_file_connection) THEN
177 755 : CALL assign_preconnection(file_name, unit_number)
178 : ELSE
179 126091 : CALL delete_preconnection(file_name, unit_number)
180 126091 : CLOSE (UNIT=unit_number, IOSTAT=istat, STATUS=TRIM(status_string))
181 126091 : IF (istat /= 0) THEN
182 : WRITE (UNIT=message, FMT="(A,I0,A,I0,A)") &
183 0 : "An error occurred closing the file with the logical unit number ", &
184 0 : unit_number, " (IOSTAT = ", istat, ")."
185 0 : CPABORT(TRIM(message))
186 : END IF
187 : END IF
188 : END IF
189 :
190 126849 : 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 126091 : 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 126091 : nc = SIZE(preconnected)
208 :
209 : ! Search for preconnection entry and delete it when found
210 1386839 : DO ic = 1, nc
211 1386839 : IF (TRIM(preconnected(ic)%file_name) == TRIM(file_name)) THEN
212 21 : IF (preconnected(ic)%unit_number == unit_number) THEN
213 21 : preconnected(ic)%file_name = ""
214 21 : preconnected(ic)%unit_number = -1
215 21 : EXIT
216 : ELSE
217 0 : CALL print_preconnection_list()
218 : CALL cp_abort(__LOCATION__, &
219 : "Attempt to disconnect the file <"// &
220 : TRIM(file_name)// &
221 0 : "> from an unlisted unit.")
222 : END IF
223 : END IF
224 : END DO
225 :
226 126091 : 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 128813 : 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 128813 : IF (PRESENT(file_name)) THEN
245 : nc = SIZE(preconnected)
246 : ! Check for preconnected units
247 1112579 : DO ic = 3, nc ! Exclude the preconnected system units (< 3)
248 1112579 : IF (TRIM(preconnected(ic)%file_name) == TRIM(file_name)) THEN
249 17 : unit_number = preconnected(ic)%unit_number
250 17 : RETURN
251 : END IF
252 : END DO
253 : END IF
254 :
255 : ! Get a new unit number
256 257546 : DO unit_number = 1, max_unit_number
257 2748150 : IF (ANY(unit_number == preconnected(:)%unit_number)) CYCLE
258 248335 : INQUIRE (UNIT=unit_number, EXIST=exists, OPENED=is_open, IOSTAT=istat)
259 248335 : IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) RETURN
260 : END DO
261 :
262 128813 : 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 : ! **************************************************************************************************
272 8530 : SUBROUTINE init_preconnection_list()
273 :
274 : INTEGER :: ic, nc
275 :
276 8530 : nc = SIZE(preconnected)
277 :
278 93830 : DO ic = 1, nc
279 85300 : preconnected(ic)%file_name = ""
280 93830 : preconnected(ic)%unit_number = -1
281 : END DO
282 :
283 : ! Define reserved unit numbers
284 8530 : preconnected(1)%file_name = "stdin"
285 8530 : preconnected(1)%unit_number = default_input_unit
286 8530 : preconnected(2)%file_name = "stdout"
287 8530 : preconnected(2)%unit_number = default_output_unit
288 :
289 8530 : 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 128745 : 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 128745 : IF (PRESENT(file_access)) THEN
327 19 : access_string = TRIM(file_access)
328 : ELSE
329 128726 : access_string = "SEQUENTIAL"
330 : END IF
331 :
332 128745 : IF (PRESENT(file_status)) THEN
333 100195 : status_string = TRIM(file_status)
334 : ELSE
335 28550 : status_string = "OLD"
336 : END IF
337 :
338 128745 : IF (PRESENT(file_form)) THEN
339 91379 : form_string = TRIM(file_form)
340 : ELSE
341 37366 : form_string = "FORMATTED"
342 : END IF
343 :
344 128745 : IF (PRESENT(file_pad)) THEN
345 0 : pad_string = file_pad
346 0 : IF (form_string == "UNFORMATTED") THEN
347 : WRITE (UNIT=message, FMT="(A)") &
348 0 : "The PAD specifier is not allowed for an UNFORMATTED file."
349 0 : CPABORT(TRIM(message))
350 : END IF
351 : ELSE
352 128745 : pad_string = "YES"
353 : END IF
354 :
355 128745 : IF (PRESENT(file_action)) THEN
356 100195 : action_string = TRIM(file_action)
357 : ELSE
358 28550 : action_string = "READ"
359 : END IF
360 :
361 128745 : IF (PRESENT(file_position)) THEN
362 96050 : position_string = TRIM(file_position)
363 : ELSE
364 32695 : position_string = "REWIND"
365 : END IF
366 :
367 128745 : IF (PRESENT(debug)) THEN
368 138 : debug_unit = debug
369 : ELSE
370 128607 : debug_unit = 0 ! use default_output_unit for debugging
371 : END IF
372 :
373 128745 : IF (file_name(1:1) == " ") THEN
374 : WRITE (UNIT=message, FMT="(A)") &
375 0 : "The file name <"//TRIM(file_name)//"> has leading blanks."
376 0 : CPABORT(TRIM(message))
377 : END IF
378 :
379 128745 : IF (status_string == "OLD") THEN
380 34539 : real_file_name = discover_file(file_name)
381 : ELSE
382 : ! Strip leading and trailing blanks from file name
383 94206 : real_file_name = TRIM(ADJUSTL(file_name))
384 94206 : IF (LEN_TRIM(real_file_name) == 0) THEN
385 0 : 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 128745 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exists, OPENED=is_open, IOSTAT=istat)
391 :
392 128745 : IF (istat /= 0) THEN
393 : WRITE (UNIT=message, FMT="(A,I0,A)") &
394 : "An error occurred inquiring the file <"//TRIM(real_file_name)// &
395 0 : "> (IOSTAT = ", istat, ")"
396 0 : CPABORT(TRIM(message))
397 128745 : ELSE IF (status_string == "OLD") THEN
398 34539 : 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 0 : "Data directory path: "//TRIM(get_data_dir())
403 0 : CPABORT(TRIM(message))
404 : END IF
405 : END IF
406 :
407 : ! Open the specified input file
408 128745 : IF (is_open) THEN
409 : INQUIRE (FILE=TRIM(real_file_name), NUMBER=unit_number, &
410 2303 : ACTION=current_action, FORM=current_form)
411 2303 : IF (TRIM(position_string) == "REWIND") REWIND (UNIT=unit_number)
412 2303 : IF (TRIM(status_string) == "NEW") THEN
413 : CALL cp_abort(__LOCATION__, &
414 : "Attempt to re-open the existing OLD file <"// &
415 0 : TRIM(real_file_name)//"> with status attribute NEW.")
416 : END IF
417 2303 : 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 0 : "> as "//TRIM(form_string)//" file.")
422 : END IF
423 2303 : 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 0 : TRIM(current_action)//".")
429 : END IF
430 : ELSE
431 : ! Find an unused unit number
432 126442 : get_a_new_unit = .TRUE.
433 126442 : IF (PRESENT(skip_get_unit_number)) THEN
434 2807 : IF (skip_get_unit_number) get_a_new_unit = .FALSE.
435 : END IF
436 123635 : IF (get_a_new_unit) unit_number = get_unit_number(TRIM(real_file_name))
437 126442 : IF (unit_number < 1) THEN
438 : WRITE (UNIT=message, FMT="(A)") &
439 : "Cannot open the file <"//TRIM(real_file_name)// &
440 0 : ">, because no unused logical unit number could be obtained."
441 0 : CPABORT(TRIM(message))
442 : END IF
443 126442 : 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 108078 : 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 18364 : IOSTAT=istat)
464 : END IF
465 126442 : IF (istat /= 0) THEN
466 0 : 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 0 : "' (UNIT = ", unit_number, ", IOSTAT = ", istat, "). "//TRIM(iomsgstr)//". "// &
470 0 : "Current working directory: "//TRIM(cwd)
471 :
472 0 : CPABORT(TRIM(message))
473 : END IF
474 : END IF
475 :
476 128745 : 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 138 : FORM=form_string, ACTION=action_string)
480 138 : WRITE (UNIT=debug_unit, FMT="(T2,A)") "BEGIN DEBUG "//TRIM(routineN)
481 138 : WRITE (UNIT=debug_unit, FMT="(T3,A,I0)") "NUMBER : ", unit_number
482 138 : WRITE (UNIT=debug_unit, FMT="(T3,A,L1)") "OPENED : ", is_open
483 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "NAME : "//TRIM(message)
484 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "POSITION: "//TRIM(position_string)
485 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "ACCESS : "//TRIM(access_string)
486 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "FORM : "//TRIM(form_string)
487 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "ACTION : "//TRIM(action_string)
488 138 : WRITE (UNIT=debug_unit, FMT="(T2,A)") "END DEBUG "//TRIM(routineN)
489 138 : CALL print_preconnection_list(debug_unit)
490 : END IF
491 :
492 128745 : 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 534 : 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 534 : real_file_name = discover_file(file_name)
507 534 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exist)
508 :
509 534 : 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 35097 : 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 35097 : real_file_name = TRIM(ADJUSTL(file_name))
527 :
528 35097 : IF (LEN_TRIM(real_file_name) == 0) THEN
529 0 : CPABORT("A file name length of zero for an existing file is invalid.")
530 : END IF
531 :
532 : ! First try file name directly
533 35097 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exists, IOSTAT=stat)
534 47910 : IF (stat == 0 .AND. exists) RETURN
535 :
536 : ! Then try the data directory
537 12860 : data_dir = get_data_dir()
538 12860 : IF (LEN_TRIM(data_dir) > 0) THEN
539 12860 : candidate = join_paths(data_dir, real_file_name)
540 12860 : INQUIRE (FILE=TRIM(candidate), EXIST=exists, IOSTAT=stat)
541 12860 : IF (stat == 0 .AND. exists) THEN
542 12813 : real_file_name = candidate
543 12813 : RETURN
544 : END IF
545 : END IF
546 :
547 35097 : 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 17527 : FUNCTION get_data_dir() RESULT(data_dir_path)
555 : CHARACTER(LEN=default_path_length) :: data_dir_path
556 :
557 : INTEGER :: stat
558 :
559 17527 : CALL GET_ENVIRONMENT_VARIABLE("CP2K_DATA_DIR", data_dir_path, status=stat)
560 17527 : IF (stat == 0) RETURN
561 :
562 : #if defined(__DATA_DIR)
563 17527 : 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 12860 : 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 12860 : n = LEN_TRIM(path1)
584 12860 : IF (path2(1:1) == '/') THEN
585 0 : joined_path = path2
586 12860 : ELSE IF (n == 0 .OR. path1(n:n) == '/') THEN
587 0 : joined_path = TRIM(path1)//path2
588 : ELSE
589 12860 : joined_path = TRIM(path1)//'/'//path2
590 : END IF
591 12860 : 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 138 : SUBROUTINE print_preconnection_list(output_unit)
601 : INTEGER, INTENT(IN), OPTIONAL :: output_unit
602 :
603 : INTEGER :: ic, nc, unit
604 :
605 138 : IF (PRESENT(output_unit)) THEN
606 138 : unit = output_unit
607 : ELSE
608 138 : unit = default_output_unit
609 : END IF
610 :
611 138 : nc = SIZE(preconnected)
612 :
613 138 : IF (output_unit > 0) THEN
614 :
615 : WRITE (UNIT=output_unit, FMT="(A,/,A)") &
616 138 : " LIST OF PRECONNECTED LOGICAL UNITS", &
617 276 : " Slot Unit number File name"
618 1518 : DO ic = 1, nc
619 1518 : IF (preconnected(ic)%unit_number > 0) THEN
620 : WRITE (UNIT=output_unit, FMT="(I6,3X,I6,8X,A)") &
621 391 : ic, preconnected(ic)%unit_number, &
622 782 : TRIM(preconnected(ic)%file_name)
623 : ELSE
624 : WRITE (UNIT=output_unit, FMT="(I6,17X,A)") &
625 989 : ic, "UNUSED"
626 : END IF
627 : END DO
628 : END IF
629 138 : END SUBROUTINE print_preconnection_list
630 :
631 0 : END MODULE cp_files
|
