diff --git a/src/C_routines.c b/src/C_routines.c index 98dc25e45..4b07c0ee0 100644 --- a/src/C_routines.c +++ b/src/C_routines.c @@ -4,25 +4,24 @@ #include #include #include +#include #include #include #include "zlib.h" -/* http://stackoverflow.com/questions/30279228/is-there-an-alternative-to-getcwd-in-fortran-2003-2008 */ +#define PATHLEN 4096 +#define STRLEN 256 -int isdirectory_c(const char *dir){ - struct stat statbuf; - if(stat(dir, &statbuf) != 0) /* error */ - return 0; /* return "NO, this is not a directory" */ - return S_ISDIR(statbuf.st_mode); /* 1 => is directory, 0 => this is NOT a directory */ +int setcwd_c(const char *cwd){ + return chdir(cwd); } -void getcurrentworkdir_c(char cwd[], int *stat ){ - char cwd_tmp[4096]; - if(getcwd(cwd_tmp, sizeof(cwd_tmp)) == cwd_tmp){ - strcpy(cwd,cwd_tmp); +void getcwd_c(char cwd[], int *stat ){ + char cwd_tmp[PATHLEN+1]; + if(getcwd(cwd_tmp, sizeof(cwd_tmp))){ + strcpy(cwd,cwd_tmp); // getcwd guarantees a NULL-terminated string *stat = 0; } else{ @@ -32,9 +31,9 @@ void getcurrentworkdir_c(char cwd[], int *stat ){ void gethostname_c(char hostname[], int *stat){ - char hostname_tmp[4096]; + char hostname_tmp[STRLEN]; if(gethostname(hostname_tmp, sizeof(hostname_tmp)) == 0){ - strcpy(hostname,hostname_tmp); + strncpy(hostname,hostname_tmp,sizeof(hostname_tmp)+1); // gethostname does not guarantee a NULL-terminated string *stat = 0; } else{ @@ -43,10 +42,18 @@ void gethostname_c(char hostname[], int *stat){ } -int chdir_c(const char *dir){ - return chdir(dir); +void getusername_c(char username[], int *stat){ + struct passwd *pw = getpwuid(geteuid()); + if(pw && strlen(pw->pw_name) <= STRLEN){ + strncpy(username,pw->pw_name,STRLEN+1); + *stat = 0; + } + else{ + *stat = 1; + } } + void signalterm_c(void (*handler)(int)){ signal(SIGTERM, handler); } @@ -59,6 +66,7 @@ void signalusr2_c(void (*handler)(int)){ signal(SIGUSR2, handler); } + void inflate_c(const uLong *s_deflated, const uLong *s_inflated, const Byte deflated[], Byte inflated[]){ /* make writable copy, uncompress will write to it */ uLong s_inflated_,i; diff --git a/src/DAMASK_interface.f90 b/src/DAMASK_interface.f90 index 52971ae06..3e3f981e2 100644 --- a/src/DAMASK_interface.f90 +++ b/src/DAMASK_interface.f90 @@ -69,8 +69,6 @@ subroutine DAMASK_interface_init loadCaseArg = '', & !< -l argument given to the executable geometryArg = '', & !< -g argument given to the executable workingDirArg = '' !< -w argument given to the executable - character(len=pStringLen) :: & - userName !< name of user calling the executable integer :: & stat, & i @@ -117,6 +115,9 @@ subroutine DAMASK_interface_init print'(/,a)', ' Compiled on: '//__DATE__//' at '//__TIME__ + print'(/,a,i0,a,i0,a,i0)', & + ' PETSc version: ',PETSC_VERSION_MAJOR,'.',PETSC_VERSION_MINOR,'.',PETSC_VERSION_SUBMINOR + call date_and_time(values = dateAndTime) print'(/,a,2(i2.2,a),i4.4)', ' Date: ',dateAndTime(3),'/',dateAndTime(2),'/', dateAndTime(1) print'(a,2(i2.2,a),i2.2)', ' Time: ',dateAndTime(5),':', dateAndTime(6),':', dateAndTime(7) @@ -189,17 +190,15 @@ subroutine DAMASK_interface_init interface_loadFile = getLoadCaseFile(loadCaseArg) call get_command(commandLine) - call get_environment_variable('USER',userName) - ! ToDo: https://stackoverflow.com/questions/8953424/how-to-get-the-username-in-c-c-in-linux - print'(a)', ' Host name: '//trim(getHostName()) - print'(a)', ' User name: '//trim(userName) + print'(/,a)', ' Host name: '//getHostName() + print'(a)', ' User name: '//getUserName() print'(/a)', ' Command line call: '//trim(commandLine) if (len_trim(workingDirArg) > 0) & print'(a)', ' Working dir argument: '//trim(workingDirArg) print'(a)', ' Geometry argument: '//trim(geometryArg) - print'(a)', ' Load case argument: '//trim(loadcaseArg) - print'(a)', ' Working directory: '//getCWD() + print'(a)', ' Loadcase argument: '//trim(loadcaseArg) + print'(/,a)', ' Working directory: '//getCWD() print'(a)', ' Geometry file: '//interface_geomFile print'(a)', ' Loadcase file: '//interface_loadFile print'(a)', ' Solver job name: '//getSolverJobName() @@ -222,8 +221,8 @@ end subroutine DAMASK_interface_init !-------------------------------------------------------------------------------------------------- subroutine setWorkingDirectory(workingDirectoryArg) - character(len=*), intent(in) :: workingDirectoryArg !< working directory argument - character(len=pPathLen) :: workingDirectory + character(len=*), intent(in) :: workingDirectoryArg !< working directory argument + character(len=:), allocatable :: workingDirectory logical :: error external :: quit @@ -359,12 +358,12 @@ end function rectifyPath !-------------------------------------------------------------------------------------------------- -!> @brief relative path from absolute a to absolute b +!> @brief Determine relative path from absolute a to absolute b !-------------------------------------------------------------------------------------------------- function makeRelativePath(a,b) - character (len=*), intent(in) :: a,b - character (len=pPathLen) :: a_cleaned,b_cleaned + character(len=*), intent(in) :: a,b + character(len=pPathLen) :: a_cleaned,b_cleaned character(len=:), allocatable :: makeRelativePath integer :: i,posLastCommonSlash,remainingSlashes diff --git a/src/system_routines.f90 b/src/system_routines.f90 index 9a2442163..309b96b7e 100644 --- a/src/system_routines.f90 +++ b/src/system_routines.f90 @@ -8,79 +8,65 @@ module system_routines use prec implicit none + private public :: & - signalterm_C, & - signalusr1_C, & - signalusr2_C, & - isDirectory, & + setCWD, & getCWD, & getHostName, & - setCWD + getUserName, & + signalterm_C, & + signalusr1_C, & + signalusr2_C + interface - function isDirectory_C(path) bind(C) - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR + function setCWD_C(cwd) bind(C) + use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR + + integer(C_INT) :: setCWD_C + character(kind=C_CHAR), dimension(*), intent(in) :: cwd + end function setCWD_C + subroutine getCWD_C(cwd, stat) 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 + character(kind=C_CHAR), dimension(pPathLen+1), intent(out) :: cwd ! NULL-terminated array integer(C_INT), intent(out) :: stat + end subroutine getCWD_C + + subroutine getHostName_C(hostname, stat) bind(C) + use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR + use prec + + character(kind=C_CHAR), dimension(pStringLen+1), intent(out) :: hostname ! NULL-terminated 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 - + subroutine getUserName_C(username, stat) 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 + character(kind=C_CHAR), dimension(pStringLen+1), intent(out) :: username ! NULL-terminated array + integer(C_INT), intent(out) :: stat + end subroutine getUserName_C subroutine signalterm_C(handler) bind(C) - use, intrinsic :: ISO_C_Binding, only: & - C_FUNPTR + 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 + 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 + use, intrinsic :: ISO_C_Binding, only: C_FUNPTR type(C_FUNPTR), intent(in), value :: handler end subroutine signalusr2_C @@ -89,45 +75,48 @@ module system_routines contains + !-------------------------------------------------------------------------------------------------- -!> @brief figures out if a given path is a directory (and not an ordinary file) +!> @brief set the current working directory !-------------------------------------------------------------------------------------------------- -logical function isDirectory(path) +logical function setCWD(path) character(len=*), intent(in) :: path - - isDirectory=merge(.True.,.False.,isDirectory_C(f_c_string(path)) /= 0_C_INT) -end function isDirectory + setCWD=merge(.True.,.False.,setCWD_C(f_c_string(path)) /= 0_C_INT) + +end function setCWD !-------------------------------------------------------------------------------------------------- -!> @brief gets the current working directory +!> @brief get the current working directory !-------------------------------------------------------------------------------------------------- function getCWD() - character(kind=C_CHAR), dimension(pPathLen) :: getCWD_Cstring - character(len=:), allocatable :: getCWD + character(len=:), allocatable :: getCWD + + character(kind=C_CHAR), dimension(pPathLen+1) :: getCWD_Cstring integer(C_INT) :: stat - call getCurrentWorkDir_C(getCWD_Cstring,stat) + call getCWD_C(getCWD_Cstring,stat) if(stat == 0) then getCWD = c_f_string(getCWD_Cstring) else - getCWD = 'Error occured when getting currend working directory' + error stop 'invalid working directory' endif end function getCWD !-------------------------------------------------------------------------------------------------- -!> @brief gets the current host name +!> @brief get the host name !-------------------------------------------------------------------------------------------------- function getHostName() - character(kind=C_CHAR), dimension(pPathLen) :: getHostName_Cstring - character(len=:), allocatable :: getHostName + character(len=:), allocatable :: getHostName + + character(kind=C_CHAR), dimension(pStringLen+1) :: getHostName_Cstring integer(C_INT) :: stat call getHostName_C(getHostName_Cstring,stat) @@ -135,22 +124,31 @@ function getHostName() if(stat == 0) then getHostName = c_f_string(getHostName_Cstring) else - getHostName = 'Error occured when getting host name' + getHostName = 'n/a (Error!)' endif end function getHostName !-------------------------------------------------------------------------------------------------- -!> @brief changes the current working directory +!> @brief get the user name !-------------------------------------------------------------------------------------------------- -logical function setCWD(path) +function getUserName() - character(len=*), intent(in) :: path + character(len=:), allocatable :: getUserName - setCWD=merge(.True.,.False.,chdir_C(f_c_string(path)) /= 0_C_INT) + character(kind=C_CHAR), dimension(pStringLen+1) :: getUserName_Cstring + integer(C_INT) :: stat -end function setCWD + call getUserName_C(getUserName_Cstring,stat) + + if(stat == 0) then + getUserName = c_f_string(getUserName_Cstring) + else + getUserName = 'n/a (Error!)' + endif + +end function getUserName !-------------------------------------------------------------------------------------------------- @@ -182,14 +180,14 @@ end function c_f_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 + character(len=*), intent(in) :: f_string + character(kind=C_CHAR), dimension(len_trim(f_string)+1) :: c_string integer :: i - do i=1,len(f_string) + do i=1,len_trim(f_string) c_string(i)=f_string(i:i) enddo - c_string(i) = C_NULL_CHAR + c_string(len_trim(f_string)+1) = C_NULL_CHAR end function f_c_string