file_opts.f

Go to the documentation of this file.

!*******************************************************************************
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!*******************************************************************************
      MODULE file_opts
      USE system_mod
 
      IMPLICIT NONE
 
!*******************************************************************************
!  file_opts module parameters
!*******************************************************************************
      INTEGER, PARAMETER :: path_length = 300
 
      CONTAINS
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      SUBROUTINE move_file(file_source, file_dest, error)
#if defined(__INTEL_COMPILER)
      USE iflport
#endif
 
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=*), INTENT(in) :: file_source
      CHARACTER (len=*), INTENT(in) :: file_dest
      INTEGER, INTENT(out)          :: error
 
!  local parameters
!  To avoid any possible interactive command lines, make sure the command
!  overwrites the file if it exists.
#if defined(WIN32)
      CHARACTER (len=*), PARAMETER :: cmd = 'move /y '
#else
      CHARACTER (len=*), PARAMETER :: cmd = 'mv -f '
#endif
 
!  Start of executable code
 
#if defined(__GFORTRAN__) || defined(__INTEL_COMPILER)
      error = rename(trim(file_source), trim(file_dest))
#else
      CALL system(cmd // trim(file_source) // ' ' // file_dest,           &
     &            error)
#endif
      END SUBROUTINE
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      SUBROUTINE copy_file(file_source, file_dest, error)
      USE safe_open_mod
#if defined(FAST_COPY)
      use, INTRINSIC :: iso_c_binding
#endif
 
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=*), INTENT(in)                :: file_source
      CHARACTER (len=*), INTENT(in)                :: file_dest
      INTEGER, INTENT(out)                         :: error
 
!  local variables
      LOGICAL                                      :: l_exists
      LOGICAL                                      :: l_opened
      INTEGER                                      :: file_size
      INTEGER                                      :: max_block_size
      INTEGER                                      :: io_source
      INTEGER                                      :: io_dest
      INTEGER                                      :: n_rec
      INTEGER                                      :: i_rec
      CHARACTER (len=1), ALLOCATABLE, DIMENSION(:) :: buffer
 
!  local parameters
      INTEGER, PARAMETER            :: block_size = 1024
 
#if defined(fast_copy)
      INTERFACE
         FUNCTION copy_file_c(src, dest) BIND(C)
         use, INTRINSIC :: iso_c_binding
 
         IMPLICIT NONE
 
         INTEGER, PARAMETER :: length = 300
         INTEGER (c_int)    :: copy_file_c
         CHARACTER (kind=c_char,len=1), DIMENSION(length), INTENT(in) ::       &
     &      src
         CHARACTER (kind=c_char,len=1), DIMENSION(length), INTENT(in) ::       &
     &      dest
         END FUNCTION
      END INTERFACE
#endif
 
!  Start of executable code
#if defined(FAST_COPY)
      error = copy_file_c(trim(file_source) // c_null_char,                    &
     &                    trim(file_dest) // c_null_char)
#else
 
!  Check source file.
      INQUIRE (file=file_source, exist=l_exists, opened=l_opened)
      CALL getfilesize(file_source, file_size)
 
      IF (.not.l_exists) THEN
         WRITE (*,1001) trim(file_source)
         error = -1
         RETURN
      ELSE IF (l_opened) THEN
         WRITE (*,1000) trim(file_source)
         error = -1
         RETURN
      END IF
 
!  Check destination file.
      INQUIRE (file=file_dest, exist=l_exists, opened=l_opened)
      IF (l_opened) THEN
         WRITE (*,1000) trim(file_dest)
         error = -1
         RETURN
      ELSE
         CALL delete_file(file_dest, error)
      END IF
 
      io_source = 10
      io_dest = 11
 
      max_block_size = min(block_size, file_size)
 
      CALL safe_open(io_source, error, file_source, 'old',                     &
     &               'unformatted', record_in=max_block_size,                  &
     &               access_in='direct')
      IF (error .ne. 0) WRITE (*,1002) trim(file_source)
 
      CALL safe_open(io_dest, error, file_dest, 'new', 'unformatted',          &
     &               record_in=max_block_size, access_in='direct')
      IF (error .ne. 0) WRITE (*,1003) trim(file_dest)
 
      ALLOCATE (buffer(max_block_size), stat=error)
      IF (error .ne. 0) WRITE (*,1004)
 
!  Write file in block sized chunks.
      n_rec = max(1, file_size/max_block_size)
      DO i_rec = 1, n_rec
         READ (io_source, rec=i_rec) buffer
         WRITE (io_dest, rec=i_rec) buffer
      END DO
 
      CLOSE (io_source)
      CLOSE (io_dest)
 
!  The block size may not bet an even multiple of the file size. Copy the
!  remaining part in 1 byte chunks.
      IF (file_size - (i_rec - 1)*max_block_size .gt. 0) THEN
         OPEN (unit=io_source, file=file_source, status='old',                 &
     &         access='direct', recl=1)
         OPEN (unit=io_dest, file=file_dest, status='old',                     &
     &         access='direct', recl=1)
 
         DO i_rec = i_rec, file_size
            READ (io_source, rec=i_rec) buffer(1)
            WRITE (io_dest, rec=i_rec) buffer(1)
         END DO
 
         CLOSE (io_source)
         CLOSE (io_dest)
      END IF
 
      DEALLOCATE (buffer)
 
1000  FORMAT('ERROR: File ',a,' is already opened.')
1001  FORMAT('ERROR: File ',a,' does not exist.')
1002  FORMAT('ERROR: Fail to open ',a,'.')
1003  FORMAT('ERROR: Fail to create ',a,'.')
1004  FORMAT('ERROR: Fail to allocate copy buffer.')
#endif
      END SUBROUTINE
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      SUBROUTINE delete_file(file_source, error)
#if defined(__INTEL_COMPILER)
      USE iflport
#endif
      USE safe_open_mod
 
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=*), INTENT(in) :: file_source
      INTEGER, INTENT(out)          :: error
 
