dbcsr_files.F Source File


Source Code

# 1 "/__w/dbcsr/dbcsr/src/utils/dbcsr_files.F" 1
!--------------------------------------------------------------------------------------------------!
! Copyright (C) by the DBCSR developers group - All rights reserved                                !
! This file is part of the DBCSR library.                                                          !
!                                                                                                  !
! For information on the license, see the LICENSE file.                                            !
! For further information please visit https://dbcsr.cp2k.org                                      !
! SPDX-License-Identifier: GPL-2.0+                                                                !
!--------------------------------------------------------------------------------------------------!

MODULE dbcsr_files
   !! Utility routines to open and close files.

   USE dbcsr_kinds, ONLY: default_path_length
   USE dbcsr_machine, ONLY: default_input_unit, &
                            default_output_unit, &
                            m_getcwd
#include "base/dbcsr_base_uses.f90"

   IMPLICIT NONE

   PRIVATE

   PUBLIC :: close_file, &
             open_file, &
             get_unit_number, &
             file_exists

   CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_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

   SUBROUTINE assign_preconnection(file_name, unit_number)
      !! Add an entry to the list of preconnected units

      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
         DBCSR_ABORT("An invalid logical unit number was specified.")
      END IF

      IF (LEN_TRIM(file_name) == 0) THEN
         DBCSR_ABORT("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 dbcsr_abort(__LOCATION__, &
                                "Attempt to connect the already connected file <"// &
                                TRIM(ADJUSTL(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()
         DBCSR_ABORT("No free slot found in the list of preconnected units")
      END IF

      preconnected(islot)%file_name = TRIM(ADJUSTL(file_name))
      preconnected(islot)%unit_number = unit_number

   END SUBROUTINE assign_preconnection

   SUBROUTINE close_file(unit_number, file_status, keep_preconnection)
      !! Close an open file given by its logical unit number.
      !! Optionally, keep the file and unit preconnected.

      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, ")"
         DBCSR_ABORT(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."
         DBCSR_ABORT(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
            DBCSR_ABORT(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
            DBCSR_ABORT(TRIM(message))
         END IF
         ! Define status after closing the file
         IF (PRESENT(file_status)) THEN
            status_string = TRIM(ADJUSTL(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, ")"
            DBCSR_ABORT(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, ")"
               DBCSR_ABORT(TRIM(message))
            END IF
         END IF
      END IF

   END SUBROUTINE close_file

   SUBROUTINE delete_preconnection(file_name, unit_number)
      !! Remove an entry from the list of preconnected units

      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 dbcsr_abort(__LOCATION__, &
                                "Attempt to disconnect the file <"// &
                                TRIM(ADJUSTL(file_name))// &
                                "> from an unlisted unit")
            END IF
         END IF
      END DO

   END SUBROUTINE delete_preconnection

   FUNCTION get_unit_number(file_name) RESULT(unit_number)
      !! Returns the first logical unit that is not preconnected
      !! @note
      !! -1 if no free unit exists

      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

   SUBROUTINE 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

      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
         !! file access mode

      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
      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"
            DBCSR_ABORT(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

      ! Check the specified input file name
      INQUIRE (FILE=TRIM(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(file_name)// &
            "> (IOSTAT = ", istat, ")"
         DBCSR_ABORT(TRIM(message))
      ELSE IF (status_string == "OLD") THEN
         IF (.NOT. exists) THEN
            WRITE (UNIT=message, FMT="(A)") &
               "The specified file <"//TRIM(ADJUSTL(file_name))// &
               "> cannot be opened. It does not exist. "
            DBCSR_ABORT(TRIM(message))
         END IF
      END IF

      ! Open the specified input file
      IF (is_open) THEN
         INQUIRE (FILE=TRIM(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 dbcsr_abort(__LOCATION__, &
                             "Attempt to re-open the existing OLD file <"// &
                             TRIM(file_name)//"> with status attribute NEW.")
         END IF
         IF (TRIM(current_form) /= TRIM(form_string)) THEN
            CALL dbcsr_abort(__LOCATION__, &
                             "Attempt to re-open the existing "// &
                             TRIM(current_form)//" file <"//TRIM(file_name)// &
                             "> as "//TRIM(form_string)//" file.")
         END IF
         IF (TRIM(current_action) /= TRIM(action_string)) THEN
            CALL dbcsr_abort(__LOCATION__, &
                             "Attempt to re-open the existing file <"// &
                             TRIM(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(file_name))
         IF (unit_number < 1) THEN
            WRITE (UNIT=message, FMT="(A)") &
               "Cannot open the file <"//TRIM(ADJUSTL(file_name))// &
               ">, because no unused logical unit number could be obtained."
            DBCSR_ABORT(TRIM(message))
         END IF
         IF (TRIM(form_string) == "FORMATTED") THEN
            OPEN (UNIT=unit_number, &
                  FILE=TRIM(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(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(ADJUSTL(file_name))// &
               "' (UNIT = ", unit_number, ", IOSTAT = ", istat, "). "//TRIM(iomsgstr)//". "// &
               "Current working directory: "//TRIM(cwd)

            DBCSR_ABORT(TRIM(message))
         END IF
      END IF

      IF (debug_unit > 0) THEN
         INQUIRE (FILE=TRIM(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(ADJUSTL(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(ADJUSTL(message))
         WRITE (UNIT=debug_unit, FMT="(T3,A)") "POSITION: "//TRIM(ADJUSTL(position_string))
         WRITE (UNIT=debug_unit, FMT="(T3,A)") "ACCESS  : "//TRIM(ADJUSTL(access_string))
         WRITE (UNIT=debug_unit, FMT="(T3,A)") "FORM    : "//TRIM(ADJUSTL(form_string))
         WRITE (UNIT=debug_unit, FMT="(T3,A)") "ACTION  : "//TRIM(ADJUSTL(action_string))
         WRITE (UNIT=debug_unit, FMT="(T2,A)") "END DEBUG "//TRIM(ADJUSTL(routineN))
         CALL print_preconnection_list(debug_unit)
      END IF

   END SUBROUTINE open_file

   FUNCTION file_exists(file_name) RESULT(exist)
      !! Checks if file exists, considering also the file discovery mechanism.
      CHARACTER(LEN=*), INTENT(IN)                       :: file_name
      LOGICAL                                            :: exist

      INQUIRE (FILE=TRIM(file_name), exist=exist)
   END FUNCTION file_exists

   SUBROUTINE print_preconnection_list(output_unit)
      !! Print the list of preconnected units

      INTEGER, INTENT(IN), OPTIONAL                      :: output_unit
         !! which unit to print to (optional)

      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(ADJUSTL(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 dbcsr_files