loct.F90

Go to the documentation of this file.

!! Copyright (C) 2002-2006 M. Marques, A. Castro, A. Rubio, G. Bertsch, M. Oliveira
!!
!! This program is free software; you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation; either version 2, or (at your option)
!! any later version.
!!
!! This program is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with this program; if not, write to the Free Software
!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
!! 02110-1301, USA.
!!
 
#include "global.h"
 
module loct_oct_m
  use iso_c_binding
  use, intrinsic :: iso_fortran_env
 
  implicit none
 
  private
  public ::                  &
    loct_clock,              &
    loct_gettimeofday,       &
    loct_nanosleep,          &
    loct_sysname,            &
    loct_search_file_lr,     &
    loct_mkdir,              &
    loct_rm,                 &
    loct_dir_exists,         &
    loct_dirname,            &
    loct_number_of_lines,    &
    loct_break_c_string,     &
    loct_getenv,             &
    loct_isinstringlist,     &
    loct_progress_bar,       &
    loct_print_recipe,       &
    loct_strerror,           &
    loct_get_memory_usage,   &
    loct_executable_path
 
  private :: string_f_to_c
 
  ! ---------------------------------------------------------
 
  interface loct_clock
    function oct_clock()
      use, intrinsic :: iso_fortran_env
      implicit none
      real(real64) :: oct_clock
    end function oct_clock
  end interface loct_clock
 
  interface loct_gettimeofday
    subroutine oct_gettimeofday(sec, usec)
      implicit none
      integer, intent(out) :: sec, usec
    end subroutine oct_gettimeofday
  end interface loct_gettimeofday
 
  interface loct_nanosleep
    subroutine oct_nanosleep(sec, nsec)
      implicit none
      integer, intent(in) :: sec
      integer, intent(in) :: nsec
    end subroutine oct_nanosleep
  end interface loct_nanosleep
 
  ! ---------------------------------------------------------
  interface loct_number_of_lines
    integer function oct_number_of_lines(filename) bind(c)
      use iso_c_binding
      implicit none
      character(kind=c_char), intent(in) :: filename(*)
    end function oct_number_of_lines
  end interface loct_number_of_lines
 
  interface loct_break_c_string
    subroutine oct_break_c_string(str, s, line)
      use iso_c_binding
      implicit none
      type(c_ptr),       intent(in)    :: str
      type(c_ptr),       intent(inout) :: s
      character(kind=c_char),  intent(out)   :: line(*)
    end subroutine oct_break_c_string
  end interface loct_break_c_string
 
  ! ---------------------------------------------------------
  interface loct_progress_bar
    subroutine oct_progress_bar(a, maxcount)
      implicit none
      integer, intent(in) :: a, maxcount
    end subroutine oct_progress_bar
  end interface loct_progress_bar
 
  interface loct_wfs_list
    subroutine oct_wfs_list(str, l) bind(c)
      use iso_c_binding
      implicit none
      character(kind=c_char), intent(in)  :: str(*)
      integer,                intent(out) :: l
    end subroutine oct_wfs_list
  end interface loct_wfs_list
 
  interface loct_get_memory_usage
    integer(c_intptr_t) function oct_get_memory_usage()
      use iso_c_binding, only: c_intptr_t
      implicit none
    end function oct_get_memory_usage
  end interface loct_get_memory_usage
 
