system_routines.f90

Go to the documentation of this file.

# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/system_routines.f90"
# 1 "<built-in>"
# 1 "<command-line>"
# 1 "/home/damask_user/GitLabCI_Pipeline_4301/DAMASK/src/system_routines.f90"
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
module system_routines
  use, intrinsic :: iso_c_binding
  
  use prec 
  
  implicit none
  
  public :: &
    signalterm_c, &
    signalusr1_c, &
    signalusr2_c, &
    isdirectory, &
    getcwd, &
    gethostname, &
    setcwd
 
  interface
 
  function isdirectory_c(path) bind(C)
    use, intrinsic :: iso_c_binding, only: &
      c_int, &
      c_char
 
    use prec
    
    integer(C_INT) :: isdirectory_c
    character(kind=C_CHAR), dimension(pPathLen), intent(in) :: path                                 ! C string is an array
   end function isdirectory_c
 
  subroutine getcurrentworkdir_c(path, stat) bind(C)
    use, intrinsic :: iso_c_binding, only: &
      c_int, &
      c_char
 
    use prec
    
    character(kind=C_CHAR), dimension(pPathLen), intent(out) :: path                                ! C string is an array
    integer(C_INT),                              intent(out) :: stat
   end subroutine getcurrentworkdir_c
 
  subroutine gethostname_c(str, stat) bind(C)
    use, intrinsic :: iso_c_binding, only: &
      c_int, &
      c_char
 
    use prec
    
    character(kind=C_CHAR), dimension(pStringLen), intent(out) :: str                               ! C string is an array
    integer(C_INT),                                intent(out) :: stat
   end subroutine gethostname_c
 
  function chdir_c(path) bind(C)
    use, intrinsic :: iso_c_binding, only: &
      c_int, &
      c_char
 
    use prec
    
    integer(C_INT) :: chdir_c
    character(kind=C_CHAR), dimension(pPathLen), intent(in) :: path                                 ! C string is an array
  end function chdir_c
  
  subroutine signalterm_c(handler) bind(C)
    use, intrinsic :: iso_c_binding, only: &
      c_funptr
    
    type(c_funptr), intent(in), value :: handler
  end subroutine signalterm_c
 
  subroutine signalusr1_c(handler) bind(C)
    use, intrinsic :: iso_c_binding, only: &
      c_funptr
   
    type(c_funptr), intent(in), value :: handler
  end subroutine signalusr1_c
  
  subroutine signalusr2_c(handler) bind(C)
    use, intrinsic :: iso_c_binding, only: &
      c_funptr
    
    type(c_funptr), intent(in), value :: handler
  end subroutine signalusr2_c
 
  end interface
 
contains
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
logical function isdirectory(path)
 
  character(len=*), intent(in) :: path
  character(kind=C_CHAR), dimension(pPathLen) :: strfixedlength                                     ! C string as array
  integer :: i 
 
  strfixedlength = repeat(c_null_char,len(strfixedlength))
  do i=1,len(path)                                                                                  ! copy array components
    strfixedlength(i)=path(i:i)
  enddo
  isdirectory=merge(.true.,.false.,isdirectory_c(strfixedlength) /= 0_c_int)
 
end function isdirectory
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function getcwd()
 
  character(kind=C_CHAR), dimension(pPathLen) :: chararray                                          ! C string is an array
  character(len=:),       allocatable         :: getcwd
  integer(C_INT) :: stat
  integer :: i
 
  call getcurrentworkdir_c(chararray,stat)
  
  if (stat /= 0_c_int) then
    getcwd = 'Error occured when getting currend working directory'
  else
    allocate(character(len=pPathLen)::getcwd)
    arraytostring: do i=1,len(getcwd)
      if (chararray(i) /= c_null_char) then
        getcwd(i:i)=chararray(i)
      else
        getcwd = getcwd(:i-1)
        exit
      endif
    enddo arraytostring
  endif
 
end function getcwd
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
function gethostname()
 
  character(kind=C_CHAR), dimension(pPathLen) :: chararray                                          ! C string is an array
  character(len=:),       allocatable         :: gethostname
  integer(C_INT) :: stat
  integer :: i
 
  call gethostname_c(chararray,stat)
 
  if (stat /= 0_c_int) then
    gethostname = 'Error occured when getting host name'
  else
    allocate(character(len=pPathLen)::gethostname)
    arraytostring: do i=1,len(gethostname)
      if (chararray(i) /= c_null_char) then
        gethostname(i:i)=chararray(i)
      else
        gethostname = gethostname(:i-1)
        exit
      endif
    enddo arraytostring
  endif
 
end function gethostname
 
 
!--------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------
logical function setcwd(path)
 
  character(len=*), intent(in) :: path
  character(kind=C_CHAR), dimension(pPathLen) :: strfixedlength                                     ! C string is an array
  integer :: i
 
  strfixedlength = repeat(c_null_char,len(strfixedlength))
  do i=1,len(path)                                                                                  ! copy array components
    strfixedlength(i)=path(i:i)
  enddo
  setcwd=merge(.true.,.false.,chdir_c(strfixedlength) /= 0_c_int)
 
end function setcwd
 
end module system_routines