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 125830 : 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 125830 : keep_file_connection = .FALSE.
131 755 : IF (PRESENT(keep_preconnection)) keep_file_connection = keep_preconnection
132 :
133 125830 : INQUIRE (UNIT=unit_number, EXIST=exists, OPENED=is_open, IOSTAT=istat)
134 :
135 125830 : 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 125830 : 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 125830 : IF (is_open) THEN
150 : ! Refuse to close any preconnected system unit
151 125827 : 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 125827 : 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 125827 : IF (PRESENT(file_status)) THEN
163 85645 : status_string = TRIM(file_status)
164 : ELSE
165 40182 : status_string = "KEEP"
166 : END IF
167 : ! Optionally, keep this unit preconnected
168 125827 : INQUIRE (UNIT=unit_number, NAME=file_name, IOSTAT=istat)
169 125827 : 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 125827 : IF (keep_file_connection) THEN
177 755 : CALL assign_preconnection(file_name, unit_number)
178 : ELSE
179 125072 : CALL delete_preconnection(file_name, unit_number)
180 125072 : CLOSE (UNIT=unit_number, IOSTAT=istat, STATUS=TRIM(status_string))
181 125072 : 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 125830 : 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 125072 : 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 125072 : nc = SIZE(preconnected)
208 :
209 : ! Search for preconnection entry and delete it when found
210 1375630 : DO ic = 1, nc
211 1375630 : 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 125072 : 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 127722 : 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 127722 : IF (PRESENT(file_name)) THEN
245 : nc = SIZE(preconnected)
246 : ! Check for preconnected units
247 1103408 : DO ic = 3, nc ! Exclude the preconnected system units (< 3)
248 1103408 : 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 257230 : DO unit_number = 1, max_unit_number
257 2744674 : IF (ANY(unit_number == preconnected(:)%unit_number)) CYCLE
258 248019 : INQUIRE (UNIT=unit_number, EXIST=exists, OPENED=is_open, IOSTAT=istat)
259 248019 : IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) RETURN
260 : END DO
261 :
262 127722 : 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 8388 : SUBROUTINE init_preconnection_list()
273 :
274 : INTEGER :: ic, nc
275 :
276 8388 : nc = SIZE(preconnected)
277 :
278 92268 : DO ic = 1, nc
279 83880 : preconnected(ic)%file_name = ""
280 92268 : preconnected(ic)%unit_number = -1
281 : END DO
282 :
283 : ! Define reserved unit numbers
284 8388 : preconnected(1)%file_name = "stdin"
285 8388 : preconnected(1)%unit_number = default_input_unit
286 8388 : preconnected(2)%file_name = "stdout"
287 8388 : preconnected(2)%unit_number = default_output_unit
288 :
289 8388 : 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 127726 : 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 127726 : IF (PRESENT(file_access)) THEN
327 19 : access_string = TRIM(file_access)
328 : ELSE
329 127707 : access_string = "SEQUENTIAL"
330 : END IF
331 :
332 127726 : IF (PRESENT(file_status)) THEN
333 99623 : status_string = TRIM(file_status)
334 : ELSE
335 28103 : status_string = "OLD"
336 : END IF
337 :
338 127726 : IF (PRESENT(file_form)) THEN
339 90972 : form_string = TRIM(file_form)
340 : ELSE
341 36754 : form_string = "FORMATTED"
342 : END IF
343 :
344 127726 : 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 127726 : pad_string = "YES"
353 : END IF
354 :
355 127726 : IF (PRESENT(file_action)) THEN
356 99623 : action_string = TRIM(file_action)
357 : ELSE
358 28103 : action_string = "READ"
359 : END IF
360 :
361 127726 : IF (PRESENT(file_position)) THEN
362 95501 : position_string = TRIM(file_position)
363 : ELSE
364 32225 : position_string = "REWIND"
365 : END IF
366 :
367 127726 : IF (PRESENT(debug)) THEN
368 138 : debug_unit = debug
369 : ELSE
370 127588 : debug_unit = 0 ! use default_output_unit for debugging
371 : END IF
372 :
373 127726 : IF (file_name(1:1) == " ") THEN
374 : WRITE (UNIT=message, FMT="(A)") &
375 3 : "The file name <"//TRIM(file_name)//"> has leading blanks."
376 3 : CPWARN(TRIM(message))
377 : END IF
378 :
379 127726 : real_file_name = ADJUSTL(file_name)
380 127726 : IF (status_string == "OLD") real_file_name = discover_file(file_name)
381 :
382 : ! Check the specified input file name
383 127726 : INQUIRE (FILE=TRIM(real_file_name), EXIST=exists, OPENED=is_open, IOSTAT=istat)
384 :
385 127726 : IF (istat /= 0) THEN
386 : WRITE (UNIT=message, FMT="(A,I0,A)") &
387 : "An error occurred inquiring the file <"//TRIM(real_file_name)// &
388 0 : "> (IOSTAT = ", istat, ")"
389 0 : CPABORT(TRIM(message))
390 127726 : ELSE IF (status_string == "OLD") THEN
391 33679 : 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 0 : "Data directory path: "//TRIM(get_data_dir())
396 0 : CPABORT(TRIM(message))
397 : END IF
398 : END IF
399 :
400 : ! Open the specified input file
401 127726 : IF (is_open) THEN
402 : INQUIRE (FILE=TRIM(real_file_name), NUMBER=unit_number, &
403 2303 : ACTION=current_action, FORM=current_form)
404 2303 : IF (TRIM(position_string) == "REWIND") REWIND (UNIT=unit_number)
405 2303 : IF (TRIM(status_string) == "NEW") THEN
406 : CALL cp_abort(__LOCATION__, &
407 : "Attempt to re-open the existing OLD file <"// &
408 0 : TRIM(real_file_name)//"> with status attribute NEW.")
409 : END IF
410 2303 : 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 0 : "> as "//TRIM(form_string)//" file.")
415 : END IF
416 2303 : 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 0 : TRIM(current_action)//".")
422 : END IF
423 : ELSE
424 : ! Find an unused unit number
425 125423 : get_a_new_unit = .TRUE.
426 125423 : IF (PRESENT(skip_get_unit_number)) THEN
427 2807 : IF (skip_get_unit_number) get_a_new_unit = .FALSE.
428 : END IF
429 122616 : IF (get_a_new_unit) unit_number = get_unit_number(TRIM(real_file_name))
430 125423 : IF (unit_number < 1) THEN
431 : WRITE (UNIT=message, FMT="(A)") &
432 : "Cannot open the file <"//TRIM(real_file_name)// &
433 0 : ">, because no unused logical unit number could be obtained."
434 0 : CPABORT(TRIM(message))
435 : END IF
436 125423 : 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 108210 : 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 17213 : IOSTAT=istat)
457 : END IF
458 125423 : IF (istat /= 0) THEN
459 0 : 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 0 : "' (UNIT = ", unit_number, ", IOSTAT = ", istat, "). "//TRIM(iomsgstr)//". "// &
463 0 : "Current working directory: "//TRIM(cwd)
464 :
465 0 : CPABORT(TRIM(message))
466 : END IF
467 : END IF
468 :
469 127726 : 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 138 : FORM=form_string, ACTION=action_string)
473 138 : WRITE (UNIT=debug_unit, FMT="(T2,A)") "BEGIN DEBUG "//TRIM(routineN)
474 138 : WRITE (UNIT=debug_unit, FMT="(T3,A,I0)") "NUMBER : ", unit_number
475 138 : WRITE (UNIT=debug_unit, FMT="(T3,A,L1)") "OPENED : ", is_open
476 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "NAME : "//TRIM(message)
477 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "POSITION: "//TRIM(position_string)
478 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "ACCESS : "//TRIM(access_string)
479 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "FORM : "//TRIM(form_string)
480 138 : WRITE (UNIT=debug_unit, FMT="(T3,A)") "ACTION : "//TRIM(action_string)
481 138 : WRITE (UNIT=debug_unit, FMT="(T2,A)") "END DEBUG "//TRIM(routineN)
482 138 : CALL print_preconnection_list(debug_unit)
483 : END IF
484 :
485 127726 : 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 496 : 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 496 : real_file_name = discover_file(file_name)
500 496 : INQUIRE (FILE=TRIM(real_file_name), exist=exist)
501 496 : 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 34205 : 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 34205 : real_file_name = TRIM(ADJUSTL(file_name))
518 :
519 : ! first try file-name directly
520 34205 : INQUIRE (file=TRIM(real_file_name), exist=exists, iostat=stat)
521 46669 : IF (stat == 0 .AND. exists) RETURN
522 :
523 : ! then try the data-dir
524 12487 : data_dir = get_data_dir()
525 12487 : IF (LEN_TRIM(data_dir) > 0) THEN
526 12487 : candidate = join_paths(data_dir, real_file_name)
527 12487 : INQUIRE (file=TRIM(candidate), exist=exists, iostat=stat)
528 12487 : IF (stat == 0 .AND. exists) THEN
529 12464 : real_file_name = candidate
530 12464 : RETURN
531 : END IF
532 : END IF
533 :
534 34205 : 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 17083 : FUNCTION get_data_dir() RESULT(data_dir_path)
542 : CHARACTER(LEN=default_path_length) :: data_dir_path
543 :
544 : INTEGER :: stat
545 :
546 17083 : CALL GET_ENVIRONMENT_VARIABLE("CP2K_DATA_DIR", data_dir_path, status=stat)
547 17083 : IF (stat == 0) RETURN
548 :
549 : #if defined(__DATA_DIR)
550 17083 : 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 12487 : 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 12487 : n = LEN_TRIM(path1)
571 12487 : IF (path2(1:1) == '/') THEN
572 0 : joined_path = path2
573 12487 : ELSE IF (n == 0 .OR. path1(n:n) == '/') THEN
574 0 : joined_path = TRIM(path1)//path2
575 : ELSE
576 12487 : joined_path = TRIM(path1)//'/'//path2
577 : END IF
578 12487 : 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 138 : SUBROUTINE print_preconnection_list(output_unit)
588 : INTEGER, INTENT(IN), OPTIONAL :: output_unit
589 :
590 : INTEGER :: ic, nc, unit
591 :
592 138 : IF (PRESENT(output_unit)) THEN
593 138 : unit = output_unit
594 : ELSE
595 138 : unit = default_output_unit
596 : END IF
597 :
598 138 : nc = SIZE(preconnected)
599 :
600 138 : IF (output_unit > 0) THEN
601 :
602 : WRITE (UNIT=output_unit, FMT="(A,/,A)") &
603 138 : " LIST OF PRECONNECTED LOGICAL UNITS", &
604 276 : " Slot Unit number File name"
605 1518 : DO ic = 1, nc
606 1518 : IF (preconnected(ic)%unit_number > 0) THEN
607 : WRITE (UNIT=output_unit, FMT="(I6,3X,I6,8X,A)") &
608 391 : ic, preconnected(ic)%unit_number, &
609 782 : TRIM(preconnected(ic)%file_name)
610 : ELSE
611 : WRITE (UNIT=output_unit, FMT="(I6,17X,A)") &
612 989 : ic, "UNUSED"
613 : END IF
614 : END DO
615 : END IF
616 138 : END SUBROUTINE print_preconnection_list
617 :
618 0 : END MODULE cp_files
|
