cp_files.F

Go to the documentation of this file.

!--------------------------------------------------------------------------------------------------!
!   CP2K: A general program to perform molecular dynamics simulations                              !
!   Copyright 2000-2024 CP2K developers group <https://cp2k.org>                                   !
!                                                                                                  !
!   SPDX-License-Identifier: GPL-2.0-or-later                                                      !
!--------------------------------------------------------------------------------------------------!
 
! **************************************************************************************************
!> \brief Utility routines to open and close files. Tracking of preconnections.
!> \par History
!>      - Creation CP2K_WORKSHOP 1.0 TEAM
!>      - Revised (18.02.2011,MK)
!>      - Enhanced error checking (22.02.2011,MK)
!> \author Matthias Krack (MK)
! **************************************************************************************************
MODULE cp_files
 
   USE kinds,                           ONLY: default_path_length
   USE machine,                         ONLY: default_input_unit,&
                                              default_output_unit,&
                                              m_getcwd
#include "../base/base_uses.f90"
 
   IMPLICIT NONE
 
   PRIVATE
 
   PUBLIC :: close_file, &
             init_preconnection_list, &
             open_file, &
             get_unit_number, &
             file_exists, &
             get_data_dir, &
             discover_file
 
   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_files'
 
   INTEGER, PARAMETER :: max_preconnections = 10, &
                         max_unit_number = 999
 
   TYPE preconnection_type
      PRIVATE
      CHARACTER(LEN=default_path_length) :: file_name = ""
      INTEGER                            :: unit_number = -1
   END TYPE preconnection_type
 
   TYPE(preconnection_type), DIMENSION(max_preconnections) :: preconnected
 
CONTAINS
 