contains
 
  subroutine loct_print_recipe(dir, filename)
    character(len=*), intent(in)  :: dir
    character(len=*), intent(inout) :: filename
 
    character(kind=c_char) :: c_name(len(filename)+1)
 
    interface
      subroutine oct_print_recipe(dir, filename) bind(c)
        use iso_c_binding
        implicit none
        character(kind=c_char), intent(in)  :: dir(*)
        character(kind=c_char), intent(out) :: filename(*)
      end subroutine oct_print_recipe
    end interface
 
    call oct_print_recipe(string_f_to_c(dir), c_name)
    call string_c_to_f(c_name, filename)
  end subroutine loct_print_recipe
 
 
  ! ---------------------------------------------------------
  !
  function string_f_to_c(f_string) result(c_string)
    character(len=*), intent(in) :: f_string
    character(kind=c_char,len=1) :: c_string(len_trim(f_string) + 1)
 
    integer :: i, strlen
 
    strlen = len_trim(f_string)
 
    do i = 1, strlen
      c_string(i) = f_string(i:i)
    end do
    c_string(strlen+1) = c_null_char
 
  end function string_f_to_c
 
  ! ---------------------------------------------------------
  !
  subroutine string_c_to_f(c_string, f_string)
    character(kind=c_char,len=1), intent(in)  :: c_string(*)
    character(len=*),             intent(out) :: f_string
 
    integer :: i
 
    i = 1
    do while(c_string(i) /= c_null_char .and. i <= len(f_string))
      f_string(i:i) = c_string(i)
      i = i + 1
    end do
    if (i < len(f_string)) f_string(i:) = ' '
 
  end subroutine string_c_to_f
 
  logical function loct_isinstringlist(a, s) result(inlist)
    integer,          intent(in) :: a
    character(len=*), intent(in) :: s
 
    integer, allocatable :: list(:)
 
    allocate(list(2**14))
 
    call loct_wfs_list(string_f_to_c(s), list(1))
    inlist = .false.
    if (list(a) == 1) inlist = .true.
 
    deallocate(list)
 
  end function loct_isinstringlist
 
  subroutine loct_mkdir(name)
    character(len=*), intent(in) :: name
 
    interface oct_mkdir
      subroutine oct_mkdir(name) bind(c)
        use iso_c_binding
        implicit none
        character(kind=c_char), intent(in) :: name(*)
      end subroutine oct_mkdir
    end interface oct_mkdir
 
    call oct_mkdir(string_f_to_c(name))
  end subroutine loct_mkdir
 
  subroutine loct_rm(name)
    character(len=*), intent(in) :: name
 
    interface oct_rm
      subroutine oct_rm(name) bind(c)
        use iso_c_binding
        implicit none
        character(kind=c_char), intent(in) :: name(*)
      end subroutine oct_rm
    end interface oct_rm
 
    call oct_rm(string_f_to_c(name))
  end subroutine loct_rm
 
  subroutine loct_sysname(name)
    character(len=*), intent(inout) :: name
    character(kind=c_char) :: c_name(len(name)+1)
 
    interface oct_sysname
      subroutine oct_sysname(name) bind(c)
        use iso_c_binding
        implicit none
        character(kind=c_char), intent(out) :: name(*)
      end subroutine oct_sysname
    end interface oct_sysname
 
    c_name = c_null_char
    call oct_sysname(c_name)
    call string_c_to_f(c_name, name)
  end subroutine loct_sysname
 
  logical function loct_dir_exists(dirname) result(exists)
    character(len=*), intent(in) :: dirname
 
    interface oct_dir_exists
      integer function oct_dir_exists(dirname) bind(c)
        use iso_c_binding
        implicit none
        character(kind=c_char), intent(in)    :: dirname(*)
      end function oct_dir_exists
    end interface oct_dir_exists
 
    exists = oct_dir_exists(string_f_to_c(dirname)) /= 0
 
  end function loct_dir_exists
 
  subroutine loct_getenv(var, val)
    character(len=*), intent(in)    :: var
    character(len=*), intent(inout) :: val
 
    character(kind=c_char) :: c_val(len(val)+1)
 
    interface oct_getenv
      subroutine oct_getenv(var, val) bind(c)
        use iso_c_binding
        implicit none
        character(kind=c_char), intent(in)    :: var(*)
        character(kind=c_char), intent(inout) :: val(*)
      end subroutine oct_getenv
    end interface oct_getenv
 
    c_val = c_null_char
    call oct_getenv(string_f_to_c(var), c_val)
    call string_c_to_f(c_val, val)
  end subroutine loct_getenv
 
  subroutine loct_strerror(errno, res)
    integer,          intent(in)     :: errno
    character(len=*), intent(inout)  :: res
 
    character(kind=c_char) :: cres(len(res)+1)
 
    interface oct_strerror
      subroutine oct_strerror(errno, res) bind(c)
        use iso_c_binding
        implicit none
        integer, intent(in) :: errno
        character(kind=c_char), intent(inout)  :: res(*)
      end subroutine oct_strerror
    end interface oct_strerror
 
    cres = c_null_char
    call oct_strerror(errno, cres)
    call string_c_to_f(cres, res)
  end subroutine loct_strerror
 
  subroutine loct_search_file_lr(freq, tag, ierr, dirname)
    real(real64),     intent(inout) :: freq
    integer,          intent(in)    :: tag
    integer,          intent(out)   :: ierr
    character(len=*), intent(in)    :: dirname
 
    interface
      subroutine oct_search_file_lr(freq, tag, ierr, dirname) bind(c)
        use iso_c_binding
        use, intrinsic :: iso_fortran_env
        implicit none
        real(real64),           intent(inout) :: freq
        integer,                intent(in)    :: tag
        integer,                intent(out)   :: ierr
        character(kind=c_char), intent(in)    :: dirname(*)
      end subroutine oct_search_file_lr
    end interface
 
    call oct_search_file_lr(freq, tag, ierr, string_f_to_c(dirname))
  end subroutine loct_search_file_lr
 
  subroutine loct_executable_path(fpath)
    character(len=*), intent(inout)  :: fpath
 
    character(kind=c_char) :: path(len(fpath)+1)
    interface
      subroutine oct_executable_path(path) bind(c)
        use iso_c_binding
        character(kind=c_char), intent(out)  :: path(*)
      end subroutine oct_executable_path
    end interface
 
    path = c_null_char
    call oct_executable_path(path)
    call string_c_to_f(path, fpath)
  end subroutine loct_executable_path
 
  subroutine loct_dirname(path, dir)
    character(len=*), intent(in)     :: path
    character(len=*), intent(inout)  :: dir
 
    character(kind=c_char) :: cdir(len(dir)+1)
    interface
      subroutine oct_dirname(path, dir) bind(c)
        use iso_c_binding
        character(kind=c_char), intent(in)    :: path(*)
        character(kind=c_char), intent(inout) :: dir(*)
      end subroutine oct_dirname
    end interface
 
    call oct_dirname(string_f_to_c(path), cdir)
    call string_c_to_f(cdir, dir)
  end subroutine loct_dirname
 
end module loct_oct_m
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: