DAMASK_EICMD/src/system_routines.f90

199 lines
6.0 KiB
Fortran
Raw Normal View History

2016-05-05 16:30:46 +05:30
!--------------------------------------------------------------------------------------------------
2020-06-26 15:14:17 +05:30
!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH
!> @brief Wrappers to C routines for system operations
2016-05-05 16:30:46 +05:30
!--------------------------------------------------------------------------------------------------
2016-03-12 01:29:14 +05:30
module system_routines
2019-05-11 01:18:43 +05:30
use, intrinsic :: ISO_C_Binding
2020-06-26 15:14:17 +05:30
use prec
implicit none
2020-06-26 15:14:17 +05:30
public :: &
signalterm_C, &
signalusr1_C, &
signalusr2_C, &
isDirectory, &
getCWD, &
getHostName, &
setCWD
2020-06-26 15:14:17 +05:30
interface
2020-06-26 15:14:17 +05:30
function isDirectory_C(path) bind(C)
use, intrinsic :: ISO_C_Binding, only: &
C_INT, &
C_CHAR
2020-01-26 16:49:36 +05:30
use prec
2020-06-26 15:14:17 +05:30
integer(C_INT) :: isDirectory_C
2020-01-26 16:49:36 +05:30
character(kind=C_CHAR), dimension(pPathLen), intent(in) :: path ! C string is an array
2020-07-25 02:14:41 +05:30
end function isDirectory_C
2020-06-26 15:14:17 +05:30
2020-01-26 16:49:36 +05:30
subroutine getCurrentWorkDir_C(path, stat) bind(C)
use, intrinsic :: ISO_C_Binding, only: &
C_INT, &
C_CHAR
2020-01-26 16:49:36 +05:30
use prec
2020-06-26 15:14:17 +05:30
2020-01-26 16:49:36 +05:30
character(kind=C_CHAR), dimension(pPathLen), intent(out) :: path ! C string is an array
integer(C_INT), intent(out) :: stat
2020-07-25 02:14:41 +05:30
end subroutine getCurrentWorkDir_C
2020-06-26 15:14:17 +05:30
subroutine getHostName_C(str, stat) bind(C)
use, intrinsic :: ISO_C_Binding, only: &
C_INT, &
C_CHAR
2020-01-26 16:49:36 +05:30
use prec
2020-06-26 15:14:17 +05:30
2020-01-26 16:49:36 +05:30
character(kind=C_CHAR), dimension(pStringLen), intent(out) :: str ! C string is an array
integer(C_INT), intent(out) :: stat
2020-07-25 02:14:41 +05:30
end subroutine getHostName_C
2020-06-26 15:14:17 +05:30
function chdir_C(path) bind(C)
use, intrinsic :: ISO_C_Binding, only: &
C_INT, &
C_CHAR
2020-01-26 16:49:36 +05:30
use prec
2020-06-26 15:14:17 +05:30
integer(C_INT) :: chdir_C
2020-01-26 16:49:36 +05:30
character(kind=C_CHAR), dimension(pPathLen), intent(in) :: path ! C string is an array
end function chdir_C
2020-06-26 15:14:17 +05:30
subroutine signalterm_C(handler) bind(C)
use, intrinsic :: ISO_C_Binding, only: &
C_FUNPTR
2020-06-26 15:14:17 +05:30
type(C_FUNPTR), intent(in), value :: handler
end subroutine signalterm_C
2020-06-26 15:14:17 +05:30
subroutine signalusr1_C(handler) bind(C)
use, intrinsic :: ISO_C_Binding, only: &
C_FUNPTR
2020-06-26 15:14:17 +05:30
type(C_FUNPTR), intent(in), value :: handler
end subroutine signalusr1_C
2020-06-26 15:14:17 +05:30
subroutine signalusr2_C(handler) bind(C)
use, intrinsic :: ISO_C_Binding, only: &
C_FUNPTR
2020-06-26 15:14:17 +05:30
type(C_FUNPTR), intent(in), value :: handler
end subroutine signalusr2_C
2020-06-26 15:14:17 +05:30
end interface
2016-03-12 01:29:14 +05:30
contains
2016-05-05 16:30:46 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief figures out if a given path is a directory (and not an ordinary file)
!--------------------------------------------------------------------------------------------------
logical function isDirectory(path)
2019-05-11 01:18:43 +05:30
character(len=*), intent(in) :: path
2020-08-09 09:47:14 +05:30
isDirectory=merge(.True.,.False.,isDirectory_C(f_c_string(path)) /= 0_C_INT)
2016-03-12 01:29:14 +05:30
2016-05-05 16:30:46 +05:30
end function isDirectory
2016-03-12 01:29:14 +05:30
2016-05-05 16:30:46 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief gets the current working directory
!--------------------------------------------------------------------------------------------------
function getCWD()
2020-08-09 09:47:14 +05:30
character(kind=C_CHAR), dimension(pPathLen) :: getCWD_Cstring
2020-01-26 16:49:36 +05:30
character(len=:), allocatable :: getCWD
2019-05-11 01:18:43 +05:30
integer(C_INT) :: stat
2020-06-26 15:14:17 +05:30
2020-08-09 09:47:14 +05:30
call getCurrentWorkDir_C(getCWD_Cstring,stat)
if(stat == 0) then
getCWD = c_f_string(getCWD_Cstring)
else
getCWD = 'Error occured when getting currend working directory'
endif
2016-03-12 01:29:14 +05:30
2016-05-05 16:30:46 +05:30
end function getCWD
2016-03-12 01:29:14 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief gets the current host name
!--------------------------------------------------------------------------------------------------
function getHostName()
2019-05-09 11:55:56 +05:30
2020-08-09 09:47:14 +05:30
character(kind=C_CHAR), dimension(pPathLen) :: getHostName_Cstring
2020-01-26 16:49:36 +05:30
character(len=:), allocatable :: getHostName
2019-05-11 01:18:43 +05:30
integer(C_INT) :: stat
2020-06-26 15:14:17 +05:30
2020-08-09 09:47:14 +05:30
call getHostName_C(getHostName_Cstring,stat)
if(stat == 0) then
getHostName = c_f_string(getHostName_Cstring)
else
getHostName = 'Error occured when getting host name'
endif
end function getHostName
2018-05-26 02:52:32 +05:30
!--------------------------------------------------------------------------------------------------
!> @brief changes the current working directory
!--------------------------------------------------------------------------------------------------
logical function setCWD(path)
2019-05-09 11:55:56 +05:30
2019-05-11 01:18:43 +05:30
character(len=*), intent(in) :: path
2020-08-09 09:47:14 +05:30
setCWD=merge(.True.,.False.,chdir_C(f_c_string(path)) /= 0_C_INT)
end function setCWD
!--------------------------------------------------------------------------------------------------
!> @brief convert C string to Fortran string
!> @details: C string is NULL terminated and, hence, longer by one than the Fortran string
!--------------------------------------------------------------------------------------------------
pure function c_f_string(c_string) result(f_string)
character(kind=C_CHAR), dimension(:), intent(in) :: c_string
character(len=:), allocatable :: f_string
integer :: i
allocate(character(len=size(c_string))::f_string)
arrayToString: do i=1,len(f_string)
if (c_string(i) /= C_NULL_CHAR) then
f_string(i:i)=c_string(i)
else
f_string = f_string(:i-1)
exit
endif
enddo arrayToString
end function c_f_string
!--------------------------------------------------------------------------------------------------
!> @brief convert Fortran string to C string
!> @details: C string is NULL terminated and, hence, longer by one than the Fortran string
!--------------------------------------------------------------------------------------------------
pure function f_c_string(f_string) result(c_string)
character(len=*), intent(in) :: f_string
character(kind=C_CHAR), dimension(len(f_string)+1) :: c_string
2019-05-11 01:18:43 +05:30
integer :: i
2020-06-26 15:14:17 +05:30
2020-08-09 09:47:14 +05:30
do i=1,len(f_string)
c_string(i)=f_string(i:i)
2019-05-11 01:18:43 +05:30
enddo
2020-08-09 09:47:14 +05:30
c_string(i) = C_NULL_CHAR
end function f_c_string
2018-05-26 02:52:32 +05:30
2016-03-12 01:29:14 +05:30
end module system_routines