! **************************************************************************************************
!> \brief Add an entry to the list of preconnected units
!> \param file_name ...
!> \param unit_number ...
!> \par History
!>      - Creation (22.02.2011,MK)
!> \author Matthias Krack (MK)
! **************************************************************************************************
   SUBROUTINE assign_preconnection(file_name, unit_number)
 
      CHARACTER(LEN=*), INTENT(IN)                       :: file_name
      INTEGER, INTENT(IN)                                :: unit_number
 
      INTEGER                                            :: ic, islot, nc
 
      IF ((unit_number < 1) .OR. (unit_number > max_unit_number)) THEN
         cpabort("An invalid logical unit number was specified.")
      END IF
 
      IF (len_trim(file_name) == 0) THEN
         cpabort("No valid file name was specified")
      END IF
 
      nc = SIZE(preconnected)
 
      ! Check if a preconnection already exists
      DO ic = 1, nc
         IF (trim(preconnected(ic)%file_name) == trim(file_name)) THEN
            ! Return if the entry already exists
            IF (preconnected(ic)%unit_number == unit_number) THEN
               RETURN
            ELSE
               CALL print_preconnection_list()
               CALL cp_abort(__location__, &
                             "Attempt to connect the already connected file <"// &
                             trim(file_name)//"> to another unit")
            END IF
         END IF
      END DO
 
      ! Search for an unused entry
      islot = -1
      DO ic = 1, nc
         IF (preconnected(ic)%unit_number == -1) THEN
            islot = ic
            EXIT
         END IF
      END DO
 
      IF (islot == -1) THEN
         CALL print_preconnection_list()
         cpabort("No free slot found in the list of preconnected units")
      END IF
 
      preconnected(islot)%file_name = trim(file_name)
      preconnected(islot)%unit_number = unit_number
 
   END SUBROUTINE assign_preconnection
 
! **************************************************************************************************
!> \brief Close an open file given by its logical unit number.
!>        Optionally, keep the file and unit preconnected.
!> \param unit_number ...
!> \param file_status ...
!> \param keep_preconnection ...
!> \author Matthias Krack (MK)
! **************************************************************************************************
   SUBROUTINE close_file(unit_number, file_status, keep_preconnection)
 
      INTEGER, INTENT(IN)                                :: unit_number
      CHARACTER(LEN=*), INTENT(IN), OPTIONAL             :: file_status
      LOGICAL, INTENT(IN), OPTIONAL                      :: keep_preconnection
 
      CHARACTER(LEN=2*default_path_length)               :: message
      CHARACTER(LEN=6)                                   :: status_string
      CHARACTER(LEN=default_path_length)                 :: file_name
      INTEGER                                            :: istat
      LOGICAL                                            :: exists, is_open, keep_file_connection
 
      keep_file_connection = .false.
      IF (PRESENT(keep_preconnection)) keep_file_connection = keep_preconnection
 
      INQUIRE (unit=unit_number, exist=exists, opened=is_open, iostat=istat)
 
      IF (istat /= 0) THEN
         WRITE (unit=message, fmt="(A,I0,A,I0,A)") &
            "An error occurred inquiring the unit with the number ", unit_number, &
            " (IOSTAT = ", istat, ")"
         cpabort(trim(message))
      ELSE IF (.NOT. exists) THEN
         WRITE (unit=message, fmt="(A,I0,A)") &
            "The specified unit number ", unit_number, &
            " cannot be closed, because it does not exist."
         cpabort(trim(message))
      END IF
 
      ! Close the specified file
 
      IF (is_open) THEN
         ! Refuse to close any preconnected system unit
         IF (unit_number == default_input_unit) THEN
            WRITE (unit=message, fmt="(A,I0)") &
               "Attempt to close the default input unit number ", unit_number
            cpabort(trim(message))
         END IF
         IF (unit_number == default_output_unit) THEN
            WRITE (unit=message, fmt="(A,I0)") &
               "Attempt to close the default output unit number ", unit_number
            cpabort(trim(message))
         END IF
         ! Define status after closing the file
         IF (PRESENT(file_status)) THEN
            status_string = trim(file_status)
         ELSE
            status_string = "KEEP"
         END IF
         ! Optionally, keep this unit preconnected
         INQUIRE (unit=unit_number, name=file_name, iostat=istat)
         IF (istat /= 0) THEN
            WRITE (unit=message, fmt="(A,I0,A,I0,A)") &
               "An error occurred inquiring the unit with the number ", unit_number, &
               " (IOSTAT = ", istat, ")"
            cpabort(trim(message))
         END IF
         ! Manage preconnections
         IF (keep_file_connection) THEN
            CALL assign_preconnection(file_name, unit_number)
         ELSE
            CALL delete_preconnection(file_name, unit_number)
            CLOSE (unit=unit_number, iostat=istat, status=trim(status_string))
            IF (istat /= 0) THEN
               WRITE (unit=message, fmt="(A,I0,A,I0,A)") &
                  "An error occurred closing the file with the logical unit number ", &
                  unit_number, " (IOSTAT = ", istat, ")"
               cpabort(trim(message))
            END IF
         END IF
      END IF
 
   END SUBROUTINE close_file
 
! **************************************************************************************************
!> \brief Remove an entry from the list of preconnected units
!> \param file_name ...
!> \param unit_number ...
!> \par History
!>      - Creation (22.02.2011,MK)
!> \author Matthias Krack (MK)
! **************************************************************************************************
   SUBROUTINE delete_preconnection(file_name, unit_number)
 
      CHARACTER(LEN=*), INTENT(IN)                       :: file_name
      INTEGER                                            :: unit_number
 
      INTEGER                                            :: ic, nc
 
      nc = SIZE(preconnected)
 
      ! Search for preconnection entry and delete it when found
      DO ic = 1, nc
         IF (trim(preconnected(ic)%file_name) == trim(file_name)) THEN
            IF (preconnected(ic)%unit_number == unit_number) THEN
               preconnected(ic)%file_name = ""
               preconnected(ic)%unit_number = -1
               EXIT
            ELSE
               CALL print_preconnection_list()
               CALL cp_abort(__location__, &
                             "Attempt to disconnect the file <"// &
                             trim(file_name)// &
                             "> from an unlisted unit")
            END IF
         END IF
      END DO
 
   END SUBROUTINE delete_preconnection
 
! **************************************************************************************************
!> \brief Returns the first logical unit that is not preconnected
!> \param file_name ...
!> \return ...
!> \author Matthias Krack (MK)
!> \note
!>       -1 if no free unit exists
! **************************************************************************************************
   FUNCTION get_unit_number(file_name) RESULT(unit_number)
 
      CHARACTER(LEN=*), INTENT(IN), OPTIONAL             :: file_name
      INTEGER                                            :: unit_number
 
      INTEGER                                            :: ic, istat, nc
      LOGICAL                                            :: exists, is_open
 
      IF (PRESENT(file_name)) THEN
         nc = SIZE(preconnected)
         ! Check for preconnected units
         DO ic = 3, nc ! Exclude the preconnected system units (< 3)
            IF (trim(preconnected(ic)%file_name) == trim(file_name)) THEN
               unit_number = preconnected(ic)%unit_number
               RETURN
            END IF
         END DO
      END IF
 
      ! Get a new unit number
      DO unit_number = 1, max_unit_number
         IF (any(unit_number == preconnected(:)%unit_number)) cycle
         INQUIRE (unit=unit_number, exist=exists, opened=is_open, iostat=istat)
         IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) RETURN
      END DO
 
      unit_number = -1
 
   END FUNCTION get_unit_number
 
