Rename fpm_filesystem.f90 to fpm_filesystem.F90: requires preprocessor

1 files changed, 0 insertions, 945 deletions

diff --git a/src/fpm_filesystem.f90 b/src/fpm_filesystem.f90
deleted file mode 100644
index d2fcd95..0000000
--- a/src/fpm_filesystem.f90
+++ /dev/null
@@ -1,945 +0,0 @@
-!> This module contains general routines for interacting with the file system
-!!
-module fpm_filesystem
-use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit
-    use fpm_environment, only: get_os_type, &
-                               OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, &
-                               OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD
-    use fpm_environment, only: separator, get_env
-    use fpm_strings, only: f_string, replace, string_t, split
-    use iso_c_binding, only: c_int8_t, c_int16_t, c_int32_t, c_int64_t, c_int128_t, c_char, c_ptr, c_int, c_loc, c_long, c_short, &
-        c_null_char, c_associated, c_f_pointer
-    implicit none
-    private
-    public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, read_lines, list_files, env_variable, &
-            mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, to_fortran_name
-    public :: fileopen, fileclose, filewrite, warnwrite, parent_dir
-    public :: which
-
-    integer, parameter :: LINE_BUFFER_LEN = 1000
-
-#if (defined(MINGW64))
-    type, bind(c) :: stat_t
-        integer(kind=c_int32_t) :: st_dev
-        integer(kind=c_int16_t) :: st_ino
-        integer(kind=c_int16_t) :: st_mode
-        integer(kind=c_int16_t) :: st_nlink
-
-        integer(kind=c_int16_t) :: st_uid
-        integer(kind=c_int16_t) :: st_gid
-
-        integer(kind=c_int32_t) :: st_rdev
-        integer(kind=c_int32_t) :: st_size
-
-        integer(kind=c_int64_t) :: st_atime
-        integer(kind=c_int64_t) :: st_mtime
-        integer(kind=c_int64_t) :: st_ctime
-    end type
-#elif (defined(MINGW32))
-    type, bind(c) :: stat_t
-        integer(kind=c_int32_t) :: st_dev
-        integer(kind=c_int16_t) :: st_ino
-        integer(kind=c_int16_t) :: st_mode
-        integer(kind=c_int16_t) :: st_nlink
-
-        integer(kind=c_int16_t) :: st_uid
-        integer(kind=c_int16_t) :: st_gid
-
-        integer(kind=c_int32_t) :: st_rdev
-        integer(kind=c_int32_t) :: st_size
-
-        integer(kind=c_int32_t) :: st_atime
-        integer(kind=c_int32_t) :: st_mtime
-        integer(kind=c_int32_t) :: st_ctime
-    end type
-#elif (defined(LINUX64))
-    type, bind(c) :: stat_t
-        integer(kind=c_int64_t) :: st_dev
-        integer(kind=c_int64_t) :: st_ino
-        integer(kind=c_int64_t) :: st_nlink
-        integer(kind=c_int32_t) :: st_mode
-
-        integer(kind=c_int32_t) :: st_uid
-        integer(kind=c_int32_t) :: st_gid
-        integer(kind=c_int32_t) :: pad0
-
-        integer(kind=c_int64_t) :: st_rdev
-        integer(kind=c_int64_t) :: st_size
-        integer(kind=c_int64_t) :: st_blksize
-        integer(kind=c_int64_t) :: st_blocks
-
-        integer(kind=c_int128_t) :: st_atime
-        integer(kind=c_int128_t) :: st_mtime
-        integer(kind=c_int128_t) :: st_ctime
-
-        integer(kind=c_int64_t) :: glibc_reserved4
-        integer(kind=c_int64_t) :: glibc_reserved5
-        integer(kind=c_int64_t) :: glibc_reserved6
-    end type
-#elif (defined(LINUX32))
-    type, bind(c) :: stat_t
-        integer(kind=c_int64_t) :: st_dev
-        integer(kind=c_int16_t) :: pad1
-        integer(kind=c_int32_t) :: st_ino
-        integer(kind=c_int32_t) :: st_mode
-        integer(kind=c_int32_t) :: st_nlink
-
-        integer(kind=c_int32_t) :: st_uid
-        integer(kind=c_int32_t) :: st_gid
-        integer(kind=c_int64_t) :: st_rdev
-        integer(kind=c_int16_t) :: pad2
-
-        integer(kind=c_int32_t) :: st_size
-        integer(kind=c_int32_t) :: st_blksize
-        integer(kind=c_int32_t) :: st_blocks
-
-        integer(kind=c_int64_t) :: st_atime
-        integer(kind=c_int64_t) :: st_mtime
-        integer(kind=c_int64_t) :: st_ctime
-
-        integer(kind=c_int32_t) :: glibc_reserved4
-        integer(kind=c_int32_t) :: glibc_reserved5
-    end type
-#endif
-
-#if (defined(MINGW64) || defined(MINGW32))
-    type, bind(c) :: dirent
-        integer(kind=c_long)  :: d_ino
-        integer(kind=c_short) :: d_reclen
-        integer(kind=c_short) :: d_namlen
-        character(len=1,kind=c_char) :: d_name(260)
-    end type
-#elif (defined(LINUX64))
-    type, bind(c) :: dirent
-        integer(kind=c_int64_t) :: d_ino
-        integer(kind=c_int64_t) :: d_off
-        integer(kind=c_int16_t) :: d_reclen
-        integer(kind=c_int8_t)  :: d_type
-        character(len=1,kind=c_char) :: d_name(256)
-    end type
-#elif (defined(LINUX32))
-    type, bind(c) :: dirent
-        integer(kind=c_int32_t) :: d_ino
-        integer(kind=c_int32_t) :: d_off
-        integer(kind=c_int16_t) :: d_reclen
-        integer(kind=c_int8_t)  :: d_type
-        character(len=1,kind=c_char) :: d_name(256)
-    end type
-#endif
-
-#if (defined(MINGW64) || defined(MINGW32) || defined(LINUX64) || defined(LINUX32))
-    interface
-        function c_stat(path, buf) result(r) bind(c, name="stat")
-            import c_char, c_ptr, c_int
-            character(kind=c_char), intent(in) :: path(*)
-            type(c_ptr), value :: buf
-            integer(kind=c_int) :: r
-        end function c_stat
-
-        function c_opendir(dir) result(r) bind(c, name="opendir")
-            import c_char, c_ptr
-            character(kind=c_char), intent(in) :: dir(*)
-            type(c_ptr) :: r
-        end function c_opendir
-
-        function c_readdir(dir) result(r) bind(c, name="readdir")
-            import c_ptr
-            type(c_ptr), intent(in), value :: dir
-            type(c_ptr) :: r
-        end function c_readdir
-
-        function c_closedir(dir) result(r) bind(c, name="closedir")
-            import c_ptr, c_int
-            type(c_ptr), intent(in), value :: dir
-            integer(kind=c_int) :: r
-        end function c_closedir
-    end interface
-#endif
-
-contains
-
-
-!> return value of environment variable
-subroutine env_variable(var, name)
-   character(len=:), allocatable, intent(out) :: var
-   character(len=*), intent(in) :: name
-   integer :: length, stat
-
-   call get_environment_variable(name, length=length, status=stat)
-   if (stat /= 0) return
-
-   allocate(character(len=length) :: var)
-
-   if (length > 0) then
-      call get_environment_variable(name, var, status=stat)
-      if (stat /= 0) then
-         deallocate(var)
-         return
-      end if
-   end if
-
-end subroutine env_variable
-
-
-!> Extract filename from path with/without suffix
-function basename(path,suffix) result (base)
- 
-    character(*), intent(In) :: path
-    logical, intent(in), optional :: suffix
-    character(:), allocatable :: base
-
-    character(:), allocatable :: file_parts(:)
-    logical :: with_suffix
-
-    if (.not.present(suffix)) then
-        with_suffix = .true.
-    else
-        with_suffix = suffix
-    end if
-
-    if (with_suffix) then
-        call split(path,file_parts,delimiters='\/')
-        if(size(file_parts).gt.0)then
-           base = trim(file_parts(size(file_parts)))
-        else
-           base = ''
-        endif
-    else
-        call split(path,file_parts,delimiters='\/.')
-        if(size(file_parts).ge.2)then
-           base = trim(file_parts(size(file_parts)-1))
-        else
-           base = ''
-        endif
-    end if
-
-end function basename
-
-
-!> Canonicalize path for comparison
-!! * Handles path string redundancies
-!! * Does not test existence of path
-!!
-!! To be replaced by realpath/_fullname in stdlib_os
-!!
-!! FIXME: Lot's of ugly hacks following here
-function canon_path(path)
-    character(len=*), intent(in) :: path
-    character(len=:), allocatable :: canon_path
-    character(len=:), allocatable :: nixpath
-
-    integer :: ii, istart, iend, stat, nn, last
-    logical :: is_path, absolute
-
-    nixpath = unix_path(path)
-
-    istart = 0
-    nn = 0
-    iend = 0
-    absolute = nixpath(1:1) == "/"
-    if (absolute) then
-        canon_path = "/"
-    else
-        canon_path = ""
-    end if
-
-    do while(iend < len(nixpath))
-        call next(nixpath, istart, iend, is_path)
-        if (is_path) then
-            select case(nixpath(istart:iend))
-            case(".", "") ! always drop empty paths
-            case("..")
-                if (nn > 0) then
-                    last = scan(canon_path(:len(canon_path)-1), "/", back=.true.)
-                    canon_path = canon_path(:last)
-                    nn = nn - 1
-                else
-                    if (.not. absolute) then
-                        canon_path = canon_path // nixpath(istart:iend) // "/"
-                    end if
-                end if
-            case default
-                nn = nn + 1
-                canon_path = canon_path // nixpath(istart:iend) // "/"
-            end select
-        end if
-    end do
-
-    if (len(canon_path) == 0) canon_path = "."
-    if (len(canon_path) > 1 .and. canon_path(len(canon_path):) == "/") then
-        canon_path = canon_path(:len(canon_path)-1)
-    end if
-
-contains
-
-    subroutine next(string, istart, iend, is_path)
-        character(len=*), intent(in) :: string
-        integer, intent(inout) :: istart
-        integer, intent(inout) :: iend
-        logical, intent(inout) :: is_path
-
-        integer :: ii, nn
-        character :: tok, last
-
-        nn = len(string)
-
-        if (iend >= nn) then
-            istart = nn
-            iend = nn
-            return
-        end if
-
-        ii = min(iend + 1, nn)
-        tok = string(ii:ii)
-
-        is_path = tok /= '/'
-
-        if (.not.is_path) then
-            is_path = .false.
-            istart = ii
-            iend = ii
-            return
-        end if
-
-        istart = ii
-        do ii = min(iend + 1, nn), nn
-            tok = string(ii:ii)
-            select case(tok)
-            case('/')
-                exit
-            case default
-                iend = ii
-                cycle
-            end select
-        end do
-
-    end subroutine next
-end function canon_path
-
-
-!> Extract dirname from path
-function dirname(path) result (dir)
-    character(*), intent(in) :: path
-    character(:), allocatable :: dir
-
-    dir = path(1:scan(path,'/\',back=.true.))
-    if (len_trim(dir) == 0) dir = "."
-
-end function dirname
-
-!> Extract dirname from path
-function parent_dir(path) result (dir)
-    character(*), intent(in) :: path
-    character(:), allocatable :: dir
-
-    dir = path(1:scan(path,'/\',back=.true.)-1)
-
-end function parent_dir
-
-
-!> test if a name matches an existing directory path
-logical function is_dir(dir)
-    character(*), intent(in) :: dir
-    integer :: stat
-
-    select case (get_os_type())
-
-    case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
-        call execute_command_line("test -d " // dir , exitstat=stat)
-
-    case (OS_WINDOWS)
-        call execute_command_line('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', exitstat=stat)
-
-    end select
-
-    is_dir = (stat == 0)
-
-end function is_dir
-
-
-!> Construct path by joining strings with os file separator
-function join_path(a1,a2,a3,a4,a5) result(path)
-
-    character(len=*), intent(in)           :: a1, a2
-    character(len=*), intent(in), optional :: a3, a4, a5
-    character(len=:), allocatable          :: path
-    character(len=1)                       :: filesep
-
-    select case (get_os_type())
-        case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
-            filesep = '/'
-        case (OS_WINDOWS)
-            filesep = '\'
-    end select
-
-    path = a1 // filesep // a2
-
-    if (present(a3)) then
-        path = path // filesep // a3
-    else
-        return
-    end if
-
-    if (present(a4)) then
-        path = path // filesep // a4
-    else
-        return
-    end if
-
-    if (present(a5)) then
-        path = path // filesep // a5
-    else
-        return
-    end if
-
-end function join_path
-
-
-!> Determine number or rows in a file given a LUN
-integer function number_of_rows(s) result(nrows)
-    integer,intent(in)::s
-    integer :: ios
-    character(len=100) :: r
-    rewind(s)
-    nrows = 0
-    do
-        read(s, '(A)', iostat=ios) r
-        if (ios /= 0) exit
-        nrows = nrows + 1
-    end do
-    rewind(s)
-end function number_of_rows
-
-
-!> read lines into an array of TYPE(STRING_T) variables
-function read_lines(fh) result(lines)
-    integer, intent(in) :: fh
-    type(string_t), allocatable :: lines(:)
-
-    integer :: i
-    character(LINE_BUFFER_LEN) :: line_buffer
-
-    allocate(lines(number_of_rows(fh)))
-    do i = 1, size(lines)
-        read(fh, '(A)') line_buffer
-        lines(i)%s = trim(line_buffer)
-    end do
-
-end function read_lines
-
-!> Create a directory. Create subdirectories as needed
-subroutine mkdir(dir)
-    character(len=*), intent(in) :: dir
-    integer                      :: stat
-
-    if (is_dir(dir)) return
-
-    select case (get_os_type())
-        case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
-            call execute_command_line('mkdir -p ' // dir, exitstat=stat)
-            write (*, '(" + ",2a)') 'mkdir -p ' // dir
-
-        case (OS_WINDOWS)
-            call execute_command_line("mkdir " // windows_path(dir), exitstat=stat)
-            write (*, '(" + ",2a)') 'mkdir ' // windows_path(dir)
-    end select
-
-    if (stat /= 0) then
-        print *, 'execute_command_line() failed'
-        error stop
-    end if
-end subroutine mkdir
-
-
-#if (defined(MINGW64) || defined(MINGW32) || defined(LINUX64) || defined(LINUX32))
-!> Get file & directory names in directory `dir` using iso_c_binding.
-!!
-!!  - File/directory names return are relative to cwd, ie. preprended with `dir`
-!!  - Includes files starting with `.` except current directory and parent directory
-!!
-recursive subroutine list_files(dir, files, recurse)
-    character(len=*), intent(in) :: dir
-    type(string_t), allocatable, intent(out) :: files(:)
-    logical, intent(in), optional :: recurse
-
-    integer :: i
-    type(string_t), allocatable :: dir_files(:)
-    type(string_t), allocatable :: sub_dir_files(:)
-
-    type(c_ptr) :: dir_handle
-    type(c_ptr) :: dir_entry_c
-    type(dirent), pointer :: dir_entry_fortran
-    character(len=:), allocatable :: string_fortran
-    integer, parameter :: N_MAX = 256
-    type(string_t) :: files_tmp(N_MAX)
-    integer(kind=c_int) :: r
-
-    if (.not. is_dir_c(dir(1:len_trim(dir))//c_null_char)) then
-        allocate (files(0))
-        return
-    end if
-
-    dir_handle = c_opendir(dir(1:len_trim(dir))//c_null_char)
-    if (.not. c_associated(dir_handle)) then
-        print *, 'c_opendir() failed'
-        error stop
-    end if
-
-    i = 0
-    allocate(files(0))
-
-    do
-        dir_entry_c = c_readdir(dir_handle)
-        if (.not. c_associated(dir_entry_c)) then
-            exit
-        else
-            call c_f_pointer(dir_entry_c, dir_entry_fortran)
-            string_fortran = f_string(dir_entry_fortran%d_name)
-
-            if ((string_fortran .eq. '.' .or. string_fortran .eq. '..')) then
-                cycle
-            end if
-
-            i = i + 1
-
-            if (i .gt. N_MAX) then
-                files = [files, files_tmp]
-                i = 1
-            end if
-
-            files_tmp(i)%s = join_path(dir, string_fortran)
-        end if
-    end do
-
-    r = c_closedir(dir_handle)
-
-    if (r .ne. 0) then
-        print *, 'c_closedir() failed'
-        error stop
-    end if
-
-    if (i .gt. 0) then
-        files = [files, files_tmp(1:i)]
-    end if
-
-    if (present(recurse)) then
-        if (recurse) then
-
-            allocate(sub_dir_files(0))
-
-            do i=1,size(files)
-                if (is_dir_c(files(i)%s//c_null_char)) then
-                    call list_files(files(i)%s, dir_files, recurse=.true.)
-                    sub_dir_files = [sub_dir_files, dir_files]
-                end if
-            end do
-
-            files = [files, sub_dir_files]
-        end if
-    end if
-end subroutine list_files
-
-function is_dir_c(path) result(r)
-    character(kind=c_char), intent(in) :: path(*)
-    logical :: r
-    type(stat_t), target :: buf
-    integer(kind=c_int) :: exists
-    integer(kind=c_int), parameter :: S_IFMT  = 61440
-    integer(kind=c_int), parameter :: S_IFDIR = 16384
-
-    exists = c_stat(path, c_loc(buf))
-    r = exists .eq. 0 .and. iand(int(buf%st_mode, kind=c_int), S_IFMT) .eq. S_IFDIR
-end function is_dir_c
-
-#else
-!> Get file & directory names in directory `dir`.
-!!
-!!  - File/directory names return are relative to cwd, ie. preprended with `dir`
-!!  - Includes files starting with `.` except current directory and parent directory
-!!
-recursive subroutine list_files(dir, files, recurse)
-    character(len=*), intent(in) :: dir
-    type(string_t), allocatable, intent(out) :: files(:)
-    logical, intent(in), optional :: recurse
-
-    integer :: stat, fh, i
-    character(:), allocatable :: temp_file
-    type(string_t), allocatable :: dir_files(:)
-    type(string_t), allocatable :: sub_dir_files(:)
-
-    if (.not. is_dir(dir)) then
-        allocate (files(0))
-        return
-    end if
-
-    allocate (temp_file, source=get_temp_filename())
-
-    select case (get_os_type())
-        case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD)
-            call execute_command_line('ls -A ' // dir // ' > ' // temp_file, &
-                                      exitstat=stat)
-        case (OS_WINDOWS)
-            call execute_command_line('dir /b ' // windows_path(dir) // ' > ' // temp_file, &
-                                      exitstat=stat)
-    end select
-
-    if (stat /= 0) then
-        print *, 'execute_command_line() failed'
-        error stop
-    end if
-
-    open (newunit=fh, file=temp_file, status='old')
-    files = read_lines(fh)
-    close(fh,status="delete")
-
-    do i=1,size(files)
-        files(i)%s = join_path(dir,files(i)%s)
-    end do
-
-    if (present(recurse)) then
-        if (recurse) then
-
-            allocate(sub_dir_files(0))
-
-            do i=1,size(files)
-                if (is_dir(files(i)%s)) then
-
-                    call list_files(files(i)%s, dir_files, recurse=.true.)
-                    sub_dir_files = [sub_dir_files, dir_files]
-
-                end if
-            end do
-
-            files = [files, sub_dir_files]
-
-        end if
-    end if
-
-end subroutine list_files
-#endif
-
-!> test if pathname already exists
-logical function exists(filename) result(r)
-    character(len=*), intent(in) :: filename
-    inquire(file=filename, exist=r)
-end function
-
-
-!> Get a unused temporary filename
-!!  Calls posix 'tempnam' - not recommended, but
-!!   we have no security concerns for this application
-!!   and use here is temporary.
-!! Works with MinGW
-function get_temp_filename() result(tempfile)
-    !
-    use iso_c_binding, only: c_ptr, C_NULL_PTR, c_f_pointer
-    character(:), allocatable :: tempfile
-
-    type(c_ptr) :: c_tempfile_ptr
-    character(len=1), pointer :: c_tempfile(:)
-
-    interface
-
-        function c_tempnam(dir,pfx) result(tmp) bind(c,name="tempnam")
-            import
-            type(c_ptr), intent(in), value :: dir
-            type(c_ptr), intent(in), value :: pfx
-            type(c_ptr) :: tmp
-        end function c_tempnam
-
-        subroutine c_free(ptr) BIND(C,name="free")
-            import
-            type(c_ptr), value :: ptr
-        end subroutine c_free
-
-    end interface
-
-    c_tempfile_ptr = c_tempnam(C_NULL_PTR, C_NULL_PTR)
-    call c_f_pointer(c_tempfile_ptr,c_tempfile,[LINE_BUFFER_LEN])
-
-    tempfile = f_string(c_tempfile)
-
-    call c_free(c_tempfile_ptr)
-
-end function get_temp_filename
-
-
-!> Replace file system separators for windows
-function windows_path(path) result(winpath)
-
-    character(*), intent(in) :: path
-    character(:), allocatable :: winpath
-
-    integer :: idx
-
-    winpath = path
-
-    idx = index(winpath,'/')
-    do while(idx > 0)
-        winpath(idx:idx) = '\'
-        idx = index(winpath,'/')
-    end do
-
-end function windows_path
-
-
-!> Replace file system separators for unix
-function unix_path(path) result(nixpath)
-
-    character(*), intent(in) :: path
-    character(:), allocatable :: nixpath
-
-    integer :: idx
-
-    nixpath = path
-
-    idx = index(nixpath,'\')
-    do while(idx > 0)
-        nixpath(idx:idx) = '/'
-        idx = index(nixpath,'\')
-    end do
-
-end function unix_path
-
-
-!> read a line of arbitrary length into a CHARACTER variable from the specified LUN
-subroutine getline(unit, line, iostat, iomsg)
-
-    !> Formatted IO unit
-    integer, intent(in) :: unit
-
-    !> Line to read
-    character(len=:), allocatable, intent(out) :: line
-
-    !> Status of operation
-    integer, intent(out) :: iostat
-
-    !> Error message
-    character(len=:), allocatable, optional :: iomsg
-
-    character(len=LINE_BUFFER_LEN) :: buffer
-    character(len=LINE_BUFFER_LEN) :: msg
-    integer :: size
-    integer :: stat
-
-    allocate(character(len=0) :: line)
-    do
-        read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=size) &
-            & buffer
-        if (stat > 0) exit
-        line = line // buffer(:size)
-        if (stat < 0) then
-            if (is_iostat_eor(stat)) then
-                stat = 0
-            end if
-            exit
-        end if
-    end do
-
-    if (stat /= 0) then
-        if (present(iomsg)) iomsg = trim(msg)
-    end if
-    iostat = stat
-
-end subroutine getline
-
-
-!> delete a file by filename
-subroutine delete_file(file)
-    character(len=*), intent(in) :: file
-    logical :: exist
-    integer :: unit
-    inquire(file=file, exist=exist)
-    if (exist) then
-        open(file=file, newunit=unit)
-        close(unit, status="delete")
-    end if
-end subroutine delete_file
-
-!> write trimmed character data to a file if it does not exist
-subroutine warnwrite(fname,data)
-character(len=*),intent(in) :: fname
-character(len=*),intent(in) :: data(:)
-
-    if(.not.exists(fname))then
-        call filewrite(fname,data)
-    else
-        write(stderr,'(*(g0,1x))')'<INFO>  ',fname,&
-        & 'already exists. Not overwriting'
-    endif
-
-end subroutine warnwrite
-
-!> procedure to open filename as a sequential "text" file
-subroutine fileopen(filename,lun,ier)
-
-character(len=*),intent(in)   :: filename
-integer,intent(out)           :: lun
-integer,intent(out),optional  :: ier
-integer                       :: ios
-character(len=256)            :: message
-
-    message=' '
-    ios=0
-    if(filename.ne.' ')then
-        open(file=filename, &
-        & newunit=lun, &
-        & form='formatted', &    ! FORM    = FORMATTED | UNFORMATTED
-        & access='sequential', & ! ACCESS  = SEQUENTIAL| DIRECT | STREAM
-        & action='write', &      ! ACTION  = READ|WRITE| READWRITE
-        & position='rewind', &   ! POSITION= ASIS      | REWIND | APPEND
-        & status='new', &        ! STATUS  = NEW| REPLACE| OLD| SCRATCH| UNKNOWN
-        & iostat=ios, &
-        & iomsg=message)
-    else
-        lun=stdout
-        ios=0
-    endif
-    if(ios.ne.0)then
-        write(stderr,'(*(a:,1x))')&
-        & '<ERROR> *filewrite*:',filename,trim(message)
-        lun=-1
-        if(present(ier))then
-           ier=ios
-        else
-           stop 1
-        endif
-    endif
-
-end subroutine fileopen
-
-!> simple close of a LUN.  On error show message and stop (by default)
-subroutine fileclose(lun,ier)
-integer,intent(in)    :: lun
-integer,intent(out),optional :: ier
-character(len=256)    :: message
-integer               :: ios
-    if(lun.ne.-1)then
-        close(unit=lun,iostat=ios,iomsg=message)
-        if(ios.ne.0)then
-            write(stderr,'(*(a:,1x))')'<ERROR> *filewrite*:',trim(message)
-            if(present(ier))then
-               ier=ios
-            else
-               stop 2
-            endif
-        endif
-    endif
-end subroutine fileclose
-
-!> procedure to write filedata to file filename
-subroutine filewrite(filename,filedata)
-
-character(len=*),intent(in)           :: filename
-character(len=*),intent(in)           :: filedata(:)
-integer                               :: lun, i, ios
-character(len=256)                    :: message
-    call fileopen(filename,lun)
-    if(lun.ne.-1)then ! program currently stops on error on open, but might
-                      ! want it to continue so -1 (unallowed LUN) indicates error
-       ! write file
-       do i=1,size(filedata)
-           write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i))
-           if(ios.ne.0)then
-               write(stderr,'(*(a:,1x))')&
-               & '<ERROR> *filewrite*:',filename,trim(message)
-               stop 4
-           endif
-       enddo
-    endif
-    ! close file
-    call fileclose(lun)
-
-end subroutine filewrite
-
-!> Returns string with special characters replaced with an underscore.
-!! For now, only a hyphen is treated as a special character, but this can be
-!! expanded to other characters if needed.
-pure function to_fortran_name(string) result(res)
-    character(*), intent(in) :: string
-    character(len(string)) :: res
-    character, parameter :: SPECIAL_CHARACTERS(*) = ['-']
-    res = replace(string, SPECIAL_CHARACTERS, '_')
-end function to_fortran_name
-
-function which(command) result(pathname)
-!>
-!!##NAME
-!!     which(3f) - [M_io:ENVIRONMENT] given a command name find the pathname by searching
-!!                 the directories in the environment variable $PATH
-!!     (LICENSE:PD)
-!!
-!!##SYNTAX
-!!   function which(command) result(pathname)
-!!
-!!    character(len=*),intent(in)  :: command
-!!    character(len=:),allocatable :: pathname
-!!
-!!##DESCRIPTION
-!!    Given a command name find the first file with that name in the directories
-!!    specified by the environment variable $PATH.
-!!
-!!##OPTIONS
-!!    COMMAND   the command to search for
-!!
-!!##RETURNS
-!!    PATHNAME  the first pathname found in the current user path. Returns blank
-!!              if the command is not found.
-!!
-!!##EXAMPLE
-!!
-!!   Sample program:
-!!
-!!   Checking the error message and counting lines:
-!!
-!!     program demo_which
-!!     use M_io, only : which
-!!     implicit none
-!!        write(*,*)'ls is ',which('ls')
-!!        write(*,*)'dir is ',which('dir')
-!!        write(*,*)'install is ',which('install')
-!!     end program demo_which
-!!
-!!##AUTHOR
-!!    John S. Urban
-!!##LICENSE
-!!    Public Domain
-
-character(len=*),intent(in)     :: command
-character(len=:),allocatable    :: pathname, checkon, paths(:), exts(:)
-integer                         :: i, j
-   pathname=''
-   call split(get_env('PATH'),paths,delimiters=merge(';',':',separator().eq.'\'))
-   SEARCH: do i=1,size(paths)
-      checkon=trim(join_path(trim(paths(i)),command))
-      select case(separator())
-      case('/')
-         if(exists(checkon))then
-            pathname=checkon
-            exit SEARCH
-         endif
-      case('\')
-         if(exists(checkon))then
-            pathname=checkon
-            exit SEARCH
-         endif
-         if(exists(checkon//'.bat'))then
-            pathname=checkon//'.bat'
-            exit SEARCH
-         endif
-         if(exists(checkon//'.exe'))then
-            pathname=checkon//'.exe'
-            exit SEARCH
-         endif
-         call split(get_env('PATHEXT'),exts,delimiters=';')
-         do j=1,size(exts)
-            if(exists(checkon//'.'//trim(exts(j))))then
-               pathname=checkon//'.'//trim(exts(j))
-               exit SEARCH
-            endif
-         enddo
-      end select
-   enddo SEARCH
-end function which
-
-end module fpm_filesystem