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 cpwarn(trim(message))
379 real_file_name = adjustl(file_name)
380 IF (status_string ==
"OLD") real_file_name =
discover_file(file_name)
383 INQUIRE (file=trim(real_file_name), exist=exists, opened=is_open, iostat=istat)
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. "// &
396 cpabort(trim(message))
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.")
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.")
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)//
".")
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.
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))
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), &
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), &
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)
465 cpabort(trim(message))
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)
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.