! **************************************************************************************************
!> \brief Allocate and initialise the list of preconnected units
!> \par History
!>      - Creation (22.02.2011,MK)
!> \author Matthias Krack (MK)
! **************************************************************************************************
   SUBROUTINE init_preconnection_list()
 
      INTEGER                                            :: ic, nc
 
      nc = SIZE(preconnected)
 
      DO ic = 1, nc
         preconnected(ic)%file_name = ""
         preconnected(ic)%unit_number = -1
      END DO
 
      ! Define reserved unit numbers
      preconnected(1)%file_name = "stdin"
      preconnected(1)%unit_number = default_input_unit
      preconnected(2)%file_name = "stdout"
      preconnected(2)%unit_number = default_output_unit
 
   END SUBROUTINE init_preconnection_list
 
! **************************************************************************************************
!> \brief Opens the requested file using a free unit number
!> \param file_name ...
!> \param file_status ...
!> \param file_form ...
!> \param file_action ...
!> \param file_position ...
!> \param file_pad ...
!> \param unit_number ...
!> \param debug ...
!> \param skip_get_unit_number ...
!> \param file_access file access mode
!> \author Matthias Krack (MK)
! **************************************************************************************************
   SUBROUTINE open_file(file_name, file_status, file_form, file_action, &
                        file_position, file_pad, unit_number, debug, &
                        skip_get_unit_number, file_access)
 
      CHARACTER(LEN=*), INTENT(IN)                       :: file_name
      CHARACTER(LEN=*), INTENT(IN), OPTIONAL             :: file_status, file_form, file_action, &
                                                            file_position, file_pad
      INTEGER, INTENT(INOUT)                             :: unit_number
      INTEGER, INTENT(IN), OPTIONAL                      :: debug
      LOGICAL, INTENT(IN), OPTIONAL                      :: skip_get_unit_number
      CHARACTER(LEN=*), INTENT(IN), OPTIONAL             :: file_access
 
      CHARACTER(LEN=*), PARAMETER                        :: routinen = 'open_file'
 
      CHARACTER(LEN=11) :: access_string, action_string, current_action, current_form, &
         form_string, pad_string, position_string, status_string
      CHARACTER(LEN=2*default_path_length)               :: message
      CHARACTER(LEN=default_path_length)                 :: cwd, iomsgstr, real_file_name
      INTEGER                                            :: debug_unit, istat
      LOGICAL                                            :: exists, get_a_new_unit, is_open
 
      IF (PRESENT(file_access)) THEN
         access_string = trim(file_access)
      ELSE
         access_string = "SEQUENTIAL"
      END IF
 
      IF (PRESENT(file_status)) THEN
         status_string = trim(file_status)
      ELSE
         status_string = "OLD"
      END IF
 
      IF (PRESENT(file_form)) THEN
         form_string = trim(file_form)
      ELSE
         form_string = "FORMATTED"
      END IF
 
      IF (PRESENT(file_pad)) THEN
         pad_string = file_pad
         IF (form_string == "UNFORMATTED") THEN
            WRITE (unit=message, fmt="(A)") &
               "The PAD specifier is not allowed for an UNFORMATTED file"
            cpabort(trim(message))
         END IF
      ELSE
         pad_string = "YES"
      END IF
 
      IF (PRESENT(file_action)) THEN
         action_string = trim(file_action)
      ELSE
         action_string = "READ"
      END IF
 
      IF (PRESENT(file_position)) THEN
         position_string = trim(file_position)
      ELSE
         position_string = "REWIND"
      END IF
 
      IF (PRESENT(debug)) THEN
         debug_unit = debug
      ELSE
         debug_unit = 0 ! use default_output_unit for debugging
      END IF
 
      IF (file_name(1:1) == " ") THEN
         WRITE (unit=message, fmt="(A)") &
            "The file name <"//trim(file_name)//"> has leading blanks."
         cpwarn(trim(message))
      END IF
 
      real_file_name = adjustl(file_name)
      IF (status_string == "OLD") real_file_name = discover_file(file_name)
 
      ! Check the specified input file name
      INQUIRE (file=trim(real_file_name), exist=exists, opened=is_open, iostat=istat)
 
      IF (istat /= 0) THEN
         WRITE (unit=message, fmt="(A,I0,A)") &
            "An error occurred inquiring the file <"//trim(real_file_name)// &
            "> (IOSTAT = ", istat, ")"
         cpabort(trim(message))
      ELSE IF (status_string == "OLD") THEN
         IF (.NOT. exists) THEN
            WRITE (unit=message, fmt="(A)") &
               "The specified OLD file <"//trim(real_file_name)// &
               "> cannot be opened. It does not exist. "// &
               "Data directory path: "//trim(get_data_dir())
            cpabort(trim(message))
         END IF
      END IF
 
      ! Open the specified input file
      IF (is_open) THEN
         INQUIRE (file=trim(real_file_name), number=unit_number, &
                  action=current_action, form=current_form)
         IF (trim(position_string) == "REWIND") rewind(unit=unit_number)
         IF (trim(status_string) == "NEW") THEN
            CALL cp_abort(__location__, &
                          "Attempt to re-open the existing OLD file <"// &
                          trim(real_file_name)//"> with status attribute NEW.")
         END IF
         IF (trim(current_form) /= trim(form_string)) THEN
            CALL cp_abort(__location__, &
                          "Attempt to re-open the existing "// &
                          trim(current_form)//" file <"//trim(real_file_name)// &
                          "> as "//trim(form_string)//" file.")
         END IF
         IF (trim(current_action) /= trim(action_string)) THEN
            CALL cp_abort(__location__, &
                          "Attempt to re-open the existing file <"// &
                          trim(real_file_name)//"> with the modified ACTION attribute "// &
                          trim(action_string)//". The current ACTION attribute is "// &
                          trim(current_action)//".")
         END IF
      ELSE
         ! Find an unused unit number
         get_a_new_unit = .true.
         IF (PRESENT(skip_get_unit_number)) THEN
            IF (skip_get_unit_number) get_a_new_unit = .false.
         END IF
         IF (get_a_new_unit) unit_number = get_unit_number(trim(real_file_name))
         IF (unit_number < 1) THEN
            WRITE (unit=message, fmt="(A)") &
               "Cannot open the file <"//trim(real_file_name)// &
               ">, because no unused logical unit number could be obtained."
            cpabort(trim(message))
         END IF
         IF (trim(form_string) == "FORMATTED") THEN
            OPEN (unit=unit_number, &
                  file=trim(real_file_name), &
                  status=trim(status_string), &
                  access=trim(access_string), &
                  form=trim(form_string), &
                  position=trim(position_string), &
                  action=trim(action_string), &
                  pad=trim(pad_string), &
                  iomsg=iomsgstr, &
                  iostat=istat)
         ELSE
            OPEN (unit=unit_number, &
                  file=trim(real_file_name), &
                  status=trim(status_string), &
                  access=trim(access_string), &
                  form=trim(form_string), &
                  position=trim(position_string), &
                  action=trim(action_string), &
                  iomsg=iomsgstr, &
                  iostat=istat)
         END IF
         IF (istat /= 0) THEN
            CALL m_getcwd(cwd)
            WRITE (unit=message, fmt="(A,I0,A,I0,A)") &
               "An error occurred opening the file '"//trim(real_file_name)// &
               "' (UNIT = ", unit_number, ", IOSTAT = ", istat, "). "//trim(iomsgstr)//". "// &
               "Current working directory: "//trim(cwd)
 
            cpabort(trim(message))
         END IF
      END IF
 
      IF (debug_unit > 0) THEN
         INQUIRE (file=trim(real_file_name), opened=is_open, number=unit_number, &
                  position=position_string, name=message, access=access_string, &
                  form=form_string, action=action_string)
         WRITE (unit=debug_unit, fmt="(T2,A)") "BEGIN DEBUG "//trim(routinen)
         WRITE (unit=debug_unit, fmt="(T3,A,I0)") "NUMBER  : ", unit_number
         WRITE (unit=debug_unit, fmt="(T3,A,L1)") "OPENED  : ", is_open
         WRITE (unit=debug_unit, fmt="(T3,A)") "NAME    : "//trim(message)
         WRITE (unit=debug_unit, fmt="(T3,A)") "POSITION: "//trim(position_string)
         WRITE (unit=debug_unit, fmt="(T3,A)") "ACCESS  : "//trim(access_string)
         WRITE (unit=debug_unit, fmt="(T3,A)") "FORM    : "//trim(form_string)
         WRITE (unit=debug_unit, fmt="(T3,A)") "ACTION  : "//trim(action_string)
         WRITE (unit=debug_unit, fmt="(T2,A)") "END DEBUG "//trim(routinen)
         CALL print_preconnection_list(debug_unit)
      END IF
 
   END SUBROUTINE open_file
 
! **************************************************************************************************
!> \brief Checks if file exists, considering also the file discovery mechanism.
!> \param file_name ...
!> \return ...
!> \author Ole Schuett
! **************************************************************************************************
   FUNCTION file_exists(file_name) RESULT(exist)
      CHARACTER(LEN=*), INTENT(IN)                       :: file_name
      LOGICAL                                            :: exist
 
      CHARACTER(LEN=default_path_length)                 :: real_file_name
 
      real_file_name = discover_file(file_name)
      INQUIRE (file=trim(real_file_name), exist=exist)
   END FUNCTION file_exists
 
! **************************************************************************************************
!> \brief Checks various locations for a file name.
!> \param file_name ...
!> \return ...
!> \author Ole Schuett
! **************************************************************************************************
   FUNCTION discover_file(file_name) RESULT(real_file_name)
      CHARACTER(LEN=*), INTENT(IN)                       :: file_name
      CHARACTER(LEN=default_path_length)                 :: real_file_name
 
      CHARACTER(LEN=default_path_length)                 :: candidate, data_dir
      INTEGER                                            :: stat
      LOGICAL                                            :: exists
 
      real_file_name = trim(adjustl(file_name))
 
      ! first try file-name directly
      INQUIRE (file=trim(real_file_name), exist=exists, iostat=stat)
      IF (stat == 0 .AND. exists) RETURN
 
      ! then try the data-dir
      data_dir = get_data_dir()
      IF (len_trim(data_dir) > 0) THEN
         candidate = join_paths(data_dir, real_file_name)
         INQUIRE (file=trim(candidate), exist=exists, iostat=stat)
         IF (stat == 0 .AND. exists) THEN
            real_file_name = candidate
            RETURN
         END IF
      END IF
 
   END FUNCTION discover_file
 
! **************************************************************************************************
!> \brief Returns path of data directory if set, otherwise an empty string
!> \return ...
!> \author Ole Schuett
! **************************************************************************************************
   FUNCTION get_data_dir() RESULT(data_dir_path)
      CHARACTER(LEN=default_path_length)                 :: data_dir_path
 
      INTEGER                                            :: stat
 
      CALL get_environment_variable("CP2K_DATA_DIR", data_dir_path, status=stat)
      IF (stat == 0) RETURN
 
#if defined(__DATA_DIR)
      data_dir_path = __data_dir
#else
      data_dir_path = "" !data-dir not set
#endif
 
   END FUNCTION get_data_dir
 
! **************************************************************************************************
!> \brief Joins two file-paths, inserting '/' as needed.
!> \param path1 ...
!> \param path2 ...
!> \return ...
!> \author Ole Schuett
! **************************************************************************************************
   FUNCTION join_paths(path1, path2) RESULT(joined_path)
      CHARACTER(LEN=*), INTENT(IN)                       :: path1, path2
      CHARACTER(LEN=default_path_length)                 :: joined_path
 
      INTEGER                                            :: n
 
      n = len_trim(path1)
      IF (path2(1:1) == '/') THEN
         joined_path = path2
      ELSE IF (n == 0 .OR. path1(n:n) == '/') THEN
         joined_path = trim(path1)//path2
      ELSE
         joined_path = trim(path1)//'/'//path2
      END IF
   END FUNCTION join_paths
 
! **************************************************************************************************
!> \brief Print the list of preconnected units
!> \param output_unit which unit to print to (optional)
!> \par History
!>      - Creation (22.02.2011,MK)
!> \author Matthias Krack (MK)
! **************************************************************************************************
   SUBROUTINE print_preconnection_list(output_unit)
      INTEGER, INTENT(IN), OPTIONAL                      :: output_unit
 
      INTEGER                                            :: ic, nc, unit
 
      IF (PRESENT(output_unit)) THEN
         unit = output_unit
      ELSE
         unit = default_output_unit
      END IF
 
      nc = SIZE(preconnected)
 
      IF (output_unit > 0) THEN
 
         WRITE (unit=output_unit, fmt="(A,/,A)") &
            " LIST OF PRECONNECTED LOGICAL UNITS", &
            "  Slot   Unit number   File name"
         DO ic = 1, nc
            IF (preconnected(ic)%unit_number > 0) THEN
               WRITE (unit=output_unit, fmt="(I6,3X,I6,8X,A)") &
                  ic, preconnected(ic)%unit_number, &
                  trim(preconnected(ic)%file_name)
            ELSE
               WRITE (unit=output_unit, fmt="(I6,17X,A)") &
                  ic, "UNUSED"
            END IF
         END DO
      END IF
   END SUBROUTINE print_preconnection_list
 
END MODULE cp_files