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
|
|
|
|
|
2019-03-24 16:29:00 +05:30
|
|
|
implicit none
|
2020-11-14 19:06:10 +05:30
|
|
|
private
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2019-03-24 16:29:00 +05:30
|
|
|
public :: &
|
2020-11-14 19:06:10 +05:30
|
|
|
setCWD, &
|
2019-03-24 16:29:00 +05:30
|
|
|
getCWD, &
|
|
|
|
getHostName, &
|
2020-11-14 19:06:10 +05:30
|
|
|
getUserName, &
|
2022-05-12 20:15:42 +05:30
|
|
|
signalint_C, &
|
2020-11-14 19:06:10 +05:30
|
|
|
signalusr1_C, &
|
2022-04-13 01:44:04 +05:30
|
|
|
signalusr2_C, &
|
|
|
|
f_c_string, &
|
|
|
|
free_C
|
2020-01-26 16:49:36 +05:30
|
|
|
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2020-11-14 19:06:10 +05:30
|
|
|
interface
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
function setCWD_C(cwd) bind(C)
|
|
|
|
use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR
|
2022-02-06 19:50:26 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
integer(C_INT) :: setCWD_C
|
|
|
|
character(kind=C_CHAR), dimension(*), intent(in) :: cwd
|
|
|
|
end function setCWD_C
|
2020-01-26 16:49:36 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
subroutine getCWD_C(cwd, stat) bind(C)
|
|
|
|
use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR
|
|
|
|
use prec
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
character(kind=C_CHAR), dimension(pPathLen+1), intent(out) :: cwd ! NULL-terminated array
|
|
|
|
integer(C_INT), intent(out) :: stat
|
|
|
|
end subroutine getCWD_C
|
2020-01-26 16:49:36 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
subroutine getHostName_C(hostname, stat) bind(C)
|
|
|
|
use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR
|
|
|
|
use prec
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
character(kind=C_CHAR), dimension(pStringLen+1), intent(out) :: hostname ! NULL-terminated array
|
|
|
|
integer(C_INT), intent(out) :: stat
|
|
|
|
end subroutine getHostName_C
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
subroutine getUserName_C(username, stat) bind(C)
|
|
|
|
use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR
|
|
|
|
use prec
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
character(kind=C_CHAR), dimension(pStringLen+1), intent(out) :: username ! NULL-terminated array
|
|
|
|
integer(C_INT), intent(out) :: stat
|
|
|
|
end subroutine getUserName_C
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2022-05-12 20:15:42 +05:30
|
|
|
subroutine signalint_C(handler) bind(C)
|
2022-04-13 01:44:04 +05:30
|
|
|
use, intrinsic :: ISO_C_Binding, only: C_FUNPTR
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
type(C_FUNPTR), intent(in), value :: handler
|
2022-05-12 20:15:42 +05:30
|
|
|
end subroutine signalint_C
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
subroutine signalusr1_C(handler) bind(C)
|
|
|
|
use, intrinsic :: ISO_C_Binding, only: C_FUNPTR
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
type(C_FUNPTR), intent(in), value :: handler
|
|
|
|
end subroutine signalusr1_C
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2022-04-13 01:44:04 +05:30
|
|
|
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
|
|
|
|
|
|
|
|
subroutine free_C(ptr) bind(C,name='free')
|
|
|
|
import c_ptr
|
|
|
|
type(c_ptr), value :: ptr
|
|
|
|
end subroutine free_C
|
2020-06-26 15:14:17 +05:30
|
|
|
|
|
|
|
|
2019-03-24 16:29:00 +05:30
|
|
|
end interface
|
2016-03-12 01:29:14 +05:30
|
|
|
|
|
|
|
contains
|
|
|
|
|
2020-11-14 19:06:10 +05:30
|
|
|
|
2016-05-05 16:30:46 +05:30
|
|
|
!--------------------------------------------------------------------------------------------------
|
2020-11-14 19:06:10 +05:30
|
|
|
!> @brief set the current working directory
|
2016-05-05 16:30:46 +05:30
|
|
|
!--------------------------------------------------------------------------------------------------
|
2020-11-14 19:06:10 +05:30
|
|
|
logical function setCWD(path)
|
2019-02-11 23:16:14 +05:30
|
|
|
|
2019-05-11 01:18:43 +05:30
|
|
|
character(len=*), intent(in) :: path
|
2016-03-12 01:29:14 +05:30
|
|
|
|
2021-04-13 20:21:59 +05:30
|
|
|
|
|
|
|
setCWD = setCWD_C(f_c_string(path)) /= 0_C_INT
|
2020-11-14 19:06:10 +05:30
|
|
|
|
|
|
|
end function setCWD
|
2016-03-12 01:29:14 +05:30
|
|
|
|
|
|
|
|
2016-05-05 16:30:46 +05:30
|
|
|
!--------------------------------------------------------------------------------------------------
|
2020-11-14 19:06:10 +05:30
|
|
|
!> @brief get the current working directory
|
2016-05-05 16:30:46 +05:30
|
|
|
!--------------------------------------------------------------------------------------------------
|
2020-01-04 22:55:59 +05:30
|
|
|
function getCWD()
|
2019-02-11 23:16:14 +05:30
|
|
|
|
2020-11-14 19:06:10 +05:30
|
|
|
character(len=:), allocatable :: getCWD
|
|
|
|
|
|
|
|
character(kind=C_CHAR), dimension(pPathLen+1) :: getCWD_Cstring
|
2019-05-11 01:18:43 +05:30
|
|
|
integer(C_INT) :: stat
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2021-04-13 20:21:59 +05:30
|
|
|
|
2020-11-14 19:06:10 +05:30
|
|
|
call getCWD_C(getCWD_Cstring,stat)
|
2020-08-09 09:47:14 +05:30
|
|
|
|
2020-08-09 12:23:10 +05:30
|
|
|
if(stat == 0) then
|
|
|
|
getCWD = c_f_string(getCWD_Cstring)
|
|
|
|
else
|
2020-11-14 19:06:10 +05:30
|
|
|
error stop 'invalid working directory'
|
2020-08-09 12:23:10 +05:30
|
|
|
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
|
|
|
|
2016-09-20 10:38:31 +05:30
|
|
|
|
|
|
|
!--------------------------------------------------------------------------------------------------
|
2020-11-14 19:06:10 +05:30
|
|
|
!> @brief get the host name
|
2016-09-20 10:38:31 +05:30
|
|
|
!--------------------------------------------------------------------------------------------------
|
2020-01-04 22:55:59 +05:30
|
|
|
function getHostName()
|
2019-05-09 11:55:56 +05:30
|
|
|
|
2020-11-14 19:06:10 +05:30
|
|
|
character(len=:), allocatable :: getHostName
|
|
|
|
|
|
|
|
character(kind=C_CHAR), dimension(pStringLen+1) :: getHostName_Cstring
|
2019-05-11 01:18:43 +05:30
|
|
|
integer(C_INT) :: stat
|
2020-06-26 15:14:17 +05:30
|
|
|
|
2021-04-13 20:21:59 +05:30
|
|
|
|
2020-08-09 09:47:14 +05:30
|
|
|
call getHostName_C(getHostName_Cstring,stat)
|
|
|
|
|
2020-08-09 12:23:10 +05:30
|
|
|
if(stat == 0) then
|
|
|
|
getHostName = c_f_string(getHostName_Cstring)
|
|
|
|
else
|
2020-11-14 19:06:10 +05:30
|
|
|
getHostName = 'n/a (Error!)'
|
2020-08-09 12:23:10 +05:30
|
|
|
endif
|
2016-09-20 10:38:31 +05:30
|
|
|
|
|
|
|
end function getHostName
|
|
|
|
|
2019-02-11 23:16:14 +05:30
|
|
|
|
2018-05-26 02:52:32 +05:30
|
|
|
!--------------------------------------------------------------------------------------------------
|
2020-11-14 19:06:10 +05:30
|
|
|
!> @brief get the user name
|
2018-05-26 02:52:32 +05:30
|
|
|
!--------------------------------------------------------------------------------------------------
|
2020-11-14 19:06:10 +05:30
|
|
|
function getUserName()
|
2019-05-09 11:55:56 +05:30
|
|
|
|
2020-11-14 19:06:10 +05:30
|
|
|
character(len=:), allocatable :: getUserName
|
2020-08-09 09:47:14 +05:30
|
|
|
|
2020-11-14 19:06:10 +05:30
|
|
|
character(kind=C_CHAR), dimension(pStringLen+1) :: getUserName_Cstring
|
|
|
|
integer(C_INT) :: stat
|
2020-08-09 09:47:14 +05:30
|
|
|
|
2021-04-13 20:21:59 +05:30
|
|
|
|
2020-11-14 19:06:10 +05:30
|
|
|
call getUserName_C(getUserName_Cstring,stat)
|
|
|
|
|
|
|
|
if(stat == 0) then
|
|
|
|
getUserName = c_f_string(getUserName_Cstring)
|
|
|
|
else
|
|
|
|
getUserName = 'n/a (Error!)'
|
2022-02-06 19:50:26 +05:30
|
|
|
end if
|
2020-11-14 19:06:10 +05:30
|
|
|
|
|
|
|
end function getUserName
|
2020-08-09 09:47:14 +05:30
|
|
|
|
|
|
|
|
|
|
|
!--------------------------------------------------------------------------------------------------
|
2022-02-06 19:50:26 +05:30
|
|
|
!> @brief Convert C string to Fortran string.
|
|
|
|
!> @details: C string is NULL terminated and, hence, longer by one than the Fortran string.
|
2020-08-09 09:47:14 +05:30
|
|
|
!--------------------------------------------------------------------------------------------------
|
|
|
|
pure function c_f_string(c_string) result(f_string)
|
|
|
|
|
|
|
|
character(kind=C_CHAR), dimension(:), intent(in) :: c_string
|
|
|
|
character(len=:), allocatable :: f_string
|
2021-04-13 20:21:59 +05:30
|
|
|
|
2020-08-09 09:47:14 +05:30
|
|
|
integer :: i
|
|
|
|
|
2021-04-13 20:21:59 +05:30
|
|
|
|
2020-08-09 09:47:14 +05:30
|
|
|
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
|
2022-02-06 19:50:26 +05:30
|
|
|
end if
|
|
|
|
end do arrayToString
|
2020-08-09 09:47:14 +05:30
|
|
|
|
|
|
|
end function c_f_string
|
|
|
|
|
|
|
|
|
|
|
|
!--------------------------------------------------------------------------------------------------
|
2022-02-06 19:50:26 +05:30
|
|
|
!> @brief Convert Fortran string to C string.
|
|
|
|
!> @details: C string is NULL terminated and, hence, longer by one than the Fortran string.
|
2020-08-09 09:47:14 +05:30
|
|
|
!--------------------------------------------------------------------------------------------------
|
|
|
|
pure function f_c_string(f_string) result(c_string)
|
|
|
|
|
2020-11-14 19:06:10 +05:30
|
|
|
character(len=*), intent(in) :: f_string
|
|
|
|
character(kind=C_CHAR), dimension(len_trim(f_string)+1) :: c_string
|
2021-04-13 20:21:59 +05:30
|
|
|
|
|
|
|
|
2022-02-06 19:50:26 +05:30
|
|
|
c_string = transfer(trim(f_string)//C_NULL_CHAR,c_string,size=size(c_string))
|
2020-08-09 09:47:14 +05:30
|
|
|
|
|
|
|
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
|
|
|
|
|