223031012
/
DAMASK_EICMD
mirror of https://github.com/achalhp/DAMASK_EICMD.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

Merge branch 'C-Fortran-improvements' into 'development' 

correct handling of C strings

See merge request damask/DAMASK!278
This commit is contained in:
Philip Eisenlohr 2020-11-16 15:06:49 +01:00
parent 12140bb657 5a28a5b4db
commit b4a0e775ea
3 changed files with 101 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
src/C_routines.c
View File

@ -4,25 +4,24 @@
#include <dirent.h>
#include <string.h>
#include <signal.h>
#include <pwd.h>
#include <sys/types.h>
#include <sys/stat.h>
#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;

25
src/DAMASK_interface.f90
View File

@ -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

136
src/system_routines.f90
View File

@ -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