diff options
Diffstat (limited to 'common/utilities.F90')
| -rw-r--r-- | common/utilities.F90 | 222 |
1 files changed, 222 insertions, 0 deletions
diff --git a/common/utilities.F90 b/common/utilities.F90 new file mode 100644 index 0000000..2e19031 --- /dev/null +++ b/common/utilities.F90 @@ -0,0 +1,222 @@ +module utilities + +#ifdef WINDOWS + character, parameter::dir_sep = '\' +#else + character, parameter::dir_sep = '/' +#endif + +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, I2, A1, I2, 1X, I2, A1, I2, A1, I2)') & + 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 = "-r" + 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) +#else + interface + function tmpnam(p) bind(c, name='tmpnam') + use iso_c_binding + type(c_ptr), value::p + type(c_ptr)::tmpnam + end function tmpnam + end interface + + type(c_ptr)::ignored + + tmp_name = c_malloc(int(1024, kind=c_size_t)) + + ignored = tmpnam(tmp_name) +#endif + + ! Convert the C Ptr to a Fortran object + clength = c_strlen(tmp_name) + 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) + + 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 + +end module utilities
\ No newline at end of file |