118 SUBROUTINE close_file(unit_number, file_status, keep_preconnection)
120 INTEGER,
INTENT(IN) :: unit_number
121 CHARACTER(LEN=*),
INTENT(IN),
OPTIONAL :: file_status
122 LOGICAL,
INTENT(IN),
OPTIONAL :: keep_preconnection
124 CHARACTER(LEN=2*default_path_length) :: message
125 CHARACTER(LEN=6) :: status_string
126 CHARACTER(LEN=default_path_length) :: file_name
128 LOGICAL :: exists, is_open, keep_file_connection
130 keep_file_connection = .false.
131 IF (
PRESENT(keep_preconnection)) keep_file_connection = keep_preconnection
133 INQUIRE (unit=unit_number, exist=exists, opened=is_open, iostat=istat)
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))
152 WRITE (unit=message, fmt=
"(A,I0)") &
153 "Attempt to close the default input unit number ", unit_number
154 cpabort(trim(message))
157 WRITE (unit=message, fmt=
"(A,I0)") &
158 "Attempt to close the default output unit number ", unit_number
159 cpabort(trim(message))
162 IF (
PRESENT(file_status))
THEN
163 status_string = trim(file_status)
165 status_string =
"KEEP"
168 INQUIRE (unit=unit_number, name=file_name, iostat=istat)
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))
176 IF (keep_file_connection)
THEN
177 CALL assign_preconnection(file_name, unit_number)
179 CALL delete_preconnection(file_name, unit_number)
180 CLOSE (unit=unit_number, iostat=istat, status=trim(status_string))
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))
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)
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
317 CHARACTER(LEN=*),
PARAMETER :: routinen =
'open_file'
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
326 IF (
PRESENT(file_access))
THEN
327 access_string = trim(file_access)
329 access_string =
"SEQUENTIAL"
332 IF (
PRESENT(file_status))
THEN
333 status_string = trim(file_status)
335 status_string =
"OLD"
338 IF (
PRESENT(file_form))
THEN
339 form_string = trim(file_form)
341 form_string =
"FORMATTED"
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))
355 IF (
PRESENT(file_action))
THEN
356 action_string = trim(file_action)
358 action_string =
"READ"
361 IF (
PRESENT(file_position))
THEN
362 position_string = trim(file_position)
364 position_string =
"REWIND"
367 IF (
PRESENT(debug))
THEN
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))
379 IF (status_string ==
"OLD")
THEN
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.")
390 INQUIRE (file=trim(real_file_name), exist=exists, opened=is_open, iostat=istat)
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. "// &
403 cpabort(trim(message))
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.")
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.")
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)//
".")
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.
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))
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), &
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), &
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)
472 cpabort(trim(message))
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)
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.