almost working
This commit is contained in:
Martin Diehl
parent
564ff68fbb
commit
b9b490d02d
|
|
@ -1,24 +0,0 @@
|
|||
/* Unix */
|
||||
#include <unistd.h>
|
||||
#include <dirent.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
|
||||
#define GETCWD getcwd
|
||||
|
||||
|
||||
void getCurrentWorkDir(char *str,int *stat){
|
||||
if(GETCWD(str, sizeof(str)) == str){
|
||||
*stat = 0;
|
||||
}
|
||||
else{
|
||||
*stat = 1;
|
||||
}
|
||||
}
|
||||
|
||||
int isDirectory(const char *path){
|
||||
struct stat statbuf;
|
||||
if(stat(path, &statbuf) != 0)
|
||||
return 0;
|
||||
return S_ISDIR(statbuf.st_mode);
|
||||
}
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
/* Unix */
|
||||
#include <stdio.h>
|
||||
#include <unistd.h>
|
||||
#include <dirent.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
|
||||
/* http://stackoverflow.com/questions/30279228/is-there-an-alternative-to-getcwd-in-fortran-2003-2008 */
|
||||
|
||||
void getcurrentworkdir_c(char cwd[], int *stat ){
|
||||
char cwd_tmp[1024];
|
||||
if(getcwd(cwd_tmp, sizeof(cwd_tmp)) == cwd_tmp){
|
||||
*stat = 0;
|
||||
strcpy(cwd, cwd_tmp);
|
||||
}
|
||||
else{
|
||||
*stat = 1;
|
||||
}
|
||||
}
|
||||
|
||||
int isdirectory_c(const char *dir){
|
||||
struct stat statbuf;
|
||||
if(stat(dir, &statbuf) != 0)
|
||||
return 0;
|
||||
return S_ISDIR(statbuf.st_mode);
|
||||
}
|
||||
|
|
@ -25,6 +25,7 @@ include ${PETSC_DIR}/lib/petsc/conf/rules
|
|||
INCLUDE_DIRS := $(PETSC_FC_INCLUDES) -DPETSc -I../lib
|
||||
LIBRARIES := $(PETSC_WITH_EXTERNAL_LIB)
|
||||
COMPILERNAME ?= $(FC)
|
||||
CCOMPILERNAME ?= $(CC)
|
||||
LINKERNAME ?= $(FLINKER)
|
||||
|
||||
# MPI compiler wrappers will tell if they are pointing to ifort or gfortran
|
||||
|
|
@ -350,7 +351,7 @@ DAMASK_spectral.o: INTERFACENAME := spectral_interface.f90
|
|||
SPECTRAL_SOLVER_FILES = spectral_mech_AL.o spectral_mech_Basic.o spectral_mech_Polarisation.o \
|
||||
spectral_thermal.o spectral_damage.o
|
||||
|
||||
SPECTRAL_FILES = prec.o DAMASK_interface.o IO.o libs.o numerics.o debug.o math.o \
|
||||
SPECTRAL_FILES = C_routines.o system_routines.o prec.o DAMASK_interface.o IO.o libs.o numerics.o debug.o math.o \
|
||||
FEsolving.o mesh.o material.o lattice.o \
|
||||
$(SOURCE_FILES) $(KINEMATICS_FILES) $(PLASTIC_FILES) constitutive.o \
|
||||
crystallite.o \
|
||||
|
|
@ -622,36 +623,25 @@ libs.o: libs.f90 \
|
|||
IO.o: IO.f90 \
|
||||
DAMASK_interface.o
|
||||
|
||||
ifeq "$(F90)" "gfortran"
|
||||
DAMASK_interface.o: spectral_interface.f90 \
|
||||
$(wildcard DAMASK_FEM_interface.f90) \
|
||||
prec.o
|
||||
$(PREFIX) $(COMPILERNAME) $(COMPILE) -c $(INTERFACENAME) -fall-intrinsics -o DAMASK_interface.o $(SUFFIX)
|
||||
#-fall-intrinsics: all intrinsic procedures (including the GNU-specific extensions) are accepted. -Wintrinsics-std will be ignored
|
||||
# and no user-defined procedure with the same name as any intrinsic will be called except when it is explicitly declared external
|
||||
# --> allows the use of 'getcwd'
|
||||
prec.o: prec.f90
|
||||
$(PREFIX) $(COMPILERNAME) $(COMPILE) -c prec.f90 -fno-range-check -fall-intrinsics -fno-fast-math $(SUFFIX)
|
||||
# fno-range-check: Disable range checking on results of simplification of constant expressions during compilation
|
||||
# --> allows the definition of DAMASK_NaN
|
||||
#-fall-intrinsics: all intrinsic procedures (including the GNU-specific extensions) are accepted. -Wintrinsics-std will be ignored
|
||||
# and no user-defined procedure with the same name as any intrinsic will be called except when it is explicitly declared external
|
||||
# --> allows the use of 'isnan'
|
||||
#-fno-fast-math:
|
||||
# --> otherwise, when setting -ffast-math, isnan always evaluates to false (I would call it a bug)
|
||||
else
|
||||
DAMASK_interface.o: spectral_interface.f90 \
|
||||
$(wildcard DAMASK_FEM_interface.f90) \
|
||||
prec.o
|
||||
$(PREFIX) $(COMPILERNAME) $(COMPILE) -c $(INTERFACENAME) -diag-remark 7410 -stand none -warn nostderrors -o DAMASK_interface.o $(SUFFIX)
|
||||
# -diag-disable 7410 should disable warning about directory statement in inquire function, but does not work. hence the other 2 statements
|
||||
prec.o: prec.f90
|
||||
$(PREFIX) $(COMPILERNAME) $(COMPILE) -c prec.f90 $(SUFFIX)
|
||||
endif
|
||||
|
||||
prec.o: prec.f90 \
|
||||
system_routines.o
|
||||
|
||||
C_routines.o: C_routines.c
|
||||
|
||||
system_routines.o: system_routines.f90 \
|
||||
C_routines.o
|
||||
|
||||
|
||||
%.o : %.f90
|
||||
$(PREFIX) $(COMPILERNAME) $(COMPILE) -c $< $(SUFFIX)
|
||||
|
||||
%.o : %.c
|
||||
$(CCOMPILERNAME) -c $<
|
||||
|
||||
.PHONY: tidy
|
||||
tidy:
|
||||
@rm -rf *.o
|
||||
|
|
|
|||
|
|
@ -11,7 +11,6 @@
|
|||
module DAMASK_interface
|
||||
use prec, only: &
|
||||
pInt
|
||||
|
||||
implicit none
|
||||
private
|
||||
#ifdef PETSc
|
||||
|
|
@ -39,7 +38,6 @@ module DAMASK_interface
|
|||
IIO_intValue, &
|
||||
IIO_lc, &
|
||||
IIO_stringPos
|
||||
|
||||
contains
|
||||
|
||||
!--------------------------------------------------------------------------------------------------
|
||||
|
|
@ -99,7 +97,6 @@ subroutine DAMASK_interface_init(loadCaseParameterIn,geometryParameterIn)
|
|||
write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>'
|
||||
#include "compilation_info.f90"
|
||||
endif mainProcess
|
||||
|
||||
if ( present(loadcaseParameterIn) .and. present(geometryParameterIn)) then ! both mandatory parameters given in function call
|
||||
geometryArg = geometryParameterIn
|
||||
loadcaseArg = loadcaseParameterIn
|
||||
|
|
@ -221,35 +218,31 @@ end subroutine DAMASK_interface_init
|
|||
!> @todo change working directory with call chdir(storeWorkingDirectory)?
|
||||
!--------------------------------------------------------------------------------------------------
|
||||
character(len=1024) function storeWorkingDirectory(workingDirectoryArg,geometryArg)
|
||||
#ifdef __INTEL_COMPILER
|
||||
use IFPORT
|
||||
#endif
|
||||
use system_routines, only: &
|
||||
isDirectory, &
|
||||
getCWD2
|
||||
|
||||
implicit none
|
||||
character(len=*), intent(in) :: workingDirectoryArg !< working directory argument
|
||||
character(len=*), intent(in) :: geometryArg !< geometry argument
|
||||
character(len=1024) :: cwd
|
||||
character :: pathSep
|
||||
logical :: dirExists
|
||||
logical :: error
|
||||
external :: quit
|
||||
integer :: error
|
||||
|
||||
|
||||
|
||||
pathSep = getPathSep()
|
||||
if (len(workingDirectoryArg)>0) then ! got working directory as input
|
||||
if (workingDirectoryArg(1:1) == pathSep) then ! absolute path given as command line argument
|
||||
storeWorkingDirectory = workingDirectoryArg
|
||||
else
|
||||
error = getcwd(cwd) ! relative path given as command line argument
|
||||
error = getCWD2(cwd) ! relative path given as command line argument
|
||||
storeWorkingDirectory = trim(cwd)//pathSep//workingDirectoryArg
|
||||
endif
|
||||
if (storeWorkingDirectory(len(trim(storeWorkingDirectory)):len(trim(storeWorkingDirectory))) & ! if path seperator is not given, append it
|
||||
/= pathSep) storeWorkingDirectory = trim(storeWorkingDirectory)//pathSep
|
||||
#ifdef __INTEL_COMPILER
|
||||
inquire(directory = trim(storeWorkingDirectory)//'.', exist=dirExists)
|
||||
#else
|
||||
inquire(file = trim(storeWorkingDirectory), exist=dirExists)
|
||||
#endif
|
||||
if(.not. dirExists) then ! check if the directory exists
|
||||
if(.not. isDirectory(trim(storeWorkingDirectory))) then ! check if the directory exists
|
||||
write(6,'(a20,a,a16)') ' working directory "',trim(storeWorkingDirectory),'" does not exist'
|
||||
call quit(1_pInt)
|
||||
endif
|
||||
|
|
@ -257,7 +250,7 @@ character(len=1024) function storeWorkingDirectory(workingDirectoryArg,geometryA
|
|||
if (geometryArg(1:1) == pathSep) then ! absolute path given as command line argument
|
||||
storeWorkingDirectory = geometryArg(1:scan(geometryArg,pathSep,back=.true.))
|
||||
else
|
||||
error = getcwd(cwd) ! relative path given as command line argument
|
||||
error = getCWD2(cwd) ! relative path given as command line argument
|
||||
storeWorkingDirectory = trim(cwd)//pathSep//&
|
||||
geometryArg(1:scan(geometryArg,pathSep,back=.true.))
|
||||
endif
|
||||
|
|
@ -309,9 +302,6 @@ end function getSolverJobName
|
|||
!> @brief basename of geometry file with extension from command line arguments
|
||||
!--------------------------------------------------------------------------------------------------
|
||||
character(len=1024) function getGeometryFile(geometryParameter)
|
||||
#ifdef __INTEL_COMPILER
|
||||
use IFPORT
|
||||
#endif
|
||||
|
||||
implicit none
|
||||
character(len=1024), intent(in) :: &
|
||||
|
|
@ -320,7 +310,7 @@ character(len=1024) function getGeometryFile(geometryParameter)
|
|||
cwd
|
||||
integer :: posExt, posSep
|
||||
character :: pathSep
|
||||
integer :: error
|
||||
logical :: error
|
||||
|
||||
getGeometryFile = geometryParameter
|
||||
pathSep = getPathSep()
|
||||
|
|
@ -329,7 +319,7 @@ character(len=1024) function getGeometryFile(geometryParameter)
|
|||
|
||||
if (posExt <= posSep) getGeometryFile = trim(getGeometryFile)//('.geom') ! no extension present
|
||||
if (scan(getGeometryFile,pathSep) /= 1) then ! relative path given as command line argument
|
||||
error = getcwd(cwd)
|
||||
error = getCWD2(cwd)
|
||||
getGeometryFile = rectifyPath(trim(cwd)//pathSep//getGeometryFile)
|
||||
else
|
||||
getGeometryFile = rectifyPath(getGeometryFile)
|
||||
|
|
@ -344,16 +334,14 @@ end function getGeometryFile
|
|||
!> @brief relative path of loadcase from command line arguments
|
||||
!--------------------------------------------------------------------------------------------------
|
||||
character(len=1024) function getLoadCaseFile(loadCaseParameter)
|
||||
#ifdef __INTEL_COMPILER
|
||||
use IFPORT
|
||||
#endif
|
||||
|
||||
implicit none
|
||||
character(len=1024), intent(in) :: &
|
||||
loadCaseParameter
|
||||
character(len=1024) :: &
|
||||
cwd
|
||||
integer :: posExt, posSep, error
|
||||
integer :: posExt, posSep
|
||||
logical :: error
|
||||
character :: pathSep
|
||||
|
||||
getLoadCaseFile = loadcaseParameter
|
||||
|
|
@ -363,7 +351,7 @@ character(len=1024) function getLoadCaseFile(loadCaseParameter)
|
|||
|
||||
if (posExt <= posSep) getLoadCaseFile = trim(getLoadCaseFile)//('.load') ! no extension present
|
||||
if (scan(getLoadCaseFile,pathSep) /= 1) then ! relative path given as command line argument
|
||||
error = getcwd(cwd)
|
||||
error = getCWD2(cwd)
|
||||
getLoadCaseFile = rectifyPath(trim(cwd)//pathSep//getLoadCaseFile)
|
||||
else
|
||||
getLoadCaseFile = rectifyPath(getLoadCaseFile)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,63 @@
|
|||
module system_routines
|
||||
|
||||
implicit none
|
||||
private
|
||||
|
||||
public :: &
|
||||
isDirectory, &
|
||||
getCWD2
|
||||
|
||||
interface
|
||||
|
||||
function isDirectory_C(path) BIND(C)
|
||||
use, intrinsic :: ISO_C_Binding, only: &
|
||||
C_INT, &
|
||||
C_CHAR
|
||||
integer(C_INT) :: isDirectory_C
|
||||
character(kind=C_CHAR),intent(in) :: path(*)
|
||||
end function isDirectory_C
|
||||
|
||||
subroutine getCurrentWorkDir_C(str_out, stat) bind(C)
|
||||
use, intrinsic :: ISO_C_Binding, only: &
|
||||
C_INT, &
|
||||
C_CHAR
|
||||
character( kind=c_char ), dimension(*), intent(inout) :: str_out
|
||||
integer(C_INT),intent(out) :: stat
|
||||
|
||||
end subroutine getCurrentWorkDir_C
|
||||
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
logical function isDirectory(path)
|
||||
use, intrinsic :: ISO_C_Binding, only: &
|
||||
C_INT
|
||||
|
||||
implicit none
|
||||
character(len=*), intent(in) :: path
|
||||
|
||||
isDirectory=merge(.True.,.False.,isDirectory_C(trim(path)) /= 0_C_INT)
|
||||
|
||||
end function isDirectory
|
||||
|
||||
|
||||
logical function getCWD2(str)
|
||||
use, intrinsic :: ISO_C_Binding, only: &
|
||||
C_INT, &
|
||||
C_CHAR, &
|
||||
C_NULL_CHAR
|
||||
|
||||
implicit none
|
||||
character(len=1024), intent(out) :: str
|
||||
integer(C_INT) :: stat
|
||||
|
||||
str = repeat(C_NULL_CHAR,1024)
|
||||
call getCurrentWorkDir_C(str,stat)
|
||||
getCWD2=merge(.True.,.False.,stat /= 0_C_INT)
|
||||
|
||||
end function getCWD2
|
||||
|
||||
end module system_routines
|
||||
|
||||
Loading…
Reference in New Issue