Merge remote-tracking branch 'origin/development' into python-improvements
This commit is contained in:
commit
cd8434b991
|
@ -187,8 +187,6 @@ grid_mech_compile_Intel:
|
|||
stage: compilePETSc
|
||||
script:
|
||||
- module load $IntelCompiler $MPICH_Intel $PETSc_MPICH_Intel
|
||||
- cp -r grid_mech_compile grid_mech_compile_Intel
|
||||
- grid_mech_compile_Intel/test.py
|
||||
- cd pytest
|
||||
- pytest -k 'compile and grid' --basetemp=${TESTROOT}/compile_grid_Intel
|
||||
except:
|
||||
|
@ -199,8 +197,6 @@ Compile_FEM_Intel:
|
|||
stage: compilePETSc
|
||||
script:
|
||||
- module load $IntelCompiler $MPICH_Intel $PETSc_MPICH_Intel
|
||||
- cp -r FEM_compile FEM_compile_Intel
|
||||
- FEM_compile_Intel/test.py
|
||||
- cd pytest
|
||||
- pytest -k 'compile and mesh' --basetemp=${TESTROOT}/compile_mesh_Intel
|
||||
except:
|
||||
|
@ -211,8 +207,6 @@ grid_mech_compile_GNU:
|
|||
stage: compilePETSc
|
||||
script:
|
||||
- module load $GNUCompiler $MPICH_GNU $PETSc_MPICH_GNU
|
||||
- cp -r grid_mech_compile grid_mech_compile_GNU
|
||||
- grid_mech_compile_GNU/test.py
|
||||
- cd pytest
|
||||
- pytest -k 'compile and grid' --basetemp=${TESTROOT}/compile_grid_GNU
|
||||
except:
|
||||
|
@ -223,8 +217,6 @@ Compile_FEM_GNU:
|
|||
stage: compilePETSc
|
||||
script:
|
||||
- module load $GNUCompiler $MPICH_GNU $PETSc_MPICH_GNU
|
||||
- cp -r FEM_compile FEM_compile_GNU
|
||||
- FEM_compile_GNU/test.py
|
||||
- cd pytest
|
||||
- pytest -k 'compile and mesh' --basetemp=${TESTROOT}/compile_mesh_GNU
|
||||
except:
|
||||
|
@ -274,22 +266,6 @@ Nonlocal_Damage_DetectChanges:
|
|||
- master
|
||||
- release
|
||||
|
||||
grid_all_restart:
|
||||
stage: grid
|
||||
script: grid_all_restart/test.py
|
||||
except:
|
||||
- master
|
||||
- release
|
||||
|
||||
grid_all_restartMPI:
|
||||
stage: grid
|
||||
script:
|
||||
- module load $IntelCompiler $MPICH_Intel $PETSc_MPICH_Intel
|
||||
- grid_all_restartMPI/test.py
|
||||
except:
|
||||
- master
|
||||
- release
|
||||
|
||||
Plasticity_DetectChanges:
|
||||
stage: grid
|
||||
script: Plasticity_DetectChanges/test.py
|
||||
|
|
2
PRIVATE
2
PRIVATE
|
@ -1 +1 @@
|
|||
Subproject commit 281e7eb84f76a2974a50eb54faf35ea25ec89b20
|
||||
Subproject commit 2105ed1c6e4800050010ca4d73b1882022f81551
|
|
@ -1,69 +0,0 @@
|
|||
#!/usr/bin/env python3
|
||||
|
||||
import os
|
||||
import sys
|
||||
from optparse import OptionParser
|
||||
|
||||
import damask
|
||||
|
||||
|
||||
scriptName = os.path.splitext(os.path.basename(__file__))[0]
|
||||
scriptID = ' '.join([scriptName,damask.version])
|
||||
|
||||
|
||||
minimal_surfaces = list(damask.Geom._minimal_surface.keys())
|
||||
|
||||
# --------------------------------------------------------------------
|
||||
# MAIN
|
||||
# --------------------------------------------------------------------
|
||||
|
||||
parser = OptionParser(usage='%prog options [geomfile]', description = """
|
||||
Generate a bicontinuous structure of given type.
|
||||
|
||||
""", version = scriptID)
|
||||
|
||||
|
||||
parser.add_option('-t','--type',
|
||||
dest = 'type',
|
||||
choices = minimal_surfaces, metavar = 'string',
|
||||
help = 'type of minimal surface [primitive] {%s}' %(','.join(minimal_surfaces)))
|
||||
parser.add_option('-f','--threshold',
|
||||
dest = 'threshold',
|
||||
type = 'float', metavar = 'float',
|
||||
help = 'threshold value defining minimal surface [%default]')
|
||||
parser.add_option('-g', '--grid',
|
||||
dest = 'grid',
|
||||
type = 'int', nargs = 3, metavar = 'int int int',
|
||||
help = 'a,b,c grid of hexahedral box [%default]')
|
||||
parser.add_option('-s', '--size',
|
||||
dest = 'size',
|
||||
type = 'float', nargs = 3, metavar = 'float float float',
|
||||
help = 'x,y,z size of hexahedral box [%default]')
|
||||
parser.add_option('-p', '--periods',
|
||||
dest = 'periods',
|
||||
type = 'int', metavar = 'int',
|
||||
help = 'number of repetitions of unit cell [%default]')
|
||||
parser.add_option('--m',
|
||||
dest = 'microstructure',
|
||||
type = 'int', nargs = 2, metavar = 'int int',
|
||||
help = 'two microstructure indices to be used [%default]')
|
||||
|
||||
parser.set_defaults(type = minimal_surfaces[0],
|
||||
threshold = 0.0,
|
||||
periods = 1,
|
||||
grid = (16,16,16),
|
||||
size = (1.0,1.0,1.0),
|
||||
microstructure = (1,2),
|
||||
)
|
||||
|
||||
(options,filename) = parser.parse_args()
|
||||
|
||||
|
||||
name = None if filename == [] else filename[0]
|
||||
damask.util.report(scriptName,name)
|
||||
|
||||
geom=damask.Geom.from_minimal_surface(options.grid,options.size,options.type,options.threshold,
|
||||
options.periods,options.microstructure)
|
||||
damask.util.croak(geom)
|
||||
|
||||
geom.save_ASCII(sys.stdout if name is None else name)
|
|
@ -3,10 +3,6 @@ from pathlib import Path
|
|||
|
||||
class Environment:
|
||||
|
||||
def __init__(self):
|
||||
"""Do Nothing."""
|
||||
pass
|
||||
|
||||
@property
|
||||
def screen_size(self):
|
||||
try:
|
||||
|
@ -43,8 +39,3 @@ class Environment:
|
|||
def root_dir(self):
|
||||
"""Return DAMASK root path."""
|
||||
return Path(__file__).parents[2]
|
||||
|
||||
|
||||
# for compatibility
|
||||
def rootDir(self):
|
||||
return str(self.root_dir)
|
||||
|
|
|
@ -31,7 +31,7 @@ class Table:
|
|||
|
||||
def __repr__(self):
|
||||
"""Brief overview."""
|
||||
return util.srepr(self.comments)+'\n'+self.data.__repr__()
|
||||
return '\n'.join(['# '+c for c in self.comments])+'\n'+self.data.__repr__()
|
||||
|
||||
def __len__(self):
|
||||
"""Number of rows."""
|
||||
|
@ -159,7 +159,7 @@ class Table:
|
|||
comments = [util.execution_stamp('Table','from_ang')]
|
||||
for line in content:
|
||||
if line.startswith('#'):
|
||||
comments.append(line.strip())
|
||||
comments.append(line.split('#',1)[1].strip())
|
||||
else:
|
||||
break
|
||||
|
||||
|
@ -222,6 +222,7 @@ class Table:
|
|||
dup.data[label] = data.reshape(dup.data[label].shape)
|
||||
return dup
|
||||
|
||||
|
||||
def add(self,label,data,info=None):
|
||||
"""
|
||||
Add column data.
|
||||
|
|
|
@ -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,9 +42,17 @@ 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;
|
||||
|
|
|
@ -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)
|
||||
|
@ -126,9 +127,9 @@ subroutine DAMASK_interface_init
|
|||
if (err /= 0) call quit(1)
|
||||
select case(trim(arg)) ! extract key
|
||||
case ('-h','--help')
|
||||
print'(a)', ' #######################################################################'
|
||||
print'(/,a)',' #######################################################################'
|
||||
print'(a)', ' DAMASK Command Line Interface:'
|
||||
print'(a)', ' For PETSc-based solvers for the Düsseldorf Advanced Material Simulation Kit'
|
||||
print'(a)', ' Düsseldorf Advanced Material Simulation Kit with PETSc-based solvers'
|
||||
print'(a,/)',' #######################################################################'
|
||||
print'(a,/)',' Valid command line switches:'
|
||||
print'(a)', ' --geom (-g, --geometry)'
|
||||
|
@ -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)', ' Loadcase argument: '//trim(loadcaseArg)
|
||||
print'(a)', ' Working directory: '//getCWD()
|
||||
print'(/,a)', ' Working directory: '//getCWD()
|
||||
print'(a)', ' Geometry file: '//interface_geomFile
|
||||
print'(a)', ' Loadcase file: '//interface_loadFile
|
||||
print'(a)', ' Solver job name: '//getSolverJobName()
|
||||
|
@ -223,7 +222,7 @@ end subroutine DAMASK_interface_init
|
|||
subroutine setWorkingDirectory(workingDirectoryArg)
|
||||
|
||||
character(len=*), intent(in) :: workingDirectoryArg !< working directory argument
|
||||
character(len=pPathLen) :: workingDirectory
|
||||
character(len=:), allocatable :: workingDirectory
|
||||
logical :: error
|
||||
external :: quit
|
||||
|
||||
|
@ -359,7 +358,7 @@ 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)
|
||||
|
||||
|
|
|
@ -993,12 +993,11 @@ subroutine utilities_updateCoords(F)
|
|||
real(pReal), dimension(3, grid(1)+1,grid(2)+1,grid3+1) :: nodeCoords
|
||||
integer :: &
|
||||
i,j,k,n, &
|
||||
rank_t, &
|
||||
rank_b, &
|
||||
c, r, &
|
||||
rank_t, rank_b, &
|
||||
c, &
|
||||
ierr
|
||||
integer, dimension(MPI_STATUS_SIZE) :: &
|
||||
s
|
||||
integer, dimension(4) :: request
|
||||
integer, dimension(MPI_STATUS_SIZE,4) :: status
|
||||
real(pReal), dimension(3) :: step
|
||||
real(pReal), dimension(3,3) :: Favg
|
||||
integer, dimension(3) :: me
|
||||
|
@ -1044,20 +1043,20 @@ subroutine utilities_updateCoords(F)
|
|||
rank_b = modulo(worldrank-1,worldsize)
|
||||
|
||||
! send bottom layer to process below
|
||||
call MPI_Isend(IPfluct_padded(:,:,:,2), c,MPI_DOUBLE,rank_b,0,PETSC_COMM_WORLD,r,ierr)
|
||||
call MPI_Isend(IPfluct_padded(:,:,:,2), c,MPI_DOUBLE,rank_b,0,PETSC_COMM_WORLD,request(1),ierr)
|
||||
if(ierr /=0) error stop 'MPI error'
|
||||
call MPI_Irecv(IPfluct_padded(:,:,:,grid3+2),c,MPI_DOUBLE,rank_t,0,PETSC_COMM_WORLD,r,ierr)
|
||||
if(ierr /=0) error stop 'MPI error'
|
||||
call MPI_Wait(r,s,ierr)
|
||||
call MPI_Irecv(IPfluct_padded(:,:,:,grid3+2),c,MPI_DOUBLE,rank_t,0,PETSC_COMM_WORLD,request(2),ierr)
|
||||
if(ierr /=0) error stop 'MPI error'
|
||||
|
||||
! send top layer to process above
|
||||
call MPI_Isend(IPfluct_padded(:,:,:,grid3+1),c,MPI_DOUBLE,rank_t,0,PETSC_COMM_WORLD,r,ierr)
|
||||
call MPI_Isend(IPfluct_padded(:,:,:,grid3+1),c,MPI_DOUBLE,rank_t,1,PETSC_COMM_WORLD,request(3),ierr)
|
||||
if(ierr /=0) error stop 'MPI error'
|
||||
call MPI_Irecv(IPfluct_padded(:,:,:,1), c,MPI_DOUBLE,rank_b,0,PETSC_COMM_WORLD,r,ierr)
|
||||
call MPI_Irecv(IPfluct_padded(:,:,:,1), c,MPI_DOUBLE,rank_b,1,PETSC_COMM_WORLD,request(4),ierr)
|
||||
if(ierr /=0) error stop 'MPI error'
|
||||
call MPI_Wait(r,s,ierr)
|
||||
|
||||
call MPI_Waitall(4,request,status,ierr)
|
||||
if(ierr /=0) error stop 'MPI error'
|
||||
if(any(status(MPI_ERROR,:) /= 0)) error stop 'MPI error'
|
||||
|
||||
!--------------------------------------------------------------------------------------------------
|
||||
! calculate nodal displacements
|
||||
|
|
|
@ -110,6 +110,7 @@ program DAMASK_mesh
|
|||
enddo ! count all identifiers to allocate memory and do sanity check
|
||||
enddo
|
||||
|
||||
if(N_def < 1) call IO_error(error_ID = 837)
|
||||
allocate(loadCases(N_def))
|
||||
|
||||
do i = 1, size(loadCases)
|
||||
|
@ -161,7 +162,7 @@ program DAMASK_mesh
|
|||
do faceSet = 1, mesh_Nboundaries
|
||||
if (mesh_boundaries(faceSet) == currentFace) currentFaceSet = faceSet
|
||||
enddo
|
||||
if (currentFaceSet < 0) call IO_error(error_ID = errorID, ext_msg = 'invalid BC')
|
||||
if (currentFaceSet < 0) call IO_error(error_ID = 837, ext_msg = 'invalid BC')
|
||||
case('t','time','delta') ! increment time
|
||||
loadCases(currentLoadCase)%time = IO_floatValue(line,chunkPos,i+1)
|
||||
case('n','incs','increments','steps') ! number of increments
|
||||
|
|
|
@ -17,6 +17,7 @@ module discretization_mesh
|
|||
use IO
|
||||
use config
|
||||
use discretization
|
||||
use results
|
||||
use FEsolving
|
||||
use FEM_quadrature
|
||||
use YAML_types
|
||||
|
@ -182,6 +183,10 @@ subroutine discretization_mesh_init(restart)
|
|||
reshape(mesh_ipCoordinates,[3,mesh_maxNips*mesh_NcpElems]), &
|
||||
mesh_node0)
|
||||
|
||||
call results_openJobFile
|
||||
call results_closeGroup(results_addGroup('geometry'))
|
||||
call results_closeJobFile
|
||||
|
||||
end subroutine discretization_mesh_init
|
||||
|
||||
|
||||
|
|
|
@ -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
|
||||
character(kind=C_CHAR), dimension(pPathLen+1), intent(out) :: cwd ! NULL-terminated 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
|
||||
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), intent(out) :: str ! C string is an array
|
||||
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)
|
||||
setCWD=merge(.True.,.False.,setCWD_C(f_c_string(path)) /= 0_C_INT)
|
||||
|
||||
end function isDirectory
|
||||
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(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(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
|
||||
|
||||
|
||||
!--------------------------------------------------------------------------------------------------
|
||||
|
@ -183,13 +181,13 @@ 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(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
|
||||
|
||||
|
|
Loading…
Reference in New Issue