!  local variables
      INTEGER                       :: io_unit
 
!  Start of executable code
#if defined(__GFORTRAN__) || defined(__INTEL_COMPILER)
      error = unlink(file_source)
#else
      io_unit = 10
      CALL safe_open(io_unit, error, file_source, 'old', 'formatted')
      CLOSE (io_unit, iostat=error, status='delete')
#endif
 
      END SUBROUTINE
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      SUBROUTINE create_directory(directory_source, error)
 
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=*), INTENT(in) :: directory_source
      INTEGER, INTENT(out)          :: error
 
!  local parameters
#if defined(WIN32)
      CHARACTER (len=*), PARAMETER :: cmd = 'mkdir '
#else
      CHARACTER (len=*), PARAMETER :: cmd = 'mkdir -p '
#endif
 
!  Start of executable code
 
      CALL system(cmd // trim(directory_source), error)
 
      END SUBROUTINE
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      SUBROUTINE delete_directory(directory_source, error)
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=*), INTENT(in) :: directory_source
      INTEGER, INTENT(out)          :: error
 
!  local parameters
#if defined(WIN32)
      CHARACTER (len=*), PARAMETER :: cmd = 'rmdir /Q /S '
#else
      CHARACTER (len=*), PARAMETER :: cmd = 'rm -rf '
#endif
 
!  Start of executable code
 
      CALL system(cmd // trim(directory_source), error)
 
      END SUBROUTINE
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      FUNCTION is_absolute_path(path)
 
      IMPLICIT NONE
 
!  Declare Arguments
      LOGICAL                       :: is_absolute_path
      CHARACTER (len=*), INTENT(in) :: path
 
!  Start of executable code
!  Treat empty paths as absolute.
      IF (path .eq. '') THEN
         is_absolute_path = .true.
         RETURN
      END IF
 
#if defined(WIN32)
!  On windows systems, root paths start with a variey of cases. Taken from
!
!  http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx#paths
!
!    * A UNC name of any format, which always start with two backslash characters
!      ("\\"). For more information, see the next section.
!    * A disk designator with a backslash, for example "C:\" or "d:\".
!    * A single backslash, for example, "\directory" or "\file.txt". This is
!      also referred to as an absolute path.
!
      is_absolute_path = (path(1:2)         .eq. '\\') .or.                    &
     &                   (index(path, ':\') .eq. 0)    .or.                    &
     &                   (path(1:1)         .eq. '\')
#else
!  On unix systems, an absolute path starts with either / or ~
      is_absolute_path = (path(1:1) .eq. '/') .or.                             &
     &                   (path(1:1) .eq. '~')
#endif
 
      END FUNCTION
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      FUNCTION get_path_of_file(file)
 
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=path_length)   :: get_path_of_file
      CHARACTER (len=*), INTENT(in) :: file
 
!  Start of executable code
#if defined(win32)
      get_path_of_file =                                                       &
     &   file(1:(index(trim(file), '\', back = .true.) - 1))
#else
      get_path_of_file =                                                       &
     &   file(1:(index(trim(file), '/', back = .true.) - 1))
#endif
 
      END FUNCTION
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      FUNCTION build_path(path, name)
 
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=path_length)   :: build_path
      CHARACTER (len=*), INTENT(in) :: path
      CHARACTER (len=*), INTENT(in) :: name
 
!  Start of executable code
      IF (trim(path) .eq. '') THEN
         build_path = name
         RETURN
      END IF
 
#if defined(WIN32)
      build_path = trim(path) // '\' // trim(name)
#else
      build_path = trim(path) // '/' // trim(name)
#endif
 
      END FUNCTION
 
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      SUBROUTINE change_directory(path, error)
#if defined(__INTEL_COMPILER)
      USE iflport
#endif
 
      IMPLICIT NONE
 
!  Declare Arguments
      CHARACTER (len=*), INTENT(in) :: path
      INTEGER, INTENT(out)          :: error
 
!  local parameters
      error = chdir(trim(path))
 
      END SUBROUTINE
 
      END MODULE