path: root/common/utilities.F90

module utilities

#ifdef WINDOWS
    character, parameter::dir_sep = '\'
#else
    character, parameter::dir_sep = '/'
#endif

    interface replace_field
        module procedure replace_field_text
        module procedure replace_field_int
    end interface

contains

    function is_absolute_path(path)
    implicit none
    
        logical::is_absolute_path
        character(len=*), intent(in)::path
        
        is_absolute_path = .false.
        if(path(1:1) == dir_sep) then
            is_absolute_path = .true.
        else
#ifdef WINDOWS
            if(path(2:2) == ":") then
                is_absolute_path = .true.
            end if
#endif
        end if
        
    end function is_absolute_path
        
    subroutine combine_paths(first, second, res)
    implicit none
    
        character(len=*), intent(in)::first, second
        character(len=*), intent(out)::res
    
        integer::i
        
        i = len_trim(first)
    
        if(first(i:i) == dir_sep) then
            res = trim(first)//trim(second)
        else
            res = trim(first)//dir_sep//trim(second)
        end if
        
    end subroutine combine_paths
    
    subroutine write_date_and_time(unit_number, values)
    implicit none
    
        integer, intent(in)::unit_number
        integer, intent(in), dimension(8)::values

        write(unit_number, '(I4, A1, I0.2, A1, I0.2, 1X, I2, A1, I0.2, A1, I0.2)') &
            values(1), "-", &
            values(2), "-", &
            values(3),  &
            values(5), ":", &
            values(6), ":", &
            values(7)

    end subroutine write_date_and_time
    
    function remove_directory(absolute_dir, and_files)
    implicit none
    
        character(*), intent(in)::absolute_dir
        logical, intent(in), optional::and_files
        logical::remove_directory
        
        character(len=8)::cmd, flags
        integer::retval
        
#ifdef WINDOWS        
        flags = " "
        cmd = "rmdir"
#else
        flags = "-rf"
        cmd = "rm"
#endif

        if(present(and_files)) then
            if(and_files) then
#ifdef WINDOWS
                flags = "/S /Q"
#else
                flags = "-rf"
#endif
            end if
        end if
        
        call execute_command_line(trim(cmd)//" "//trim(flags)//" "//trim(absolute_dir), &
                                  wait=.true., exitstat=retval)
            
        remove_directory = (retval == 0)
        
    end function remove_directory
    
    function read_into_buffer(unit_number, buffer)
    implicit none
    
        integer, intent(in)::unit_number
        character, dimension(*), intent(out)::buffer
        integer::read_into_buffer
        
        integer::i, ierr
        
        ierr = 0
        i = 0
        do while(ierr == 0 .and. i < len(buffer))
            i = i + 1
            read(unit_number, iostat=ierr) buffer(i)
        end do
            
        if(ierr /= 0) then
            i = i - 1
        end if
        
        read_into_buffer = i
    
    end function read_into_buffer
    
    function generate_temporary_filename() result(fullpath)
    use iso_c_binding
    implicit none
    
        character(len=:), pointer::fullpath
        type(c_ptr)::tmp_name
        character(kind=c_char), dimension(:), pointer::cfullpath
        integer(kind=c_size_t)::clength
        integer::i
        
        interface
            function c_strlen(p) bind(c, name='strlen')
            use iso_c_binding
            type(c_ptr), value::p
            integer(kind=c_size_t)::strlen
            end function c_strlen
            
            function c_malloc(x) bind(c, name='malloc')
            use iso_c_binding
            type(c_ptr)::c_malloc
            integer(kind=c_size_t), value::x
            end function c_malloc
            
            subroutine c_free(p) bind(c, name='free')
            use iso_c_binding
            type(c_ptr), value::p
            end subroutine c_free
            
        end interface

#ifdef WINDOWS
        interface
            function GetTempPath(n, b) bind(c, name='GetTempPathA')
            use iso_c_binding
            integer(kind=c_int32_t)::GetTempPath
            integer(kind=c_int32_t), value::n
            type(c_ptr), value::b
            end function GetTempPath
        
            function GetTempFileName(pn, prefix, unique, b) bind(c, name='GetTempFileNameA')
            use iso_c_binding
            integer(kind=c_int)::GetTempFileName
            integer(kind=c_int), value::unique
            type(c_ptr), value::pn, prefix, b
            end function GetTempFileName
        end interface
        
        type(c_ptr)::tmp_path
        integer::res
        
        tmp_path = c_malloc(int(1024, kind=c_size_t))
        res = GetTempPath(1023, tmp_path)
        
        tmp_name = c_malloc(int(1024, kind=c_size_t))
        res = GetTempFileName(tmp_path, c_null_ptr, 0, tmp_name)
        
        call c_free(tmp_path)
        
        ! Convert the C Ptr to a Fortran object
        clength = c_strlen(tmp_name)
        if(clength == 0) then
            stop
        end if
        call c_f_pointer(tmp_name, cfullpath, (/ clength /))
        allocate(character(len=clength)::fullpath)
        do i = 1, clength
            fullpath(i:i) = cfullpath(i)
        end do
        
        cfullpath => null()
        call c_free(tmp_name)
        
#else
        character(32)::num_text
        real::rnum
        
        allocate(character(len=1024) :: fullpath)
        
        call random_number(rnum)
        write(num_text, *) abs(rnum)
        fullpath = "/tmp/lv."//trim(adjustl(num_text))//".tmp"
    
        !call write_log("My temp filename is: '"//trim(fullpath)//"'")
#endif
        
    end function generate_temporary_filename
    
    subroutine delete_file(filename)
    implicit none
    
        character(*), intent(in)::filename
        
#ifdef GNU
        call unlink(filename)
#else
        ! Not implemented...
#endif

    end subroutine delete_file
    
    subroutine replace_field_text(str, field, val)
    implicit none
    
        character(*), intent(inout)::str
        character(*), intent(in)::field
        character(*), intent(in)::val
    
        character(len=:), allocatable::holding
        integer::length_estimate
        integer::field_location, i
        
        ! This is too big, but close enough
        length_estimate = len_trim(str) + len_trim(val)
        allocate(character(len=length_estimate) :: holding)
        holding = " "

        ! Find the field
        field_location = index(str, "{"//trim(field)//"}")
        if(field_location > 0) then

            i = field_location + len_trim(field) + 2
            holding = str(1:field_location-1)//trim(val)//str(i:len_trim(str))

            ! Put the results back now
            str = holding
            
        end if

        deallocate(holding)
    
    end subroutine replace_field_text

    subroutine replace_field_int(str, field, val)
    implicit none
    
        character(*), intent(inout)::str
        character(*), intent(in)::field
        integer, intent(in)::val
        
        character(16)::int_text
        
        write(int_text, *) val
        
        call replace_field_text(str, field, trim(adjustl(int_text)))
        
    end subroutine replace_field_int
    
end module utilities