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

Merge branch 'development' into empty-table-init

This commit is contained in:
Philip Eisenlohr 2022-08-12 16:15:33 -04:00
parent 7082eab366 f7350005db
commit ef8891797a
88 changed files with 1606 additions and 1925 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CMakeLists.txt
View File

@ -108,7 +108,7 @@ file(STRINGS "$ENV{PETSC_DIR}/$ENV{PETSC_ARCH}/lib/petsc/conf/petscvariables" PE
string(REPLACE "PETSC_FC_INCLUDES = " "" PETSC_INCLUDES "${PETSC_INCLUDES}")
message("PETSC_INCLUDES:\n${PETSC_INCLUDES}\n")
set(CMAKE_Fortran_FLAGS_${CMAKE_BUILD_TYPE} "${BUILDCMD_PRE} ${OPENMP_FLAGS} ${STANDARD_CHECK} ${OPTIMIZATION_FLAGS} ${COMPILE_FLAGS} ${PRECISION_FLAGS}")
set(CMAKE_Fortran_FLAGS_${CMAKE_BUILD_TYPE} "${BUILDCMD_PRE} ${OPENMP_FLAGS} ${STANDARD_CHECK} ${OPTIMIZATION_FLAGS} ${COMPILE_FLAGS}")
set(CMAKE_Fortran_LINK_EXECUTABLE "${BUILDCMD_PRE} ${CMAKE_Fortran_COMPILER} ${OPENMP_FLAGS} ${OPTIMIZATION_FLAGS} ${LINKER_FLAGS}")
if(CMAKE_BUILD_TYPE STREQUAL "DEBUG")

6
LICENSE
View File

@ -1,9 +1,9 @@
Copyright 2011-2022 Max-Planck-Institut für Eisenforschung GmbH
DAMASK is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of

2
PRIVATE

@ -1 +1 @@
Subproject commit 0e82975b23a1bd4310c523388f1cadf1b8e03dd0
Subproject commit cdca8ab0c14b637c18279e0ea236caa148d15e5e

2
VERSION
View File

@ -1 +1 @@
3.0.0-alpha6-395-g9696c1967
3.0.0-alpha6-523-g66f129273

7
cmake/Compiler-GNU.cmake
View File

@ -135,10 +135,3 @@ set (DEBUG_FLAGS "${DEBUG_FLAGS} -fsanitize=undefined")
# detect undefined behavior
# Additional options
# -fsanitize=address,leak,thread
#------------------------------------------------------------------------------------------------
# precision settings
set (PRECISION_FLAGS "${PRECISION_FLAGS} -fdefault-real-8")
# set precision to 8 bytes for standard real (=8 for pReal). Will set size of double to 16 bytes as long as -fdefault-double-8 is not set
set (PRECISION_FLAGS "${PRECISION_FLAGS} -fdefault-double-8")
# set precision to 8 bytes for double real, would be 16 bytes if -fdefault-real-8 is used

5
cmake/Compiler-Intel.cmake
View File

@ -118,8 +118,3 @@ set (DEBUG_FLAGS "${DEBUG_FLAGS} -debug all")
# -check: Checks at runtime, where
# arg_temp_created: will cause a lot of warnings because we create a bunch of temporary arrays (performance?)
# stack:
#------------------------------------------------------------------------------------------------
# precision settings
set (PRECISION_FLAGS "${PRECISION_FLAGS} -real-size 64")
# set precision for standard real to 32 | 64 | 128 (= 4 | 8 | 16 bytes, type pReal is always 8 bytes)

5
cmake/Compiler-IntelLLVM.cmake
View File

@ -117,8 +117,3 @@ set (DEBUG_FLAGS "${DEBUG_FLAGS} -debug all")
# -check: Checks at runtime, where
# arg_temp_created: will cause a lot of warnings because we create a bunch of temporary arrays (performance?)
# stack:
#------------------------------------------------------------------------------------------------
# precision settings
set (PRECISION_FLAGS "${PRECISION_FLAGS} -real-size 64")
# set precision for standard real to 32 | 64 | 128 (= 4 | 8 | 16 bytes, type pReal is always 8 bytes)

2
examples/config/phase/damage/anisobrittle_cubic.yaml
View File

@ -9,5 +9,5 @@ s_crit: [0.006666]
dot_o: 1.e-3
q: 20
D_11: 1.0
l_c: 1.0
mu: 0.001

4
examples/config/phase/damage/isobrittle_generic.yaml
View File

@ -2,6 +2,6 @@ type: isobrittle
output: [f_phi]
W_crit: 1400000.0
D_11: 1.0
G_crit: 1400000.0
l_c: 1.0
mu: 0.001

15
examples/config/phase/mechanical/plastic/dislotwin_alpha-Brass-shearbanding.yaml Normal file
View File

@ -0,0 +1,15 @@
type: dislotwin
references:
- N. Jia et al.,
Acta Materialia 60(3):1099-1115, 2012,
https://doi.org/10.1016/j.actamat.2011.10.047
- N. Jia et al.,
Acta Materialia 60:3415-3434, 2012,
https://doi.org/10.1016/j.actamat.2012.03.005
gamma_0_sb: 0.0001
tau_sb: 180.0e6 # tau_hat_sb
Q_sb: 4.0e-19 # Q_0
p_sb: 1.15
q_sb: 1.0

44
install/MarcMentat/2021.3.1/Marc_tools/include_linux64.patch vendored
View File

@ -1,18 +1,22 @@
---
+++
@@ -119,6 +119,11 @@ if test "$MSCCOSIM_VERSION" = ""; then
@@ -119,6 +119,15 @@ if test "$MSCCOSIM_VERSION" = ""; then
MSCCOSIM_VERSION="2020"
fi
+# DAMASK uses the HDF5 compiler wrapper around the Intel compiler
+H5FC="$(h5fc -shlib -show)"
+HDF5_LIB=${H5FC//ifort/}
+H5FC=$(h5fc -shlib -show)
+if [[ "$H5FC" == *"$dir is"* ]]; then
+ H5FC=$(echo $(echo "$H5FC" | tail -n1) | sed -e "s/\-shlib/-fPIC -integer-size 64 -real-size 64 -qopenmp/g")
+ H5FC=${H5FC%-lmpifort*}
+fi
+HDF5_LIB=${H5FC//*"ifort"/}
+FCOMP="$H5FC"
+
# AEM
if test "$MARCDLLOUTDIR" = ""; then
DLLOUTDIR="$MARC_LIB"
@@ -439,7 +444,7 @@ if test "$MARC_INTEGER_SIZE" = "i4" ; then
@@ -439,7 +448,7 @@ if test "$MARC_INTEGER_SIZE" = "i4" ; then
I8DEFINES=
I8CDEFINES=
else
@ -21,29 +25,29 @@
I8DEFINES="-DI64"
I8CDEFINES="-U_DOUBLE -D_SINGLE"
fi
@@ -556,7 +561,7 @@ then
@@ -556,7 +565,7 @@ then
PROFILE=" $PROFILE -pg"
fi
-FORT_OPT="-c -assume byterecl -safe_cray_ptr -mp1 -WB -fp-model source"
+FORT_OPT="-c -implicitnone -stand f18 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr -mp1 -WB -fp-model source"
if test "$MTHREAD" = "OPENMP"
then
FORT_OPT=" $FORT_OPT -qopenmp"
@@ -569,7 +574,7 @@ else
@@ -569,7 +578,7 @@ else
FORT_OPT=" $FORT_OPT -save -zero"
fi
if test "$MARCHDF_HDF" = "HDF"; then
- FORT_OPT="$FORT_OPT -DMARCHDF_HDF=$MARCHDF_HDF $HDF_INCLUDE"
+ FORT_OPT="$FORT_OPT -DMARCHDF=$MARCHDF_HDF"
fi
FORTLOW="$FCOMP $FORT_OPT $PROFILE -O0 $I8FFLAGS -I$MARC_SOURCE/common \
@@ -583,6 +588,30 @@ FORTNA="$FCOMP $FORT_OPT -fno-alias -O3 $I8FFLAGS -I$MARC_SOURCE/common \
@@ -583,6 +592,30 @@ FORTNA="$FCOMP $FORT_OPT -fno-alias -O3 $I8FFLAGS -I$MARC_SOURCE/common \
# for compiling free form f90 files. high opt, integer(4)
FORTF90="$FCOMP -c -O3"
+# determine DAMASK version
+if test -n "$DAMASK_USER"; then
+ DAMASKROOT=`dirname $DAMASK_USER`/..
@ -71,30 +75,30 @@
if test "$MARCDEBUG" = "ON"
then
FORTLOW="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \
@@ -739,7 +768,7 @@ SECLIBS="-L$MARC_LIB -llapi"
@@ -739,7 +772,7 @@ SECLIBS="-L$MARC_LIB -llapi"
SOLVERLIBS="${BCSSOLVERLIBS} ${VKISOLVERLIBS} ${CASISOLVERLIBS} ${MF2SOLVERLIBS} \
-L$MARC_MKL \
- $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/libkdtree2.a $MARC_LIB/libtetmeshinterface.a $MARC_LIB/libcaefatigueinterface.a -L$MARC_LIB -lmkl_blacs_intelmpi_ilp64 -lmkl_scalapack_ilp64 -lmkl_intel_ilp64 -lmkl_intel_thread -lmkl_core -liomp5 -ltetmesh -lmeshgems -lmg-tetra -lmeshgems_stubs $HDF_LIBS $SOLVER2LIBS"
+ $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/libkdtree2.a $MARC_LIB/libtetmeshinterface.a $MARC_LIB/libcaefatigueinterface.a -L$MARC_LIB -lmkl_blacs_intelmpi_ilp64 -lmkl_scalapack_ilp64 -lmkl_intel_ilp64 -lmkl_intel_thread -lmkl_core -liomp5 -ltetmesh -lmeshgems -lmg-tetra -lmeshgems_stubs $HDF5_LIB $SOLVER2LIBS"
SOLVERLIBS_DLL=${SOLVERLIBS}
if test "$AEM_DLL" -eq 1
@@ -762,7 +791,7 @@ then
@@ -762,7 +795,7 @@ then
OPENSSL=NONE
fi
-SYSLIBS=" $OPENMP -lpthread -shared-intel -cxxlib"
+SYSLIBS=" $OPENMP -lpthread -cxxlib"
# Uncomment the following lines to turn on the trace and comment out the next 4 lines
# if test $MPITYPE = intelmpi
@@ -772,7 +801,7 @@ SYSLIBS=" $OPENMP -lpthread -shared-intel -cxxlib"
@@ -772,7 +805,7 @@ SYSLIBS=" $OPENMP -lpthread -shared-intel -cxxlib"
# fi
if test $MPITYPE = intelmpi
then
- SYSLIBS="-L${MPI_ROOT}/lib/release -lmpi -L${MPI_ROOT}/lib -lmpifort -lrt $OPENMP -threads -lpthread -shared-intel -cxxlib"
+ SYSLIBS="-L${MPI_ROOT}/lib/release -lmpi -L${MPI_ROOT}/lib -lmpifort -lrt $OPENMP -threads -lpthread -cxxlib"
fi
if test "$ZLIB" = "ZLIB"; then

24
install/MarcMentat/2022.1/Marc_tools/include_linux64.patch vendored
View File

@ -5,14 +5,18 @@
fi
+# DAMASK uses the HDF5 compiler wrapper around the Intel compiler
+H5FC="$(h5fc -shlib -show)"
+HDF5_LIB=${H5FC//ifort/}
+H5FC=$(h5fc -shlib -show)
+if [[ "$H5FC" == *"$dir is"* ]]; then
+ H5FC=$(echo $(echo "$H5FC" | tail -n1) | sed -e "s/\-shlib/-fPIC -integer-size 64 -real-size 64 -qopenmp/g")
+ H5FC=${H5FC%-lmpifort*}
+fi
+HDF5_LIB=${H5FC//*"ifort"/}
+FCOMP="$H5FC"
+
# AEM
if test "$MARCDLLOUTDIR" = ""; then
DLLOUTDIR="$MARC_LIB"
@@ -477,8 +482,8 @@ if test "$MARC_INTEGER_SIZE" = "i4" ; then
@@ -477,8 +486,8 @@ if test "$MARC_INTEGER_SIZE" = "i4" ; then
I8DEFINES=
I8CDEFINES=
else
@ -22,7 +26,7 @@
I8CDEFINES="-U_DOUBLE -D_SINGLE"
fi
@@ -594,7 +599,7 @@ then
@@ -594,7 +605,7 @@ then
PROFILE=" $PROFILE -pg"
fi
@ -31,7 +35,7 @@
if test "$MTHREAD" = "OPENMP"
then
FORT_OPT=" $FORT_OPT -qopenmp"
@@ -607,7 +612,7 @@ else
@@ -607,7 +616,7 @@ else
FORT_OPT=" $FORT_OPT -save -zero"
fi
if test "$MARCHDF_HDF" = "HDF"; then
@ -40,10 +44,10 @@
fi
FORTLOW="$FCOMP $FORT_OPT $PROFILE -O0 $I8FFLAGS -I$MARC_SOURCE/common \
@@ -621,6 +626,29 @@ FORTNA="$FCOMP $FORT_OPT -fno-alias -O3 $I8FFLAGS -I$MARC_SOURCE/common \
@@ -621,6 +630,29 @@ FORTNA="$FCOMP $FORT_OPT -fno-alias -O3 $I8FFLAGS -I$MARC_SOURCE/common \
# for compiling free form f90 files. high opt, integer(4)
FORTF90="$FCOMP -c -O3"
+# determine DAMASK version
+if test -n "$DAMASK_USER"; then
+ DAMASKROOT=`dirname $DAMASK_USER`/..
@ -71,12 +75,12 @@
then
FORTLOW="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \
@@ -778,7 +806,7 @@ SECLIBS="-L$MARC_LIB -llapi"
SOLVERLIBS="${BCSSOLVERLIBS} ${VKISOLVERLIBS} ${CASISOLVERLIBS} ${MF2SOLVERLIBS} \
-L$MARC_MKL \
- $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/libkdtree2.a $MARC_LIB/libtetmeshinterface.a $MARC_LIB/libcaefatigueinterface.a -L$MARC_LIB -lmkl_blacs_intelmpi_ilp64 -lmkl_scalapack_ilp64 -lmkl_intel_ilp64 -lmkl_intel_thread -lmkl_core -liomp5 -ltetmesh -lmeshgems -lmg-tetra -lmeshgems_stubs $HDF_LIBS $SOLVER2LIBS"
+ $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/libkdtree2.a $MARC_LIB/libtetmeshinterface.a $MARC_LIB/libcaefatigueinterface.a -L$MARC_LIB -lmkl_blacs_intelmpi_ilp64 -lmkl_scalapack_ilp64 -lmkl_intel_ilp64 -lmkl_intel_thread -lmkl_core -liomp5 -ltetmesh -lmeshgems -lmg-tetra -lmeshgems_stubs $HDF5_LIB $SOLVER2LIBS"
SOLVERLIBS_DLL=${SOLVERLIBS}
if test "$AEM_DLL" -eq 1
@@ -802,7 +830,7 @@ then
@ -85,7 +89,7 @@
-SYSLIBS=" $OPENMP -lpthread -shared-intel -cxxlib $MARC_RPC_LIB"
+SYSLIBS=" $OPENMP -lpthread -cxxlib $MARC_RPC_LIB"
# Uncomment the following lines to turn on the trace and comment out the next 4 lines
# if test $MPITYPE = intelmpi
@@ -812,7 +840,7 @@ SYSLIBS=" $OPENMP -lpthread -shared-intel -cxxlib $MARC_RPC_LIB"

18
install/MarcMentat/apply_DAMASK_modifications.py
View File

@ -6,15 +6,18 @@ import glob
import argparse
import shutil
from pathlib import Path
import subprocess
import shlex
import damask
sys.path.append(str(Path(__file__).parents[2]/'python/damask'))
import solver
def copy_and_patch(patch,orig,editor):
try:
shutil.copyfile(orig,orig.parent/patch.stem)
except shutil.SameFileError:
pass
damask.util.run(f'patch {orig.parent/patch.stem} {patch} --backup --forward')
subprocess.run(shlex.split(f'patch {orig.parent/patch.stem} {patch} --backup --forward'))
with open(orig.parent/patch.stem) as f_in:
content = f_in.read()
with open(orig.parent/patch.stem,'w') as f_out:
@ -28,15 +31,16 @@ parser = argparse.ArgumentParser(
parser.add_argument('--editor', dest='editor', metavar='string', default='vi',
help='Name of the editor (executable) used by Marc Mentat')
parser.add_argument('--marc-root', dest='marc_root', metavar='string',
default=damask.solver._marc._marc_root,
default=solver._marc._marc_root,
help='Marc root directory')
parser.add_argument('--marc-version', dest='marc_version', metavar='string',
default=damask.solver._marc._marc_version,
default=solver._marc._marc_version,
help='Marc version')
parser.add_argument('--damask-root', dest='damask_root', metavar = 'string',
default=damask.solver._marc._damask_root,
default=solver._marc._damask_root,
help='DAMASK root directory')
args = parser.parse_args()
marc_root = Path(args.marc_root).expanduser()
damask_root = Path(args.damask_root).expanduser()
@ -52,7 +56,7 @@ matches = {'Marc_tools': [['comp_user','comp_damask_*mp'],
for cmd in ['patch','xvfb-run']:
try:
damask.util.run(f'{cmd} --help')
subprocess.run(shlex.split(f'{cmd} --help'))
except FileNotFoundError:
print(f'"{cmd}" not found, please install')
sys.exit()
@ -71,7 +75,7 @@ print('compiling Mentat menu binaries...')
executable = marc_root/f'mentat{marc_version}/bin/mentat'
menu_file = marc_root/f'mentat{marc_version}/menus/linux64/main.msb'
damask.util.run(f'xvfb-run -a {executable} -compile {menu_file}')
subprocess.run(shlex.split(f'xvfb-run -a {executable} -compile {menu_file}'))
print('setting file access rights...')

51
python/damask/_colormap.py
View File

@ -48,7 +48,12 @@ class Colormap(mpl.colors.ListedColormap):
def __eq__(self,
other: object) -> bool:
"""Test equality of colormaps."""
"""
Return self==other.
Test equality of other.
"""
if not isinstance(other, Colormap):
return NotImplemented
return len(self.colors) == len(other.colors) \
@ -56,31 +61,61 @@ class Colormap(mpl.colors.ListedColormap):
def __add__(self,
other: 'Colormap') -> 'Colormap':
"""Concatenate."""
"""
Return self+other.
Concatenate.
"""
return Colormap(np.vstack((self.colors,other.colors)),
f'{self.name}+{other.name}')
def __iadd__(self,
other: 'Colormap') -> 'Colormap':
"""Concatenate (in-place)."""
"""
Return self+=other.
Concatenate (in-place).
"""
return self.__add__(other)
def __mul__(self,
factor: int) -> 'Colormap':
"""Repeat."""
"""
Return self*other.
Repeat.
"""
return Colormap(np.vstack([self.colors]*factor),f'{self.name}*{factor}')
def __imul__(self,
factor: int) -> 'Colormap':
"""Repeat (in-place)."""
"""
Return self*=other.
Repeat (in-place).
"""
return self.__mul__(factor)
def __invert__(self) -> 'Colormap':
"""Reverse."""
"""
Return ~self.
Reverse.
"""
return self.reversed()
def __repr__(self) -> str:
"""Show as matplotlib figure."""
"""
Return repr(self).
Show as matplotlib figure.
"""
fig = plt.figure(self.name,figsize=(5,.5))
ax1 = fig.add_axes([0, 0, 1, 1])
ax1.set_axis_off()
@ -385,7 +420,7 @@ class Colormap(mpl.colors.ListedColormap):
GOM_str = '1 1 {name} 9 {name} '.format(name=self.name.replace(" ","_")) \
+ '0 1 0 3 0 0 -1 9 \\ 0 0 0 255 255 255 0 0 255 ' \
+ f'30 NO_UNIT 1 1 64 64 64 255 1 0 0 0 0 0 0 3 0 {self.N}' \
+ ' '.join([f' 0 {c[0]} {c[1]} {c[2]} 255 1' for c in reversed((self.colors*255).astype(int))]) \
+ ' '.join([f' 0 {c[0]} {c[1]} {c[2]} 255 1' for c in reversed((self.colors*255).astype(np.int64))]) \
+ '\n'
self._get_file_handle(fname,'.legend').write(GOM_str)

23
python/damask/_config.py
View File

@ -64,7 +64,12 @@ class Config(dict):
super().__init__(**kwargs)
def __repr__(self) -> str:
"""Show as in file."""
"""
Return repr(self).
Show as in file.
"""
output = StringIO()
self.save(output)
output.seek(0)
@ -72,7 +77,12 @@ class Config(dict):
def __copy__(self: MyType) -> MyType:
"""Create deep copy."""
"""
Return deepcopy(self).
Create deep copy.
"""
return copy.deepcopy(self)
copy = __copy__
@ -81,6 +91,8 @@ class Config(dict):
def __or__(self: MyType,
other) -> MyType:
"""
Return self|other.
Update configuration with contents of other.
Parameters
@ -105,7 +117,12 @@ class Config(dict):
def __ior__(self: MyType,
other) -> MyType:
"""Update configuration with contents of other."""
"""
Return self|=other.
Update configuration with contents of other.
"""
return self.__or__(other)

11
python/damask/_crystal.py
View File

@ -403,7 +403,12 @@ class Crystal():
def __repr__(self):
"""Give short human-readable summary."""
"""
Return repr(self).
Give short human-readable summary.
"""
family = f'Crystal family: {self.family}'
return family if self.lattice is None else \
util.srepr([family,
@ -415,7 +420,9 @@ class Crystal():
def __eq__(self,
other: object) -> bool:
"""
Equal to other.
Return self==other.
Test equality of other.
Parameters
----------

30
python/damask/_grid.py
View File

@ -62,7 +62,12 @@ class Grid:
self.comments = [] if comments_ is None else [str(c) for c in comments_]
def __repr__(self) -> str:
"""Give short human-readable summary."""
"""
Return repr(self).
Give short human-readable summary.
"""
mat_min = np.nanmin(self.material)
mat_max = np.nanmax(self.material)
mat_N = self.N_materials
@ -76,7 +81,12 @@ class Grid:
def __copy__(self) -> 'Grid':
"""Create deep copy."""
"""
Return deepcopy(self).
Create deep copy.
"""
return copy.deepcopy(self)
copy = __copy__
@ -85,6 +95,8 @@ class Grid:
def __eq__(self,
other: object) -> bool:
"""
Return self==other.
Test equality of other.
Parameters
@ -117,8 +129,8 @@ class Grid:
self._material = np.copy(material)
if self.material.dtype in np.sctypes['float'] and \
np.all(self.material == self.material.astype(int).astype(float)):
self._material = self.material.astype(int)
np.all(self.material == self.material.astype(np.int64).astype(float)):
self._material = self.material.astype(np.int64)
@property
@ -285,7 +297,7 @@ class Grid:
raise TypeError(f'mismatch between {cells.prod()} expected entries and {i} found')
if not np.any(np.mod(material,1) != 0.0): # no float present
material = material.astype(int) - (1 if material.min() > 0 else 0)
material = material.astype(np.int64) - (1 if material.min() > 0 else 0)
return Grid(material = material.reshape(cells,order='F'),
size = size,
@ -916,7 +928,7 @@ class Grid:
cval=np.nanmax(self.material) + 1 if fill is None else fill)
# avoid scipy interpolation errors for rotations close to multiples of 90°
material = material_temp if np.prod(material_temp.shape) != np.prod(material.shape) else \
np.rot90(material,k=np.rint(angle/90.).astype(int),axes=axes)
np.rot90(material,k=np.rint(angle/90.).astype(np.int64),axes=axes)
origin = self.origin-(np.asarray(material.shape)-self.cells)*.5 * self.size/self.cells
@ -1094,7 +1106,7 @@ class Grid:
rng = np.random.default_rng(rng_seed)
d = np.floor(distance).astype(int)
d = np.floor(distance).astype(np.int64)
ext = np.linspace(-d,d,1+2*d,dtype=float),
xx,yy,zz = np.meshgrid(ext,ext,ext)
footprint = xx**2+yy**2+zz**2 <= distance**2+distance*1e-8
@ -1197,7 +1209,7 @@ class Grid:
mask = np.sum(np.power(coords_rot/r,2.0**np.array(exponent)),axis=-1) > 1.0
if periodic: # translate back to center
mask = np.roll(mask,((c/self.size-0.5)*self.cells).round().astype(int),(0,1,2))
mask = np.roll(mask,((c/self.size-0.5)*self.cells).round().astype(np.int64),(0,1,2))
return Grid(material = np.where(np.logical_not(mask) if inverse else mask,
self.material,
@ -1249,7 +1261,7 @@ class Grid:
return np.any(stencil != me if selection is None else
np.in1d(stencil,np.array(list(selection - {me}))))
d = np.floor(distance).astype(int)
d = np.floor(distance).astype(np.int64)
ext = np.linspace(-d,d,1+2*d,dtype=float),
xx,yy,zz = np.meshgrid(ext,ext,ext)
footprint = xx**2+yy**2+zz**2 <= distance**2+distance*1e-8

29
python/damask/_orientation.py
View File

@ -120,14 +120,24 @@ class Orientation(Rotation,Crystal):
def __repr__(self) -> str:
"""Give short human-readable summary."""
"""
Return repr(self).
Give short human-readable summary.
"""
return util.srepr([Crystal.__repr__(self),
Rotation.__repr__(self)])
def __copy__(self: MyType,
rotation: Union[FloatSequence, Rotation] = None) -> MyType:
"""Create deep copy."""
"""
Return deepcopy(self).
Create deep copy.
"""
dup = copy.deepcopy(self)
if rotation is not None:
dup.quaternion = Rotation(rotation).quaternion
@ -140,7 +150,9 @@ class Orientation(Rotation,Crystal):
def __eq__(self,
other: object) -> bool:
"""
Equal to other.
Return self==other.
Test equality of other.
Parameters
----------
@ -158,7 +170,9 @@ class Orientation(Rotation,Crystal):
def __ne__(self,
other: object) -> bool:
"""
Not equal to other.
Return self!=other.
Test inequality of other.
Parameters
----------
@ -448,9 +462,12 @@ class Orientation(Rotation,Crystal):
elif self.family == 'orthorhombic':
return (np.prod(1. >= rho_abs,axis=-1)).astype(bool)
elif self.family == 'monoclinic':
return (1. >= rho_abs[...,1]).astype(bool)
return np.logical_or( 1. >= rho_abs[...,1],
np.isnan(rho_abs[...,1]))
elif self.family == 'triclinic':
return np.ones(rho_abs.shape[:-1]).astype(bool)
else:
return np.all(np.isfinite(rho_abs),axis=-1)
raise TypeError(f'unknown symmetry "{self.family}"')
@property

18
python/damask/_result.py
View File

@ -83,7 +83,7 @@ class Result:
>>> import damask
>>> r = damask.Result('my_file.hdf5')
>>> r.add_Cauchy()
>>> r.add_stress_Cauchy()
>>> r.add_equivalent_Mises('sigma')
>>> r.export_VTK()
>>> r_last = r.view(increments=-1)
@ -152,14 +152,24 @@ class Result:
def __copy__(self) -> "Result":
"""Create deep copy."""
"""
Return deepcopy(self).
Create deep copy.
"""
return copy.deepcopy(self)
copy = __copy__
def __repr__(self) -> str:
"""Give short human-readable summary."""
"""
Return repr(self).
Give short human-readable summary.
"""
with h5py.File(self.fname,'r') as f:
header = [f'Created by {f.attrs["creator"]}',
f' on {f.attrs["created"]}',
@ -334,7 +344,7 @@ class Result:
>>> import damask
>>> r = damask.Result('my_file.hdf5')
>>> r_first = r.view(increment=0)
>>> r_first = r.view(increments=0)
Get a view that shows all results between simulation times of 10 to 40:

80
python/damask/_rotation.py
View File

@ -88,14 +88,24 @@ class Rotation:
def __repr__(self) -> str:
"""Give short human-readable summary."""
"""
Return repr(self).
Give short human-readable summary.
"""
return f'Quaternion{" " if self.quaternion.shape == (4,) else "s of shape "+str(self.quaternion.shape[:-1])+chr(10)}'\
+ str(self.quaternion)
def __copy__(self: MyType,
rotation: Union[FloatSequence, 'Rotation'] = None) -> MyType:
"""Create deep copy."""
"""
Return deepcopy(self).
Create deep copy.
"""
dup = copy.deepcopy(self)
if rotation is not None:
dup.quaternion = Rotation(rotation).quaternion
@ -106,7 +116,12 @@ class Rotation:
def __getitem__(self,
item: Union[Tuple[int], int, bool, np.bool_, np.ndarray]):
"""Return slice according to item."""
"""
Return self[item].
Return slice according to item.
"""
return self.copy() if self.shape == () else \
self.copy(self.quaternion[item+(slice(None),)] if isinstance(item,tuple) else self.quaternion[item])
@ -114,7 +129,9 @@ class Rotation:
def __eq__(self,
other: object) -> bool:
"""
Equal to other.
Return self==other.
Test equality of other.
Parameters
----------
@ -130,7 +147,9 @@ class Rotation:
def __ne__(self,
other: object) -> bool:
"""
Not equal to other.
Return self!=other.
Test inequality of other.
Parameters
----------
@ -214,12 +233,22 @@ class Rotation:
def __len__(self) -> int:
"""Length of leading/leftmost dimension of array."""
"""
Return len(self).
Length of leading/leftmost dimension of array.
"""
return 0 if self.shape == () else self.shape[0]
def __invert__(self: MyType) -> MyType:
"""Inverse rotation (backward rotation)."""
"""
Return ~self.
Inverse rotation (backward rotation).
"""
dup = self.copy()
dup.quaternion[...,1:] *= -1
return dup
@ -228,6 +257,8 @@ class Rotation:
def __pow__(self: MyType,
exp: Union[float, int]) -> MyType:
"""
Return self**exp.
Perform the rotation 'exp' times.
Parameters
@ -243,6 +274,8 @@ class Rotation:
def __ipow__(self: MyType,
exp: Union[float, int]) -> MyType:
"""
Return self**=exp.
Perform the rotation 'exp' times (in-place).
Parameters
@ -257,6 +290,8 @@ class Rotation:
def __mul__(self: MyType,
other: MyType) -> MyType:
"""
Return self*other.
Compose with other.
Parameters
@ -284,6 +319,8 @@ class Rotation:
def __imul__(self: MyType,
other: MyType) -> MyType:
"""
Return self*=other.
Compose with other (in-place).
Parameters
@ -298,6 +335,8 @@ class Rotation:
def __truediv__(self: MyType,
other: MyType) -> MyType:
"""
Return self/other.
Compose with inverse of other.
Parameters
@ -319,6 +358,8 @@ class Rotation:
def __itruediv__(self: MyType,
other: MyType) -> MyType:
"""
Return self/=other.
Compose with inverse of other (in-place).
Parameters
@ -333,7 +374,9 @@ class Rotation:
def __matmul__(self,
other: np.ndarray) -> np.ndarray:
"""
Rotate vector, second order tensor, or fourth order tensor.
Return self@other.
Rotate vector, second-order tensor, or fourth-order tensor.
Parameters
----------
@ -365,7 +408,7 @@ class Rotation:
R = self.as_matrix()
return np.einsum('...im,...jn,...ko,...lp,...mnop',R,R,R,R,other)
else:
raise ValueError('can only rotate vectors, 2nd order tensors, and 4th order tensors')
raise ValueError('can only rotate vectors, second-order tensors, and fourth-order tensors')
elif isinstance(other, Rotation):
raise TypeError('use "R1*R2", i.e. multiplication, to compose rotations "R1" and "R2"')
else:
@ -1372,7 +1415,7 @@ class Rotation:
w[np.isclose(w[...,0],1.0+0.0j),1:] = 0.
w[np.isclose(w[...,1],1.0+0.0j),2:] = 0.
vr = np.swapaxes(vr,-1,-2)
ax = np.where(np.abs(diag_delta)<1e-12,
ax = np.where(np.abs(diag_delta)<1e-13,
np.real(vr[np.isclose(w,1.0+0.0j)]).reshape(om.shape[:-2]+(3,)),
np.abs(np.real(vr[np.isclose(w,1.0+0.0j)]).reshape(om.shape[:-2]+(3,))) \
*np.sign(diag_delta))
@ -1581,14 +1624,13 @@ class Rotation:
@staticmethod
def _ho2ax(ho: np.ndarray) -> np.ndarray:
"""Homochoric vector to axis–angle pair."""
tfit = np.array([+1.0000000000018852, -0.5000000002194847,
-0.024999992127593126, -0.003928701544781374,
-0.0008152701535450438, -0.0002009500426119712,
-0.00002397986776071756, -0.00008202868926605841,
+0.00012448715042090092, -0.0001749114214822577,
+0.0001703481934140054, -0.00012062065004116828,
+0.000059719705868660826, -0.00001980756723965647,
+0.000003953714684212874, -0.00000036555001439719544])
tfit = np.array([+0.9999999999999968, -0.49999999999986866, -0.025000000000632055,
-0.003928571496460683, -0.0008164666077062752, -0.00019411896443261646,
-0.00004985822229871769, -0.000014164962366386031, -1.9000248160936107e-6,
-5.72184549898506e-6, +7.772149920658778e-6, -0.00001053483452909705,
+9.528014229335313e-6, -5.660288876265125e-6, +1.2844901692764126e-6,
+1.1255185726258763e-6, -1.3834391419956455e-6, +7.513691751164847e-7,
-2.401996891720091e-7, +4.386887017466388e-8, -3.5917775353564864e-9])
hmag_squared = np.sum(ho**2.,axis=-1,keepdims=True)
s = np.sum(tfit*hmag_squared**np.arange(len(tfit)),axis=-1,keepdims=True)
with np.errstate(invalid='ignore'):
@ -1679,7 +1721,7 @@ class Rotation:
"""
with np.errstate(invalid='ignore',divide='ignore'):
# get pyramide and scale by grid parameter ratio
# get pyramid and scale by grid parameter ratio
XYZ = np.take_along_axis(cu,Rotation._get_pyramid_order(cu,'forward'),-1) * _sc
order = np.abs(XYZ[...,1:2]) <= np.abs(XYZ[...,0:1])
q = np.pi/12.0 * np.where(order,XYZ[...,1:2],XYZ[...,0:1]) \

38
python/damask/_table.py
View File

@ -37,7 +37,12 @@ class Table:
def __repr__(self) -> str:
"""Give short human-readable summary."""
"""
Return repr(self).
Give short human-readable summary.
"""
self._relabel('shapes')
data_repr = self.data.__repr__()
self._relabel('uniform')
@ -46,7 +51,12 @@ class Table:
def __eq__(self,
other: object) -> bool:
"""Compare to other Table."""
"""
Return self==other.
Test equality of other.
"""
return NotImplemented if not isinstance(other,Table) else \
self.shapes == other.shapes and self.data.equals(other.data)
@ -54,7 +64,9 @@ class Table:
def __getitem__(self,
item: Union[slice, Tuple[slice, ...]]) -> 'Table':
"""
Slice the Table according to item.
Return self[item].
Return slice according to item.
Parameters
----------
@ -102,12 +114,22 @@ class Table:
def __len__(self) -> int:
"""Number of rows."""
"""
Return len(self).
Number of rows.
"""
return len(self.data)
def __copy__(self) -> 'Table':
"""Create deep copy."""
"""
Return deepcopy(self).
Create deep copy.
"""
return copy.deepcopy(self)
copy = __copy__
@ -134,7 +156,7 @@ class Table:
labels = []
for label in what:
shape = self.shapes[label]
size = np.prod(shape,dtype=int)
size = np.prod(shape,dtype=np.int64)
if how == 'uniform':
labels += [label] * size
elif how == 'shapes':
@ -168,7 +190,7 @@ class Table:
shape: Tuple[int, ...],
info: str = None):
if info is not None:
specific = f'{label}{" "+str(shape) if np.prod(shape,dtype=int) > 1 else ""}: {info}'
specific = f'{label}{" "+str(shape) if np.prod(shape,dtype=np.int64) > 1 else ""}: {info}'
general = util.execution_stamp('Table')
self.comments.append(f'{specific} / {general}')
@ -401,7 +423,7 @@ class Table:
else:
dup.shapes[label] = data.shape[1:] if len(data.shape) > 1 else (1,)
size = np.prod(data.shape[1:],dtype=int)
size = np.prod(data.shape[1:],dtype=np.int64)
new = pd.DataFrame(data=data.reshape(-1,size),
columns=[label]*size,
)

13
python/damask/_vtk.py
View File

@ -39,7 +39,12 @@ class VTK:
def __repr__(self) -> str:
"""Give short human-readable summary."""
"""
Return repr(self).
Give short human-readable summary.
"""
info = [self.vtk_data.__vtkname__]
for data in ['Cell Data', 'Point Data']:
@ -54,7 +59,9 @@ class VTK:
def __eq__(self,
other: object) -> bool:
"""
Equal to other.
Return self==other.
Test equality of other.
Parameters
----------
@ -187,7 +194,7 @@ class VTK:
----------
nodes : numpy.ndarray, shape (:,3)
Spatial position of the nodes.
connectivity : numpy.ndarray of np.dtype = int
connectivity : numpy.ndarray of np.dtype = np.int64
Cell connectivity (0-based), first dimension determines #Cells,
second dimension determines #Nodes/Cell.
cell_type : str

2
python/damask/seeds.py
View File

@ -45,7 +45,7 @@ def from_random(size: _FloatSequence,
else:
grid_coords = _grid_filters.coordinates0_point(cells,size).reshape(-1,3,order='F')
coords = grid_coords[rng.choice(_np.prod(cells),N_seeds, replace=False)] \
+ _np.broadcast_to(size_/_np.array(cells,int),(N_seeds,3))*(rng.random((N_seeds,3))*.5-.25) # wobble w/o leaving grid
+ _np.broadcast_to(size_/_np.array(cells,_np.int64),(N_seeds,3))*(rng.random((N_seeds,3))*.5-.25) # wobble w/o leaving grid
return coords

37
python/damask/solver/_marc.py
View File

@ -10,18 +10,26 @@ _damask_root = str(Path(__file__).parents[3])
class Marc:
"""Wrapper to run DAMASK with MSC Marc."""
def __init__(self,marc_version=_marc_version,marc_root=_marc_root,damask_root=_damask_root):
def __init__(self,
version: str = _marc_version,
marc_root: str = _marc_root,
damask_root: str = _damask_root):
"""
Create a Marc solver object.
Parameters
----------
version : string
Marc version
version : str, optional
Marc version. Defaults to latest supported Marc version.
marc_root : str, optional
Marc root location. Defaults to /opt/msc.
damask_root : str, optional
DAMASK root location.
Default is autodected based on location of the Python library.
"""
self.marc_version = marc_version
self.marc_root = Path(marc_root)
self.marc_version = version
self.marc_root = Path(marc_root)
self.damask_root = Path(damask_root)
@property
@ -44,9 +52,10 @@ class Marc:
return path_tools
def submit_job(self, model, job,
compile = False,
optimization = ''):
def submit_job(self, model: str, job: str,
compile: bool = False,
optimization: str = '',
env = None):
"""
Assemble command line arguments and call Marc executable.
@ -62,6 +71,8 @@ class Marc:
optimization : str, optional
Optimization level '' (-O0), 'l' (-O1), or 'h' (-O3).
Defaults to ''.
env : dict, optional
Environment for execution.
"""
usersub = (self.damask_root/'src/Marc/DAMASK_Marc').with_suffix('.f90' if compile else '.marc')
@ -73,18 +84,16 @@ class Marc:
cmd = f'{self.tools_path/script} -jid {model}_{job} -nprocd 1 -autorst 0 -ci n -cr n -dcoup 0 -b no -v no ' \
+ (f'-u {usersub} -save y' if compile else f'-prog {usersub.with_suffix("")}')
print(cmd)
ret = subprocess.run(shlex.split(cmd),capture_output=True)
ret = subprocess.run(shlex.split(cmd),capture_output=True,env=env)
try:
v = int(re.search('Exit number ([0-9]+)',ret.stderr.decode()).group(1))
if 3004 != v:
if (m := re.search('Exit number ([0-9]+)',ret.stderr.decode())) is not None:
if 3004 != (v := int(m.group(1))):
print(ret.stderr.decode())
print(ret.stdout.decode())
raise RuntimeError(f'Marc simulation failed ({v})')
except (AttributeError,ValueError):
else:
print(ret.stderr.decode())
print(ret.stdout.decode())
raise RuntimeError('Marc simulation failed (unknown return value)')

313
python/damask/util.py
View File

@ -1,43 +1,25 @@
"""Miscellaneous helper functionality."""
import sys
import datetime
import os
import subprocess
import shlex
import re
import signal
import fractions
from collections import abc
from functools import reduce, partial
from typing import Callable, Union, Iterable, Sequence, Dict, List, Tuple, Literal, Any, Collection, TextIO
from pathlib import Path
import sys as _sys
import datetime as _datetime
import os as _os
import subprocess as _subprocess
import shlex as _shlex
import re as _re
import signal as _signal
import fractions as _fractions
from collections import abc as _abc
from functools import reduce as _reduce, partial as _partial
from typing import Callable as _Callable, Union as _Union, Iterable as _Iterable, Sequence as _Sequence, Dict as _Dict, \
List as _List, Tuple as _Tuple, Literal as _Literal, Any as _Any, Collection as _Collection, TextIO as _TextIO
from pathlib import Path as _Path
import numpy as np
import h5py
import numpy as _np
import h5py as _h5py
from . import version
from ._typehints import FloatSequence, NumpyRngSeed, IntCollection, FileHandle
# limit visibility
__all__=[
'srepr',
'emph', 'deemph', 'warn', 'strikeout',
'run',
'open_text',
'natural_sort',
'show_progress',
'scale_to_coprime',
'project_equal_angle', 'project_equal_area',
'hybrid_IA',
'execution_stamp',
'shapeshifter', 'shapeblender',
'extend_docstring', 'extended_docstring',
'Bravais_to_Miller', 'Miller_to_Bravais',
'DREAM3D_base_group', 'DREAM3D_cell_data_group',
'dict_prune', 'dict_flatten',
'tail_repack',
]
from . import version as _version
from ._typehints import FloatSequence as _FloatSequence, NumpyRngSeed as _NumpyRngSeed, IntCollection as _IntCollection, \
FileHandle as _FileHandle
# https://svn.blender.org/svnroot/bf-blender/trunk/blender/build_files/scons/tools/bcolors.py
# https://stackoverflow.com/questions/287871
@ -154,8 +136,8 @@ def strikeout(msg) -> str:
def run(cmd: str,
wd: str = './',
env: Dict[str, str] = None,
timeout: int = None) -> Tuple[str, str]:
env: _Dict[str, str] = None,
timeout: int = None) -> _Tuple[str, str]:
"""
Run a command.
@ -178,26 +160,26 @@ def run(cmd: str,
"""
def pass_signal(sig,_,proc,default):
proc.send_signal(sig)
signal.signal(sig,default)
signal.raise_signal(sig)
_signal.signal(sig,default)
_signal.raise_signal(sig)
signals = [signal.SIGINT,signal.SIGTERM]
signals = [_signal.SIGINT,_signal.SIGTERM]
print(f"running '{cmd}' in '{wd}'")
process = subprocess.Popen(shlex.split(cmd),
stdout = subprocess.PIPE,
stderr = subprocess.PIPE,
env = os.environ if env is None else env,
cwd = wd,
encoding = 'utf-8')
process = _subprocess.Popen(_shlex.split(cmd),
stdout = _subprocess.PIPE,
stderr = _subprocess.PIPE,
env = _os.environ if env is None else env,
cwd = wd,
encoding = 'utf-8')
# ensure that process is terminated (https://stackoverflow.com/questions/22916783)
sig_states = [signal.signal(sig,partial(pass_signal,proc=process,default=signal.getsignal(sig))) for sig in signals]
sig_states = [_signal.signal(sig,_partial(pass_signal,proc=process,default=_signal.getsignal(sig))) for sig in signals]
try:
stdout,stderr = process.communicate(timeout=timeout)
finally:
for sig,state in zip(signals,sig_states):
signal.signal(sig,state)
_signal.signal(sig,state)
if process.returncode != 0:
print(stdout)
@ -207,8 +189,8 @@ def run(cmd: str,
return stdout, stderr
def open_text(fname: FileHandle,
mode: Literal['r','w'] = 'r') -> TextIO:
def open_text(fname: _FileHandle,
mode: _Literal['r','w'] = 'r') -> _TextIO: # noqa
"""
Open a text file.
@ -224,11 +206,11 @@ def open_text(fname: FileHandle,
f : file handle
"""
return fname if not isinstance(fname, (str,Path)) else \
open(Path(fname).expanduser(),mode,newline=('\n' if mode == 'w' else None))
return fname if not isinstance(fname, (str,_Path)) else \
open(_Path(fname).expanduser(),mode,newline=('\n' if mode == 'w' else None))
def natural_sort(key: str) -> List[Union[int, str]]:
def natural_sort(key: str) -> _List[_Union[int, str]]:
"""
Natural sort.
@ -240,13 +222,13 @@ def natural_sort(key: str) -> List[Union[int, str]]:
"""
convert = lambda text: int(text) if text.isdigit() else text
return [ convert(c) for c in re.split('([0-9]+)', key) ]
return [ convert(c) for c in _re.split('([0-9]+)', key) ]
def show_progress(iterable: Iterable,
def show_progress(iterable: _Iterable,
N_iter: int = None,
prefix: str = '',
bar_length: int = 50) -> Any:
bar_length: int = 50) -> _Any:
"""
Decorate a loop with a progress bar.
@ -264,7 +246,7 @@ def show_progress(iterable: Iterable,
Length of progress bar in characters. Defaults to 50.
"""
if isinstance(iterable,abc.Sequence):
if isinstance(iterable,_abc.Sequence):
if N_iter is None:
N = len(iterable)
else:
@ -285,7 +267,7 @@ def show_progress(iterable: Iterable,
status.update(i)
def scale_to_coprime(v: FloatSequence) -> np.ndarray:
def scale_to_coprime(v: _FloatSequence) -> _np.ndarray:
"""
Scale vector to co-prime (relatively prime) integers.
@ -304,30 +286,30 @@ def scale_to_coprime(v: FloatSequence) -> np.ndarray:
def get_square_denominator(x):
"""Denominator of the square of a number."""
return fractions.Fraction(x ** 2).limit_denominator(MAX_DENOMINATOR).denominator
return _fractions.Fraction(x ** 2).limit_denominator(MAX_DENOMINATOR).denominator
def lcm(a,b):
"""Least common multiple."""
try:
return np.lcm(a,b) # numpy > 1.18
return _np.lcm(a,b) # numpy > 1.18
except AttributeError:
return a * b // np.gcd(a, b)
return a * b // _np.gcd(a, b)
v_ = np.array(v)
m = (v_ * reduce(lcm, map(lambda x: int(get_square_denominator(x)),v_))**0.5).astype(int)
m = m//reduce(np.gcd,m)
v_ = _np.array(v)
m = (v_ * _reduce(lcm, map(lambda x: int(get_square_denominator(x)),v_))**0.5).astype(_np.int64)
m = m//_reduce(_np.gcd,m)
with np.errstate(invalid='ignore'):
if not np.allclose(np.ma.masked_invalid(v_/m),v_[np.argmax(abs(v_))]/m[np.argmax(abs(v_))]):
with _np.errstate(invalid='ignore'):
if not _np.allclose(_np.ma.masked_invalid(v_/m),v_[_np.argmax(abs(v_))]/m[_np.argmax(abs(v_))]):
raise ValueError(f'invalid result "{m}" for input "{v_}"')
return m
def project_equal_angle(vector: np.ndarray,
direction: Literal['x', 'y', 'z'] = 'z',
def project_equal_angle(vector: _np.ndarray,
direction: _Literal['x', 'y', 'z'] = 'z', # noqa
normalize: bool = True,
keepdims: bool = False) -> np.ndarray:
keepdims: bool = False) -> _np.ndarray:
"""
Apply equal-angle projection to vector.
@ -367,15 +349,15 @@ def project_equal_angle(vector: np.ndarray,
"""
shift = 'zyx'.index(direction)
v = np.roll(vector/np.linalg.norm(vector,axis=-1,keepdims=True) if normalize else vector,
shift,axis=-1)
return np.roll(np.block([v[...,:2]/(1.0+np.abs(v[...,2:3])),np.zeros_like(v[...,2:3])]),
-shift if keepdims else 0,axis=-1)[...,:3 if keepdims else 2]
v = _np.roll(vector/_np.linalg.norm(vector,axis=-1,keepdims=True) if normalize else vector,
shift,axis=-1)
return _np.roll(_np.block([v[...,:2]/(1.0+_np.abs(v[...,2:3])),_np.zeros_like(v[...,2:3])]),
-shift if keepdims else 0,axis=-1)[...,:3 if keepdims else 2]
def project_equal_area(vector: np.ndarray,
direction: Literal['x', 'y', 'z'] = 'z',
def project_equal_area(vector: _np.ndarray,
direction: _Literal['x', 'y', 'z'] = 'z', # noqa
normalize: bool = True,
keepdims: bool = False) -> np.ndarray:
keepdims: bool = False) -> _np.ndarray:
"""
Apply equal-area projection to vector.
@ -416,22 +398,22 @@ def project_equal_area(vector: np.ndarray,
"""
shift = 'zyx'.index(direction)
v = np.roll(vector/np.linalg.norm(vector,axis=-1,keepdims=True) if normalize else vector,
shift,axis=-1)
return np.roll(np.block([v[...,:2]/np.sqrt(1.0+np.abs(v[...,2:3])),np.zeros_like(v[...,2:3])]),
-shift if keepdims else 0,axis=-1)[...,:3 if keepdims else 2]
v = _np.roll(vector/_np.linalg.norm(vector,axis=-1,keepdims=True) if normalize else vector,
shift,axis=-1)
return _np.roll(_np.block([v[...,:2]/_np.sqrt(1.0+_np.abs(v[...,2:3])),_np.zeros_like(v[...,2:3])]),
-shift if keepdims else 0,axis=-1)[...,:3 if keepdims else 2]
def execution_stamp(class_name: str,
function_name: str = None) -> str:
"""Timestamp the execution of a (function within a) class."""
now = datetime.datetime.now().astimezone().strftime('%Y-%m-%d %H:%M:%S%z')
now = _datetime.datetime.now().astimezone().strftime('%Y-%m-%d %H:%M:%S%z')
_function_name = '' if function_name is None else f'.{function_name}'
return f'damask.{class_name}{_function_name} v{version} ({now})'
return f'damask.{class_name}{_function_name} v{_version} ({now})'
def hybrid_IA(dist: np.ndarray,
def hybrid_IA(dist: _np.ndarray,
N: int,
rng_seed: NumpyRngSeed = None) -> np.ndarray:
rng_seed: _NumpyRngSeed = None) -> _np.ndarray:
"""
Hybrid integer approximation.
@ -446,23 +428,23 @@ def hybrid_IA(dist: np.ndarray,
If None, then fresh, unpredictable entropy will be pulled from the OS.
"""
N_opt_samples,N_inv_samples = (max(np.count_nonzero(dist),N),0) # random subsampling if too little samples requested
N_opt_samples,N_inv_samples = (max(_np.count_nonzero(dist),N),0) # random subsampling if too little samples requested
scale_,scale,inc_factor = (0.0,float(N_opt_samples),1.0)
while (not np.isclose(scale, scale_)) and (N_inv_samples != N_opt_samples):
repeats = np.rint(scale*dist).astype(np.int64)
N_inv_samples = np.sum(repeats)
while (not _np.isclose(scale, scale_)) and (N_inv_samples != N_opt_samples):
repeats = _np.rint(scale*dist).astype(_np.int64)
N_inv_samples = _np.sum(repeats)
scale_,scale,inc_factor = (scale,scale+inc_factor*0.5*(scale - scale_), inc_factor*2.0) \
if N_inv_samples < N_opt_samples else \
(scale_,0.5*(scale_ + scale), 1.0)
return np.repeat(np.arange(len(dist)),repeats)[np.random.default_rng(rng_seed).permutation(N_inv_samples)[:N]]
return _np.repeat(_np.arange(len(dist)),repeats)[_np.random.default_rng(rng_seed).permutation(N_inv_samples)[:N]]
def shapeshifter(fro: Tuple[int, ...],
to: Tuple[int, ...],
mode: Literal['left','right'] = 'left',
keep_ones: bool = False) -> Tuple[int, ...]:
def shapeshifter(fro: _Tuple[int, ...],
to: _Tuple[int, ...],
mode: _Literal['left','right'] = 'left', # noqa
keep_ones: bool = False) -> _Tuple[int, ...]:
"""
Return dimensions that reshape 'fro' to become broadcastable to 'to'.
@ -486,8 +468,8 @@ def shapeshifter(fro: Tuple[int, ...],
new_dims : tuple
Dimensions for reshape.
Example
-------
Examples
--------
>>> import numpy as np
>>> from damask import util
>>> a = np.ones((3,4,2))
@ -496,36 +478,29 @@ def shapeshifter(fro: Tuple[int, ...],
>>> (a * np.broadcast_to(b_extended,a.shape)).shape
(3,4,2)
"""
if len(fro) == 0 and len(to) == 0: return ()
if len(fro) == 0 and len(to) == 0: return tuple()
_fro = [1] if len(fro) == 0 else list(fro)[::-1 if mode=='left' else 1]
_to = [1] if len(to) == 0 else list(to) [::-1 if mode=='left' else 1]
beg = dict(left ='(^.*\\b)',
right='(^.*?\\b)')
sep = dict(left ='(.*\\b)',
right='(.*?\\b)')
end = dict(left ='(.*?$)',
right='(.*$)')
fro = (1,) if len(fro) == 0 else fro
to = (1,) if len(to) == 0 else to
try:
match = re.match(beg[mode]
+f',{sep[mode]}'.join(map(lambda x: f'{x}'
if x>1 or (keep_ones and len(fro)>1) else
'\\d+',fro))
+f',{end[mode]}',','.join(map(str,to))+',')
assert match
grp = match.groups()
except AssertionError:
raise ValueError(f'shapes cannot be shifted {fro} --> {to}')
fill: Any = ()
for g,d in zip(grp,fro+(None,)):
fill += (1,)*g.count(',')+(d,)
return fill[:-1]
final_shape: _List[int] = []
index = 0
for i,item in enumerate(_to):
if item==_fro[index]:
final_shape.append(item)
index+=1
else:
final_shape.append(1)
if _fro[index]==1 and not keep_ones:
index+=1
if index==len(_fro):
final_shape = final_shape+[1]*(len(_to)-i-1)
break
if index!=len(_fro): raise ValueError(f'shapes cannot be shifted {fro} --> {to}')
return tuple(final_shape[::-1] if mode=='left' else final_shape)
def shapeblender(a: Tuple[int, ...],
b: Tuple[int, ...]) -> Tuple[int, ...]:
def shapeblender(a: _Tuple[int, ...],
b: _Tuple[int, ...]) -> _Tuple[int, ...]:
"""
Return a shape that overlaps the rightmost entries of 'a' with the leftmost of 'b'.
@ -553,7 +528,7 @@ def shapeblender(a: Tuple[int, ...],
return a + b[i:]
def extend_docstring(extra_docstring: str) -> Callable:
def extend_docstring(extra_docstring: str) -> _Callable:
"""
Decorator: Append to function's docstring.
@ -569,8 +544,8 @@ def extend_docstring(extra_docstring: str) -> Callable:
return _decorator
def extended_docstring(f: Callable,
extra_docstring: str) -> Callable:
def extended_docstring(f: _Callable,
extra_docstring: str) -> _Callable:
"""
Decorator: Combine another function's docstring with a given docstring.
@ -588,7 +563,7 @@ def extended_docstring(f: Callable,
return _decorator
def DREAM3D_base_group(fname: Union[str, Path]) -> str:
def DREAM3D_base_group(fname: _Union[str, _Path]) -> str:
"""
Determine the base group of a DREAM.3D file.
@ -606,7 +581,7 @@ def DREAM3D_base_group(fname: Union[str, Path]) -> str:
Path to the base group.
"""
with h5py.File(Path(fname).expanduser(),'r') as f:
with _h5py.File(_Path(fname).expanduser(),'r') as f:
base_group = f.visit(lambda path: path.rsplit('/',2)[0] if '_SIMPL_GEOMETRY/SPACING' in path else None)
if base_group is None:
@ -614,7 +589,7 @@ def DREAM3D_base_group(fname: Union[str, Path]) -> str:
return base_group
def DREAM3D_cell_data_group(fname: Union[str, Path]) -> str:
def DREAM3D_cell_data_group(fname: _Union[str, _Path]) -> str:
"""
Determine the cell data group of a DREAM.3D file.
@ -634,10 +609,10 @@ def DREAM3D_cell_data_group(fname: Union[str, Path]) -> str:
"""
base_group = DREAM3D_base_group(fname)
with h5py.File(Path(fname).expanduser(),'r') as f:
with _h5py.File(_Path(fname).expanduser(),'r') as f:
cells = tuple(f['/'.join([base_group,'_SIMPL_GEOMETRY','DIMENSIONS'])][()][::-1])
cell_data_group = f[base_group].visititems(lambda path,obj: path.split('/')[0] \
if isinstance(obj,h5py._hl.dataset.Dataset) and np.shape(obj)[:-1] == cells \
if isinstance(obj,_h5py._hl.dataset.Dataset) and _np.shape(obj)[:-1] == cells \
else None)
if cell_data_group is None:
@ -647,8 +622,8 @@ def DREAM3D_cell_data_group(fname: Union[str, Path]) -> str:
def Bravais_to_Miller(*,
uvtw: np.ndarray = None,
hkil: np.ndarray = None) -> np.ndarray:
uvtw: _np.ndarray = None,
hkil: _np.ndarray = None) -> _np.ndarray:
"""
Transform 4 Miller–Bravais indices to 3 Miller indices of crystal direction [uvw] or plane normal (hkl).
@ -665,19 +640,19 @@ def Bravais_to_Miller(*,
"""
if (uvtw is not None) ^ (hkil is None):
raise KeyError('specify either "uvtw" or "hkil"')
axis,basis = (np.array(uvtw),np.array([[1,0,-1,0],
[0,1,-1,0],
[0,0, 0,1]])) \
axis,basis = (_np.array(uvtw),_np.array([[1,0,-1,0],
[0,1,-1,0],
[0,0, 0,1]])) \
if hkil is None else \
(np.array(hkil),np.array([[1,0,0,0],
[0,1,0,0],
[0,0,0,1]]))
return np.einsum('il,...l',basis,axis)
(_np.array(hkil),_np.array([[1,0,0,0],
[0,1,0,0],
[0,0,0,1]]))
return _np.einsum('il,...l',basis,axis)
def Miller_to_Bravais(*,
uvw: np.ndarray = None,
hkl: np.ndarray = None) -> np.ndarray:
uvw: _np.ndarray = None,
hkl: _np.ndarray = None) -> _np.ndarray:
"""
Transform 3 Miller indices to 4 Miller–Bravais indices of crystal direction [uvtw] or plane normal (hkil).
@ -694,19 +669,19 @@ def Miller_to_Bravais(*,
"""
if (uvw is not None) ^ (hkl is None):
raise KeyError('specify either "uvw" or "hkl"')
axis,basis = (np.array(uvw),np.array([[ 2,-1, 0],
[-1, 2, 0],
[-1,-1, 0],
[ 0, 0, 3]])/3) \
axis,basis = (_np.array(uvw),_np.array([[ 2,-1, 0],
[-1, 2, 0],
[-1,-1, 0],
[ 0, 0, 3]])/3) \
if hkl is None else \
(np.array(hkl),np.array([[ 1, 0, 0],
[ 0, 1, 0],
[-1,-1, 0],
[ 0, 0, 1]]))
return np.einsum('il,...l',basis,axis)
(_np.array(hkl),_np.array([[ 1, 0, 0],
[ 0, 1, 0],
[-1,-1, 0],
[ 0, 0, 1]]))
return _np.einsum('il,...l',basis,axis)
def dict_prune(d: Dict) -> Dict:
def dict_prune(d: _Dict) -> _Dict:
"""
Recursively remove empty dictionaries.
@ -732,7 +707,7 @@ def dict_prune(d: Dict) -> Dict:
return new
def dict_flatten(d: Dict) -> Dict:
def dict_flatten(d: _Dict) -> _Dict:
"""
Recursively remove keys of single-entry dictionaries.
@ -756,8 +731,8 @@ def dict_flatten(d: Dict) -> Dict:
return new
def tail_repack(extended: Union[str, Sequence[str]],
existing: List[str] = []) -> List[str]:
def tail_repack(extended: _Union[str, _Sequence[str]],
existing: _List[str] = []) -> _List[str]:
"""
Repack tailing characters into single string if all are new.
@ -782,11 +757,11 @@ def tail_repack(extended: Union[str, Sequence[str]],
"""
return [extended] if isinstance(extended,str) else existing + \
([''.join(extended[len(existing):])] if np.prod([len(i) for i in extended[len(existing):]]) == 1 else
([''.join(extended[len(existing):])] if _np.prod([len(i) for i in extended[len(existing):]]) == 1 else
list(extended[len(existing):]))
def aslist(arg: Union[IntCollection,int,None]) -> List:
def aslist(arg: _Union[_IntCollection, int, None]) -> _List:
"""
Transform argument to list.
@ -801,7 +776,7 @@ def aslist(arg: Union[IntCollection,int,None]) -> List:
Entity transformed into list.
"""
return [] if arg is None else list(arg) if isinstance(arg,(np.ndarray,Collection)) else [arg]
return [] if arg is None else list(arg) if isinstance(arg,(_np.ndarray,_Collection)) else [arg]
####################################################################################################
@ -834,11 +809,11 @@ class ProgressBar:
self.total = total
self.prefix = prefix
self.bar_length = bar_length
self.time_start = self.time_last_update = datetime.datetime.now()
self.time_start = self.time_last_update = _datetime.datetime.now()
self.fraction_last = 0.0
sys.stderr.write(f"{self.prefix} {'░'*self.bar_length} 0% ETA n/a")
sys.stderr.flush()
_sys.stderr.write(f"{self.prefix} {'░'*self.bar_length} 0% ETA n/a")
_sys.stderr.flush()
def update(self,
iteration: int) -> None:
@ -846,17 +821,17 @@ class ProgressBar:
fraction = (iteration+1) / self.total
if (filled_length := int(self.bar_length * fraction)) > int(self.bar_length * self.fraction_last) or \
datetime.datetime.now() - self.time_last_update > datetime.timedelta(seconds=10):
self.time_last_update = datetime.datetime.now()
_datetime.datetime.now() - self.time_last_update > _datetime.timedelta(seconds=10):
self.time_last_update = _datetime.datetime.now()
bar = '█' * filled_length + '░' * (self.bar_length - filled_length)
remaining_time = (datetime.datetime.now() - self.time_start) \
remaining_time = (_datetime.datetime.now() - self.time_start) \
* (self.total - (iteration+1)) / (iteration+1)
remaining_time -= datetime.timedelta(microseconds=remaining_time.microseconds) # remove μs
sys.stderr.write(f'\r{self.prefix} {bar} {fraction:>4.0%} ETA {remaining_time}')
sys.stderr.flush()
remaining_time -= _datetime.timedelta(microseconds=remaining_time.microseconds) # remove μs
_sys.stderr.write(f'\r{self.prefix} {bar} {fraction:>4.0%} ETA {remaining_time}')
_sys.stderr.flush()
self.fraction_last = fraction
if iteration == self.total - 1:
sys.stderr.write('\n')
sys.stderr.flush()
_sys.stderr.write('\n')
_sys.stderr.flush()

4
python/tests/test_Orientation.py
View File

@ -224,11 +224,11 @@ class TestOrientation:
@pytest.mark.parametrize('family',crystal_families)
def test_reduced_corner_cases(self,family):
# test whether there is always a sym-eq rotation that falls into the FZ
# test whether there is always exactly one sym-eq rotation that falls into the FZ
N = np.random.randint(10,40)
size = np.ones(3)*np.pi**(2./3.)
grid = grid_filters.coordinates0_node([N+1,N+1,N+1],size,-size*.5)
evenly_distributed = Orientation.from_cubochoric(x=grid[:-2,:-2,:-2],family=family)
evenly_distributed = Orientation.from_cubochoric(x=grid,family=family)
assert evenly_distributed.shape == evenly_distributed.reduced.shape
@pytest.mark.parametrize('family',crystal_families)

15
python/tests/test_Rotation.py
View File

@ -301,14 +301,13 @@ def ro2ho(ro):
#---------- Homochoric vector----------
def ho2ax(ho):
"""Homochoric vector to axis angle pair."""
tfit = np.array([+1.0000000000018852, -0.5000000002194847,
-0.024999992127593126, -0.003928701544781374,
-0.0008152701535450438, -0.0002009500426119712,
-0.00002397986776071756, -0.00008202868926605841,
+0.00012448715042090092, -0.0001749114214822577,
+0.0001703481934140054, -0.00012062065004116828,
+0.000059719705868660826, -0.00001980756723965647,
+0.000003953714684212874, -0.00000036555001439719544])
tfit = np.array([+0.9999999999999968, -0.49999999999986866, -0.025000000000632055,
-0.003928571496460683, -0.0008164666077062752, -0.00019411896443261646,
-0.00004985822229871769, -0.000014164962366386031, -1.9000248160936107e-6,
-5.72184549898506e-6, +7.772149920658778e-6, -0.00001053483452909705,
+9.528014229335313e-6, -5.660288876265125e-6, +1.2844901692764126e-6,
+1.1255185726258763e-6, -1.3834391419956455e-6, +7.513691751164847e-7,
-2.401996891720091e-7, +4.386887017466388e-8, -3.5917775353564864e-9])
# normalize h and store the magnitude
hmag_squared = np.sum(ho**2.)
if iszero(hmag_squared):

28
src/CLI.f90
View File

@ -18,7 +18,7 @@ module CLI
use parallelization
use system_routines
implicit none
implicit none(type,external)
private
integer, public, protected :: &
CLI_restartInc = 0 !< Increment at which calculation starts
@ -156,15 +156,15 @@ subroutine CLI_init
if (CLI_restartInc < 0 .or. stat /=0) then
print'(/,a)', ' ERROR: Could not parse restart increment: '//trim(arg)
call quit(1)
endif
end if
end select
if (err /= 0) call quit(1)
enddo
end do
if (len_trim(loadcaseArg) == 0 .or. len_trim(geometryArg) == 0) then
print'(/,a)', ' ERROR: Please specify geometry AND load case (-h for help)'
call quit(1)
endif
end if
if (len_trim(workingDirArg) > 0) call setWorkingDirectory(trim(workingDirArg))
CLI_geomFile = getGeometryFile(geometryArg)
@ -205,14 +205,14 @@ subroutine setWorkingDirectory(workingDirectoryArg)
else absolutePath
workingDirectory = getCWD()
workingDirectory = trim(workingDirectory)//'/'//workingDirectoryArg
endif absolutePath
end if absolutePath
workingDirectory = trim(rectifyPath(workingDirectory))
error = setCWD(trim(workingDirectory))
if(error) then
print*, 'ERROR: Invalid Working directory: '//trim(workingDirectory)
call quit(1)
endif
end if
end subroutine setWorkingDirectory
@ -256,7 +256,7 @@ function getGeometryFile(geometryParameter)
if (.not. file_exists) then
print*, 'ERROR: Geometry file does not exists: '//trim(getGeometryFile)
call quit(1)
endif
end if
end function getGeometryFile
@ -279,7 +279,7 @@ function getLoadCaseFile(loadCaseParameter)
if (.not. file_exists) then
print*, 'ERROR: Load case file does not exists: '//trim(getLoadCaseFile)
call quit(1)
endif
end if
end function getLoadCaseFile
@ -300,14 +300,14 @@ function rectifyPath(path)
l = len_trim(rectifyPath)
do i = l,3,-1
if (rectifyPath(i-2:i) == '/./') rectifyPath(i-1:l) = rectifyPath(i+1:l)//' '
enddo
end do
!--------------------------------------------------------------------------------------------------
! remove // from path
l = len_trim(rectifyPath)
do i = l,2,-1
if (rectifyPath(i-1:i) == '//') rectifyPath(i-1:l) = rectifyPath(i:l)//' '
enddo
end do
!--------------------------------------------------------------------------------------------------
! remove ../ and corresponding directory from rectifyPath
@ -321,9 +321,9 @@ function rectifyPath(path)
k = len_trim(rectifyPath)
rectifyPath(j+1:k-1) = rectifyPath(j+2:k)
rectifyPath(k:k) = ' '
endif
end if
i = j+index(rectifyPath(j+1:l),'../')
enddo
end do
if(len_trim(rectifyPath) == 0) rectifyPath = '/'
rectifyPath = trim(rectifyPath)
@ -349,10 +349,10 @@ function makeRelativePath(a,b)
do i = 1, min(len_trim(a_cleaned),len_trim(rectifyPath(b_cleaned)))
if (a_cleaned(i:i) /= b_cleaned(i:i)) exit
if (a_cleaned(i:i) == '/') posLastCommonSlash = i
enddo
end do
do i = posLastCommonSlash+1,len_trim(a_cleaned)
if (a_cleaned(i:i) == '/') remainingSlashes = remainingSlashes + 1
enddo
end do
makeRelativePath = repeat('..'//'/',remainingSlashes)//b_cleaned(posLastCommonSlash+1:len_trim(b_cleaned))

6
src/HDF5_utilities.f90
View File

@ -18,7 +18,11 @@ module HDF5_utilities
use prec
use parallelization
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
!--------------------------------------------------------------------------------------------------
@ -509,7 +513,7 @@ subroutine HDF5_addAttribute_str_array(loc_id,attrLabel,attrValue,path)
do i=1,size(attrValue)
attrValue_(i) = attrValue(i)//C_NULL_CHAR
ptr(i) = c_loc(attrValue_(i))
enddo
end do
call H5Screate_simple_f(1,shape(attrValue_,kind=HSIZE_T),space_id,hdferr,shape(attrValue_,kind=HSIZE_T))
if(hdferr < 0) error stop 'HDF5 error'

229
src/IO.f90
View File

@ -12,7 +12,7 @@ module IO
use prec
implicit none
implicit none(type,external)
private
character(len=*), parameter, public :: &
@ -24,11 +24,6 @@ module IO
character, parameter :: &
CR = achar(13), &
LF = IO_EOL
character(len=*), parameter :: &
IO_DIVIDER = '───────────────────'//&
'───────────────────'//&
'───────────────────'//&
'────────────'
public :: &
IO_init, &
@ -54,11 +49,11 @@ contains
!--------------------------------------------------------------------------------------------------
!> @brief Do self test.
!--------------------------------------------------------------------------------------------------
subroutine IO_init
subroutine IO_init()
print'(/,1x,a)', '<<<+- IO init -+>>>'; flush(IO_STDOUT)
call selfTest
call selfTest()
end subroutine IO_init
@ -95,17 +90,17 @@ function IO_readlines(fileName) result(fileContent)
if (endPos - startPos > pStringLen-1) then
line = rawData(startPos:startPos+pStringLen-1)
if (.not. warned) then
call IO_warning(207,ext_msg=trim(fileName),el=l)
call IO_warning(207,trim(fileName),label1='line',ID1=l)
warned = .true.
endif
end if
else
line = rawData(startPos:endpos)
endif
end if
startPos = endPos + 2 ! jump to next line start
fileContent(l) = trim(line)//''
l = l + 1
enddo
end do
end function IO_readlines
@ -129,15 +124,15 @@ function IO_read(fileName) result(fileContent)
inquire(file = fileName, size=fileLength)
open(newunit=fileUnit, file=fileName, access='stream',&
status='old', position='rewind', action='read',iostat=myStat)
if (myStat /= 0) call IO_error(100,ext_msg=trim(fileName))
if (myStat /= 0) call IO_error(100,trim(fileName))
allocate(character(len=fileLength)::fileContent)
if (fileLength==0) then
close(fileUnit)
return
endif
end if
read(fileUnit,iostat=myStat) fileContent
if (myStat /= 0) call IO_error(102,ext_msg=trim(fileName))
if (myStat /= 0) call IO_error(102,trim(fileName))
close(fileUnit)
if (scan(fileContent(:index(fileContent,LF)),CR//LF) /= 0) fileContent = CRLF2LF(fileContent)
@ -188,8 +183,8 @@ pure function IO_stringPos(string)
endOfString: if (right < left) then
IO_stringPos(IO_stringPos(1)*2+1) = len_trim(string)
exit
endif endOfString
enddo
end if endOfString
end do
end function IO_stringPos
@ -206,10 +201,10 @@ function IO_stringValue(string,chunkPos,myChunk)
validChunk: if (myChunk > chunkPos(1) .or. myChunk < 1) then
IO_stringValue = ''
call IO_error(110,el=myChunk,ext_msg='IO_stringValue: "'//trim(string)//'"')
call IO_error(110,'IO_stringValue: "'//trim(string)//'"',label1='chunk',ID1=myChunk)
else validChunk
IO_stringValue = string(chunkPos(myChunk*2):chunkPos(myChunk*2+1))
endif validChunk
end if validChunk
end function IO_stringValue
@ -262,8 +257,8 @@ pure function IO_lc(string)
IO_lc(i:i) = LOWER(n:n)
else
IO_lc(i:i) = string(i:i)
endif
enddo
end if
end do
end function IO_lc
@ -285,7 +280,7 @@ function IO_rmComment(line)
IO_rmComment = trim(line)
else
IO_rmComment = trim(line(:split-1))
endif
end if
end function IO_rmComment
@ -303,11 +298,11 @@ integer function IO_stringAsInt(string)
valid: if (verify(string,VALIDCHARS) == 0) then
read(string,*,iostat=readStatus) IO_stringAsInt
if (readStatus /= 0) call IO_error(111,ext_msg=string)
if (readStatus /= 0) call IO_error(111,string)
else valid
IO_stringAsInt = 0
call IO_error(111,ext_msg=string)
endif valid
call IO_error(111,string)
end if valid
end function IO_stringAsInt
@ -325,11 +320,11 @@ real(pReal) function IO_stringAsFloat(string)
valid: if (verify(string,VALIDCHARS) == 0) then
read(string,*,iostat=readStatus) IO_stringAsFloat
if (readStatus /= 0) call IO_error(112,ext_msg=string)
if (readStatus /= 0) call IO_error(112,string)
else valid
IO_stringAsFloat = 0.0_pReal
call IO_error(112,ext_msg=string)
endif valid
call IO_error(112,string)
end if valid
end function IO_stringAsFloat
@ -348,33 +343,27 @@ logical function IO_stringAsBool(string)
IO_stringAsBool = .false.
else
IO_stringAsBool = .false.
call IO_error(113,ext_msg=string)
endif
call IO_error(113,string)
end if
end function IO_stringAsBool
!--------------------------------------------------------------------------------------------------
!> @brief Write error statements to standard out and terminate the run with exit #9xxx
!> @brief Write error statements and terminate the run with exit #9xxx.
!--------------------------------------------------------------------------------------------------
subroutine IO_error(error_ID,el,ip,g,instance,ext_msg)
subroutine IO_error(error_ID,ext_msg,label1,ID1,label2,ID2)
integer, intent(in) :: error_ID
integer, optional, intent(in) :: el,ip,g,instance
character(len=*), optional, intent(in) :: ext_msg
character(len=*), optional, intent(in) :: ext_msg,label1,label2
integer, optional, intent(in) :: ID1,ID2
external :: quit
character(len=:), allocatable :: msg
character(len=pStringLen) :: formatString
select case (error_ID)
!--------------------------------------------------------------------------------------------------
! internal errors
case (0)
msg = 'internal check failed:'
!--------------------------------------------------------------------------------------------------
! file handling errors
case (100)
@ -446,7 +435,7 @@ subroutine IO_error(error_ID,el,ip,g,instance,ext_msg)
case (190)
msg = 'unknown element type:'
case (191)
msg = 'mesh consists of more than one element type'
msg = 'mesh contains more than one element type'
!--------------------------------------------------------------------------------------------------
! plasticity error messages
@ -483,27 +472,27 @@ subroutine IO_error(error_ID,el,ip,g,instance,ext_msg)
!------------------------------------------------------------------------------------------------
! errors related to YAML data
case (701)
msg = 'Incorrect indent/Null value not allowed'
msg = 'incorrect indent/Null value not allowed'
case (702)
msg = 'Invalid use of flow YAML'
msg = 'invalid use of flow YAML'
case (703)
msg = 'Invalid YAML'
msg = 'invalid YAML'
case (704)
msg = 'Space expected after a colon for <key>: <value> pair'
msg = 'space expected after a colon for <key>: <value> pair'
case (705)
msg = 'Unsupported feature'
msg = 'unsupported feature'
case (706)
msg = 'Type mismatch in YAML data node'
msg = 'type mismatch in YAML data node'
case (707)
msg = 'Abrupt end of file'
msg = 'abrupt end of file'
case (708)
msg = '--- expected after YAML file header'
msg = '"---" expected after YAML file header'
case (709)
msg = 'Length mismatch'
msg = 'length mismatch'
case (710)
msg = 'Closing quotation mark missing in string'
msg = 'closing quotation mark missing in string'
case (711)
msg = 'Incorrect type'
msg = 'incorrect type'
!-------------------------------------------------------------------------------------------------
! errors related to the mesh solver
@ -540,58 +529,35 @@ subroutine IO_error(error_ID,el,ip,g,instance,ext_msg)
case (950)
msg = 'max number of cut back exceeded, terminating'
!-------------------------------------------------------------------------------------------------
! general error messages
case default
msg = 'unknown error number...'
error stop 'invalid error number'
end select
!$OMP CRITICAL (write2out)
write(IO_STDERR,'(/,a)') ' ┌'//IO_DIVIDER//'┐'
write(IO_STDERR,'(a,24x,a,40x,a)') ' │','error', '│'
write(IO_STDERR,'(a,24x,i3,42x,a)') ' │',error_ID, '│'
write(IO_STDERR,'(a)') ' ├'//IO_DIVIDER//'┤'
write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(msg)),',',&
max(1,72-len_trim(msg)-4),'x,a)'
write(IO_STDERR,formatString) '│ ',trim(msg), '│'
if (present(ext_msg)) then
write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(ext_msg)),',',&
max(1,72-len_trim(ext_msg)-4),'x,a)'
write(IO_STDERR,formatString) '│ ',trim(ext_msg), '│'
endif
if (present(el)) &
write(IO_STDERR,'(a19,1x,i9,44x,a3)') ' │ at element ',el, '│'
if (present(ip)) &
write(IO_STDERR,'(a19,1x,i9,44x,a3)') ' │ at IP ',ip, '│'
if (present(g)) &
write(IO_STDERR,'(a19,1x,i9,44x,a3)') ' │ at constituent',g, '│'
if (present(instance)) &
write(IO_STDERR,'(a19,1x,i9,44x,a3)') ' │ at instance ',instance, '│'
write(IO_STDERR,'(a,69x,a)') ' │', '│'
write(IO_STDERR,'(a)') ' └'//IO_DIVIDER//'┘'
flush(IO_STDERR)
call panel('error',error_ID,msg, &
ext_msg=ext_msg, &
label1=label1,ID1=ID1, &
label2=label2,ID2=ID2)
call quit(9000+error_ID)
!$OMP END CRITICAL (write2out)
end subroutine IO_error
!--------------------------------------------------------------------------------------------------
!> @brief Write warning statement to standard out.
!> @brief Write warning statements.
!--------------------------------------------------------------------------------------------------
subroutine IO_warning(warning_ID,el,ip,g,ext_msg)
subroutine IO_warning(warning_ID,ext_msg,label1,ID1,label2,ID2)
integer, intent(in) :: warning_ID
integer, optional, intent(in) :: el,ip,g
character(len=*), optional, intent(in) :: ext_msg
character(len=*), optional, intent(in) :: ext_msg,label1,label2
integer, optional, intent(in) :: ID1,ID2
character(len=:), allocatable :: msg
character(len=pStringLen) :: formatString
select case (warning_ID)
case (47)
msg = 'no valid parameter for FFTW, using FFTW_PATIENT'
msg = 'invalid parameter for FFTW'
case (207)
msg = 'line truncated'
case (600)
@ -600,33 +566,15 @@ subroutine IO_warning(warning_ID,el,ip,g,ext_msg)
msg = 'stiffness close to zero'
case (709)
msg = 'read only the first document'
case default
msg = 'unknown warning number'
error stop 'invalid warning number'
end select
!$OMP CRITICAL (write2out)
write(IO_STDERR,'(/,a)') ' ┌'//IO_DIVIDER//'┐'
write(IO_STDERR,'(a,24x,a,38x,a)') ' │','warning', '│'
write(IO_STDERR,'(a,24x,i3,42x,a)') ' │',warning_ID, '│'
write(IO_STDERR,'(a)') ' ├'//IO_DIVIDER//'┤'
write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(msg)),',',&
max(1,72-len_trim(msg)-4),'x,a)'
write(IO_STDERR,formatString) '│ ',trim(msg), '│'
if (present(ext_msg)) then
write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a4,a',max(1,len_trim(ext_msg)),',',&
max(1,72-len_trim(ext_msg)-4),'x,a)'
write(IO_STDERR,formatString) '│ ',trim(ext_msg), '│'
endif
if (present(el)) &
write(IO_STDERR,'(a19,1x,i9,44x,a3)') ' │ at element ',el, '│'
if (present(ip)) &
write(IO_STDERR,'(a19,1x,i9,44x,a3)') ' │ at IP ',ip, '│'
if (present(g)) &
write(IO_STDERR,'(a19,1x,i9,44x,a3)') ' │ at constituent',g, '│'
write(IO_STDERR,'(a,69x,a)') ' │', '│'
write(IO_STDERR,'(a)') ' └'//IO_DIVIDER//'┘'
flush(IO_STDERR)
!$OMP END CRITICAL (write2out)
call panel('warning',warning_ID,msg, &
ext_msg=ext_msg, &
label1=label1,ID1=ID1, &
label2=label2,ID2=ID2)
end subroutine IO_warning
@ -650,11 +598,65 @@ pure function CRLF2LF(string)
CRLF2LF(c-n:c-n) = string(c:c)
if (c == len_trim(string)) exit
if (string(c:c+1) == CR//LF) n = n + 1
enddo
end do
CRLF2LF = CRLF2LF(:c-n)
end function
end function CRLF2LF
!--------------------------------------------------------------------------------------------------
!> @brief Write statements to standard error.
!--------------------------------------------------------------------------------------------------
subroutine panel(paneltype,ID,msg,ext_msg,label1,ID1,label2,ID2)
character(len=*), intent(in) :: paneltype,msg
character(len=*), optional, intent(in) :: ext_msg,label1,label2
integer, intent(in) :: ID
integer, optional, intent(in) :: ID1,ID2
character(len=pStringLen) :: formatString
integer, parameter :: panelwidth = 69
character(len=*), parameter :: DIVIDER = repeat('─',panelwidth)
if (.not. present(label1) .and. present(ID1)) error stop 'missing label for value 1'
if (.not. present(label2) .and. present(ID2)) error stop 'missing label for value 2'
if ( present(label1) .and. .not. present(ID1)) error stop 'missing value for label 1'
if ( present(label2) .and. .not. present(ID2)) error stop 'missing value for label 2'
!$OMP CRITICAL (write2out)
write(IO_STDERR,'(/,a)') ' ┌'//DIVIDER//'┐'
write(formatString,'(a,i2,a)') '(a,24x,a,',max(1,panelwidth-24-len_trim(paneltype)),'x,a)'
write(IO_STDERR,formatString) ' │',trim(paneltype), '│'
write(formatString,'(a,i2,a)') '(a,24x,i3,',max(1,panelwidth-24-3),'x,a)'
write(IO_STDERR,formatString) ' │',ID, '│'
write(IO_STDERR,'(a)') ' ├'//DIVIDER//'┤'
write(formatString,'(a,i3.3,a,i3.3,a)') '(1x,a4,a',max(1,len_trim(msg)),',',&
max(1,panelwidth+3-len_trim(msg)-4),'x,a)'
write(IO_STDERR,formatString) '│ ',trim(msg), '│'
if (present(ext_msg)) then
write(formatString,'(a,i3.3,a,i3.3,a)') '(1x,a4,a',max(1,len_trim(ext_msg)),',',&
max(1,panelwidth+3-len_trim(ext_msg)-4),'x,a)'
write(IO_STDERR,formatString) '│ ',trim(ext_msg), '│'
end if
if (present(label1)) then
write(formatString,'(a,i3.3,a,i3.3,a)') '(1x,a7,a',max(1,len_trim(label1)),',i9,',&
max(1,panelwidth+3-len_trim(label1)-9-7),'x,a)'
write(IO_STDERR,formatString) '│ at ',trim(label1),ID1, '│'
end if
if (present(label2)) then
write(formatString,'(a,i3.3,a,i3.3,a)') '(1x,a7,a',max(1,len_trim(label2)),',i9,',&
max(1,panelwidth+3-len_trim(label2)-9-7),'x,a)'
write(IO_STDERR,formatString) '│ at ',trim(label2),ID2, '│'
end if
write(formatString,'(a,i2.2,a)') '(a,',max(1,panelwidth),'x,a)'
write(IO_STDERR,formatString) ' │', '│'
write(IO_STDERR,'(a)') ' └'//DIVIDER//'┘'
flush(IO_STDERR)
!$OMP END CRITICAL (write2out)
end subroutine panel
!--------------------------------------------------------------------------------------------------
@ -665,6 +667,7 @@ subroutine selfTest()
integer, dimension(:), allocatable :: chunkPos
character(len=:), allocatable :: str
if(dNeq(1.0_pReal, IO_stringAsFloat('1.0'))) error stop 'IO_stringAsFloat'
if(dNeq(1.0_pReal, IO_stringAsFloat('1e0'))) error stop 'IO_stringAsFloat'
if(dNeq(0.1_pReal, IO_stringAsFloat('1e-1'))) error stop 'IO_stringAsFloat'

10
src/LAPACK_interface.f90
View File

@ -8,6 +8,8 @@ module LAPACK_interface
pure subroutine dgeev(jobvl,jobvr,n,a,lda,wr,wi,vl,ldvl,vr,ldvr,work,lwork,info)
use prec
implicit none(type,external)
character, intent(in) :: jobvl,jobvr
integer, intent(in) :: n,lda,ldvl,ldvr,lwork
real(pReal), intent(inout), dimension(lda,n) :: a
@ -20,6 +22,8 @@ module LAPACK_interface
pure subroutine dgesv(n,nrhs,a,lda,ipiv,b,ldb,info)
use prec
implicit none(type,external)
integer, intent(in) :: n,nrhs,lda,ldb
real(pReal), intent(inout), dimension(lda,n) :: a
integer, intent(out), dimension(n) :: ipiv
@ -29,6 +33,8 @@ module LAPACK_interface
pure subroutine dgetrf(m,n,a,lda,ipiv,info)
use prec
implicit none(type,external)
integer, intent(in) :: m,n,lda
real(pReal), intent(inout), dimension(lda,n) :: a
integer, intent(out), dimension(min(m,n)) :: ipiv
@ -37,6 +43,8 @@ module LAPACK_interface
pure subroutine dgetri(n,a,lda,ipiv,work,lwork,info)
use prec
implicit none(type,external)
integer, intent(in) :: n,lda,lwork
real(pReal), intent(inout), dimension(lda,n) :: a
integer, intent(in), dimension(n) :: ipiv
@ -46,6 +54,8 @@ module LAPACK_interface
pure subroutine dsyev(jobz,uplo,n,a,lda,w,work,lwork,info)
use prec
implicit none(type,external)
character, intent(in) :: jobz,uplo
integer, intent(in) :: n,lda,lwork
real(pReal), intent(inout), dimension(lda,n) :: a

32
src/Marc/DAMASK_Marc.f90
View File

@ -25,7 +25,7 @@ module DAMASK_interface
use ifport, only: &
CHDIR
implicit none
implicit none(type,external)
private
logical, protected, public :: symmetricSolver
@ -210,8 +210,8 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
use materialpoint_Marc
use OMP_LIB
implicit none
integer, intent(in) :: & ! according to MSC.Marc 2012 Manual D
implicit none(type,external)
integer(pI64), intent(in) :: & ! according to MSC.Marc 2012 Manual D
ngens, & !< size of stress-strain law
nn, & !< integration point number
ndi, & !< number of direct components
@ -224,7 +224,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
jtype, & !< element type
ifr, & !< set to 1 if R has been calculated
ifu !< set to 1 if stretch has been calculated
integer, dimension(2), intent(in) :: & ! according to MSC.Marc 2012 Manual D
integer(pI64), dimension(2), intent(in) :: & ! according to MSC.Marc 2012 Manual D
m, & !< (1) user element number, (2) internal element number
matus, & !< (1) user material identification number, (2) internal material identification number
kcus, & !< (1) layer number, (2) internal layer number
@ -362,7 +362,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, &
endif
lastLovl = lovl
call materialpoint_general(computationMode,ffn,ffn1,t(1),timinc,m(1),nn,stress,ddsdde)
call materialpoint_general(computationMode,ffn,ffn1,t(1),timinc,int(m(1)),int(nn),stress,ddsdde)
d = ddsdde(1:ngens,1:ngens)
s = stress(1:ndi+nshear)
@ -382,17 +382,18 @@ subroutine flux(f,ts,n,time)
use homogenization
use discretization_Marc
implicit none
real(pReal), dimension(6), intent(in) :: &
implicit none(type,external)
real(pReal), dimension(6), intent(in) :: &
ts
integer, dimension(10), intent(in) :: &
integer(pI64), dimension(10), intent(in) :: &
n
real(pReal), intent(in) :: &
real(pReal), intent(in) :: &
time
real(pReal), dimension(2), intent(out) :: &
real(pReal), dimension(2), intent(out) :: &
f
f(1) = homogenization_f_T(discretization_Marc_FEM2DAMASK_cell(n(3),n(1)))
f(1) = homogenization_f_T(discretization_Marc_FEM2DAMASK_cell(int(n(3)),int(n(1))))
f(2) = 0.0_pReal
end subroutine flux
@ -409,8 +410,9 @@ subroutine uedinc(inc,incsub)
use materialpoint_Marc
use discretization_Marc
implicit none
integer, intent(in) :: inc, incsub
implicit none(type,external)
integer(pI64), intent(in) :: inc, incsub
integer :: n, nqncomp, nqdatatype
integer, save :: inc_written
real(pReal), allocatable, dimension(:,:) :: d_n
@ -427,9 +429,9 @@ subroutine uedinc(inc,incsub)
enddo
call discretization_Marc_UpdateNodeAndIpCoords(d_n)
call materialpoint_results(inc,cptim)
call materialpoint_results(int(inc),cptim)
inc_written = inc
inc_written = int(inc)
endif
end subroutine uedinc

18
src/Marc/discretization_Marc.f90
View File

@ -17,7 +17,7 @@ module discretization_Marc
use geometry_plastic_nonlocal
use results
implicit none
implicit none(type,external)
private
real(pReal), public, protected :: &
@ -80,13 +80,13 @@ subroutine discretization_Marc_init
num_commercialFEM => config_numerics%get('commercialFEM',defaultVal = emptyDict)
mesh_unitlength = num_commercialFEM%get_asFloat('unitlength',defaultVal=1.0_pReal) ! set physical extent of a length unit in mesh
if (mesh_unitlength <= 0.0_pReal) call IO_error(301,ext_msg='unitlength')
if (mesh_unitlength <= 0.0_pReal) call IO_error(301,'unitlength')
call inputRead(elem,node0_elem,connectivity_elem,materialAt)
nElems = size(connectivity_elem,2)
if (debug_e < 1 .or. debug_e > nElems) call IO_error(602,ext_msg='element')
if (debug_i < 1 .or. debug_i > elem%nIPs) call IO_error(602,ext_msg='IP')
if (debug_e < 1 .or. debug_e > nElems) call IO_error(602,'element')
if (debug_i < 1 .or. debug_i > elem%nIPs) call IO_error(602,'IP')
allocate(cellNodeDefinition(elem%nNodes-1))
allocate(connectivity_cell(elem%NcellNodesPerCell,elem%nIPs,nElems))
@ -579,7 +579,7 @@ subroutine inputRead_elemType(elem, &
character(len=*), dimension(:), intent(in) :: fileContent !< file content, separated per lines
integer, allocatable, dimension(:) :: chunkPos
integer :: i,j,t,l,remainingChunks
integer :: i,j,t,t_,l,remainingChunks
t = -1
@ -594,7 +594,8 @@ subroutine inputRead_elemType(elem, &
t = mapElemtype(IO_stringValue(fileContent(l+1+i+j),chunkPos,2))
call elem%init(t)
else
if (t /= mapElemtype(IO_stringValue(fileContent(l+1+i+j),chunkPos,2))) call IO_error(191,el=t,ip=i)
t_ = mapElemtype(IO_stringValue(fileContent(l+1+i+j),chunkPos,2))
if (t /= t_) call IO_error(191,IO_stringValue(fileContent(l+1+i+j),chunkPos,2),label1='type',ID1=t)
endif
remainingChunks = elem%nNodes - (chunkPos(1) - 2)
do while(remainingChunks > 0)
@ -616,7 +617,8 @@ subroutine inputRead_elemType(elem, &
character(len=*), intent(in) :: what
select case (IO_lc(what))
select case (what)
case ( '6')
mapElemtype = 1 ! Two-dimensional Plane Strain Triangle
case ( '125') ! 155, 128 (need test)
@ -644,7 +646,7 @@ subroutine inputRead_elemType(elem, &
case ( '21')
mapElemtype = 13 ! Three-dimensional Arbitrarily Distorted quadratic hexahedral
case default
call IO_error(error_ID=190,ext_msg=IO_lc(what))
call IO_error(190,what)
end select
end function mapElemtype

4
src/Marc/element.f90
View File

@ -5,7 +5,7 @@
module element
use IO
implicit none
implicit none(type,external)
private
!---------------------------------------------------------------------------------------------------
@ -714,7 +714,7 @@ subroutine tElement_init(self,elemType)
case(13)
self%cellNodeParentNodeWeights = CELLNODEPARENTNODEWEIGHTS13
case default
call IO_error(0,ext_msg='invalid element type')
error stop 'invalid element type'
end select

5
src/Marc/materialpoint_Marc.f90
View File

@ -23,7 +23,7 @@ module materialpoint_Marc
use discretization
use discretization_Marc
implicit none
implicit none(type,external)
private
real(pReal), dimension (:,:,:), allocatable, private :: &
@ -240,7 +240,8 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
endif
if (all(abs(materialpoint_dcsdE(1:6,1:6,ip,elCP)) < 1e-10_pReal)) call IO_warning(601,elCP,ip)
if (all(abs(materialpoint_dcsdE(1:6,1:6,ip,elCP)) < 1e-10_pReal)) &
call IO_warning(601,label1='element (CP)',ID1=elCP,label2='IP',ID2=ip)
cauchyStress = materialpoint_cs (1:6, ip,elCP)
jacobian = materialpoint_dcsdE(1:6,1:6,ip,elCP)

25
src/YAML_parse.f90
View File

@ -12,7 +12,7 @@ module YAML_parse
use system_routines
#endif
implicit none
implicit none(type,external)
private
public :: &
@ -24,6 +24,7 @@ module YAML_parse
subroutine to_flow_C(flow,length_flow,mixed) bind(C)
use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR, C_PTR
implicit none(type,external)
type(C_PTR), intent(out) :: flow
integer(C_INT), intent(out) :: length_flow
@ -102,7 +103,7 @@ recursive function parse_flow(YAML_flow) result(node)
class is (tDict)
call node%set(key,myVal)
end select
enddo
end do
elseif (flow_string(1:1) == '[') then ! start of a list
e = 1
allocate(tList::node)
@ -115,7 +116,7 @@ recursive function parse_flow(YAML_flow) result(node)
class is (tList)
call node%append(myVal)
end select
enddo
end do
else ! scalar value
allocate(tScalar::node)
select type (node)
@ -155,7 +156,7 @@ integer function find_end(str,e_char)
N_sq = N_sq - merge(1,0,str(i:i) == ']')
N_cu = N_cu - merge(1,0,str(i:i) == '}')
i = i + 1
enddo
end do
find_end = i
end function find_end
@ -332,7 +333,7 @@ subroutine skip_empty_lines(blck,s_blck)
do while(empty .and. len_trim(blck(s_blck:)) /= 0)
empty = len_trim(IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))) == 0
if(empty) s_blck = s_blck + index(blck(s_blck:),IO_EOL)
enddo
end do
end subroutine skip_empty_lines
@ -386,7 +387,7 @@ logical function flow_is_closed(str,e_char)
N_cu = N_cu + merge(1,0,line(i:i) == '{')
N_sq = N_sq - merge(1,0,line(i:i) == ']')
N_cu = N_cu - merge(1,0,line(i:i) == '}')
enddo
end do
end function flow_is_closed
@ -409,7 +410,7 @@ subroutine remove_line_break(blck,s_blck,e_char,flow_line)
flow_line = flow_line//IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))//' '
line_end = flow_is_closed(flow_line,e_char)
s_blck = s_blck + index(blck(s_blck:),IO_EOL)
enddo
end do
end subroutine remove_line_break
@ -438,7 +439,7 @@ subroutine list_item_inline(blck,s_blck,inline,offset)
inline = inline//' '//trim(adjustl(IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))))
s_blck = s_blck + index(blck(s_blck:),IO_EOL)
indent_next = indentDepth(blck(s_blck:))
enddo
end do
if(scan(inline,",") > 0) inline = '"'//inline//'"'
@ -480,7 +481,7 @@ recursive subroutine line_isFlow(flow,s_flow,line)
flow(s_flow:s_flow+1) = ', '
s_flow = s_flow +2
s = s + find_end(line(s+1:),']')
enddo
end do
s_flow = s_flow - 1
if (flow(s_flow-1:s_flow-1) == ',') s_flow = s_flow - 1
flow(s_flow:s_flow) = ']'
@ -497,7 +498,7 @@ recursive subroutine line_isFlow(flow,s_flow,line)
flow(s_flow:s_flow+1) = ', '
s_flow = s_flow +2
s = s + find_end(line(s+1:),'}')
enddo
end do
s_flow = s_flow -1
if(flow(s_flow-1:s_flow-1) == ',') s_flow = s_flow -1
flow(s_flow:s_flow) = '}'
@ -645,7 +646,7 @@ recursive subroutine lst(blck,flow,s_blck,s_flow,offset)
s_flow = s_flow + 2
end if
enddo
end do
s_flow = s_flow - 1
if (flow(s_flow-1:s_flow-1) == ',') s_flow = s_flow - 1
@ -732,7 +733,7 @@ recursive subroutine dct(blck,flow,s_blck,s_flow,offset)
flow(s_flow:s_flow) = ' '
s_flow = s_flow + 1
offset = 0
enddo
end do
s_flow = s_flow - 1
if (flow(s_flow-1:s_flow-1) == ',') s_flow = s_flow - 1

14
src/YAML_types.f90
View File

@ -11,7 +11,7 @@ module YAML_types
use IO
use prec
implicit none
implicit none(type,external)
private
type, abstract, public :: tNode
@ -411,7 +411,7 @@ function tNode_get_byIndex(self,i) result(node)
do j = 2,i
item => item%next
enddo
end do
node => item%node
end function tNode_get_byIndex
@ -681,7 +681,7 @@ function tNode_contains(self,k) result(exists)
exists = .true.
return
end if
enddo
end do
class is(tList)
list => self%asList()
do j=1, list%length
@ -689,7 +689,7 @@ function tNode_contains(self,k) result(exists)
exists = .true.
return
end if
enddo
end do
class default
call IO_error(706,ext_msg='Expected list or dict')
end select
@ -731,7 +731,7 @@ function tNode_get_byKey(self,k,defaultVal) result(node)
end if
item => item%next
j = j + 1
enddo
end do
if (.not. found) then
call IO_error(143,ext_msg=k)
@ -1333,7 +1333,7 @@ function tList_as1dString(self)
scalar => item%node%asScalar()
tList_as1dString(i) = scalar%asString()
item => item%next
enddo
end do
end function tList_as1dString
@ -1384,7 +1384,7 @@ subroutine tDict_set(self,key,node)
searchExisting: do while (associated(item%next))
if (item%key == key) exit
item => item%next
enddo searchExisting
end do searchExisting
if (item%key /= key) then
allocate(item%next)
item => item%next

2
src/config.f90
View File

@ -9,7 +9,7 @@ module config
use results
use parallelization
implicit none
implicit none(type,external)
private
class(tNode), pointer, public :: &

2
src/constants.f90
View File

@ -5,7 +5,7 @@
module constants
use prec
implicit none
implicit none(type,external)
public
real(pReal), parameter :: &

4
src/discretization.f90
View File

@ -7,7 +7,7 @@ module discretization
use prec
use results
implicit none
implicit none(type,external)
private
integer, public, protected :: &
@ -68,7 +68,7 @@ subroutine discretization_init(materialAt,&
discretization_sharedNodesBegin = sharedNodesBegin
else
discretization_sharedNodesBegin = size(discretization_NodeCoords0,2)
endif
end if
end subroutine discretization_init

2
src/geometry_plastic_nonlocal.f90
View File

@ -9,7 +9,7 @@ module geometry_plastic_nonlocal
use prec
use results
implicit none
implicit none(type,external)
public
integer, protected :: &

10
src/grid/DAMASK_grid.f90
View File

@ -30,7 +30,11 @@ program DAMASK_grid
use grid_thermal_spectral
use results
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
type :: tLoadCase
type(tRotation) :: rot !< rotation of BC
@ -272,7 +276,7 @@ program DAMASK_grid
write(IO_STDOUT,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'R:',&
transpose(loadCases(l)%rot%asMatrix())
if (loadCases(l)%r <= 0.0) errorID = 833
if (loadCases(l)%r <= 0.0_pReal) errorID = 833
if (loadCases(l)%t < 0.0_pReal) errorID = 834
if (loadCases(l)%N < 1) errorID = 835
if (loadCases(l)%f_out < 1) errorID = 836
@ -290,7 +294,7 @@ program DAMASK_grid
if (loadCases(l)%f_restart < huge(0)) &
print'(2x,a,1x,i0)', 'f_restart:', loadCases(l)%f_restart
if (errorID > 0) call IO_error(error_ID = errorID, el = l)
if (errorID > 0) call IO_error(errorID,label1='line',ID1=l)
endif reportAndCheck
enddo
@ -501,7 +505,7 @@ subroutine getMaskedTensor(values,mask,tensor)
integer :: i,j
values = 0.0
values = 0.0_pReal
do i = 1,3
row => tensor%get(i)
do j = 1,3

13
src/grid/FFTW.f90 Normal file
View File

@ -0,0 +1,13 @@
!--------------------------------------------------------------------------------------------------
!> @author Martin Diehl, KU Leuven
!> @brief Wrap FFTW3 into a module.
!--------------------------------------------------------------------------------------------------
module FFTW3
use, intrinsic :: ISO_C_binding
implicit none(type,external)
public
include 'fftw3-mpi.f03'
end module FFTW3

4
src/grid/VTI.f90
View File

@ -8,7 +8,7 @@ module VTI
use base64
use IO
implicit none
implicit none(type,external)
private
public :: &
@ -151,7 +151,7 @@ subroutine VTI_readCellsSizeOrigin(cells,geomSize,origin, &
character(len=*), intent(in) :: &
fileContent
character(len=:), allocatable :: dataType, headerType
character(len=:), allocatable :: headerType
logical :: inFile, inImage, compressed
integer(pI64) :: &
startPos, endPos

2
src/grid/base64.f90
View File

@ -7,7 +7,7 @@ module base64
use prec
use IO
implicit none
implicit none(type,external)
private
character(len=*), parameter :: &

20
src/grid/discretization_grid.f90
View File

@ -10,6 +10,7 @@ module discretization_grid
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
use MPI_f08
#endif
use FFTW3
use prec
use parallelization
@ -22,7 +23,11 @@ module discretization_grid
use discretization
use geometry_plastic_nonlocal
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
integer, dimension(3), public, protected :: &
@ -50,7 +55,6 @@ subroutine discretization_grid_init(restart)
logical, intent(in) :: restart
include 'fftw3-mpi.f03'
real(pReal), dimension(3) :: &
mySize, & !< domain size of this process
origin !< (global) distance to origin
@ -107,10 +111,8 @@ subroutine discretization_grid_init(restart)
if (worldsize>cells(3)) call IO_error(894, ext_msg='number of processes exceeds cells(3)')
call fftw_mpi_init
devNull = fftw_mpi_local_size_3d(int(cells(3),C_INTPTR_T), &
int(cells(2),C_INTPTR_T), &
int(cells(1),C_INTPTR_T)/2+1, &
call fftw_mpi_init()
devNull = fftw_mpi_local_size_3d(int(cells(3),C_INTPTR_T),int(cells(2),C_INTPTR_T),int(cells(1)/2+1,C_INTPTR_T), &
PETSC_COMM_WORLD, &
z, & ! domain cells size along z
z_offset) ! domain cells offset along z
@ -123,7 +125,7 @@ subroutine discretization_grid_init(restart)
myGrid = [cells(1:2),cells3]
mySize = [geomSize(1:2),size3]
call MPI_Gather(product(cells(1:2))*cells3Offset, 1_MPI_INTEGER_KIND,MPI_INTEGER,displs,&
call MPI_Gather(product(cells(1:2))*cells3Offset,1_MPI_INTEGER_KIND,MPI_INTEGER,displs,&
1_MPI_INTEGER_KIND,MPI_INTEGER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
call MPI_Gather(product(myGrid), 1_MPI_INTEGER_KIND,MPI_INTEGER,sendcounts,&
@ -231,9 +233,9 @@ pure function cellSurfaceArea(geomSize,cells)
real(pReal), dimension(6,1,product(cells)) :: cellSurfaceArea
cellSurfaceArea(1:2,1,:) = geomSize(2)/real(cells(2)) * geomSize(3)/real(cells(3))
cellSurfaceArea(3:4,1,:) = geomSize(3)/real(cells(3)) * geomSize(1)/real(cells(1))
cellSurfaceArea(5:6,1,:) = geomSize(1)/real(cells(1)) * geomSize(2)/real(cells(2))
cellSurfaceArea(1:2,1,:) = geomSize(2)/real(cells(2),pReal) * geomSize(3)/real(cells(3),pReal)
cellSurfaceArea(3:4,1,:) = geomSize(3)/real(cells(3),pReal) * geomSize(1)/real(cells(1),pReal)
cellSurfaceArea(5:6,1,:) = geomSize(1)/real(cells(1),pReal) * geomSize(2)/real(cells(2),pReal)
end function cellSurfaceArea

4
src/grid/grid_damage_spectral.f90
View File

@ -22,7 +22,11 @@ module grid_damage_spectral
use YAML_types
use config
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
type :: tNumerics

41
src/grid/grid_mech_FEM.f90
View File

@ -27,7 +27,12 @@ module grid_mechanical_FEM
use discretization
use discretization_grid
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
type(tSolutionParams) :: params
@ -115,6 +120,8 @@ subroutine grid_mechanical_FEM_init
class(tNode), pointer :: &
num_grid, &
debug_grid
character(len=pStringLen) :: &
extmsg = ''
print'(/,1x,a)', '<<<+- grid_mechanical_FEM init -+>>>'; flush(IO_STDOUT)
@ -134,12 +141,14 @@ subroutine grid_mechanical_FEM_init
num%itmin = num_grid%get_asInt ('itmin',defaultVal=1)
num%itmax = num_grid%get_asInt ('itmax',defaultVal=250)
if (num%eps_div_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_div_atol')
if (num%eps_div_rtol < 0.0_pReal) call IO_error(301,ext_msg='eps_div_rtol')
if (num%eps_stress_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_stress_atol')
if (num%eps_stress_rtol < 0.0_pReal) call IO_error(301,ext_msg='eps_stress_rtol')
if (num%itmax <= 1) call IO_error(301,ext_msg='itmax')
if (num%itmin > num%itmax .or. num%itmin < 1) call IO_error(301,ext_msg='itmin')
if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol'
if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol'
if (num%eps_stress_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_atol'
if (num%eps_stress_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol'
if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax'
if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin'
if (extmsg /= '') call IO_error(301,ext_msg=trim(extmsg))
!--------------------------------------------------------------------------------------------------
! set default and user defined options for PETSc
@ -217,14 +226,14 @@ subroutine grid_mechanical_FEM_init
delta = geomSize/real(cells,pReal) ! grid spacing
detJ = product(delta) ! cell volume
BMat = reshape(real([-1.0_pReal/delta(1),-1.0_pReal/delta(2),-1.0_pReal/delta(3), &
1.0_pReal/delta(1),-1.0_pReal/delta(2),-1.0_pReal/delta(3), &
-1.0_pReal/delta(1), 1.0_pReal/delta(2),-1.0_pReal/delta(3), &
1.0_pReal/delta(1), 1.0_pReal/delta(2),-1.0_pReal/delta(3), &
-1.0_pReal/delta(1),-1.0_pReal/delta(2), 1.0_pReal/delta(3), &
1.0_pReal/delta(1),-1.0_pReal/delta(2), 1.0_pReal/delta(3), &
-1.0_pReal/delta(1), 1.0_pReal/delta(2), 1.0_pReal/delta(3), &
1.0_pReal/delta(1), 1.0_pReal/delta(2), 1.0_pReal/delta(3)],pReal), [3,8])/4.0_pReal ! shape function derivative matrix
BMat = reshape(real([-delta(1)**(-1),-delta(2)**(-1),-delta(3)**(-1), &
delta(1)**(-1),-delta(2)**(-1),-delta(3)**(-1), &
-delta(1)**(-1), delta(2)**(-1),-delta(3)**(-1), &
delta(1)**(-1), delta(2)**(-1),-delta(3)**(-1), &
-delta(1)**(-1),-delta(2)**(-1), delta(3)**(-1), &
delta(1)**(-1),-delta(2)**(-1), delta(3)**(-1), &
-delta(1)**(-1), delta(2)**(-1), delta(3)**(-1), &
delta(1)**(-1), delta(2)**(-1), delta(3)**(-1)],pReal), [3,8])/4.0_pReal ! shape function derivative matrix
HGMat = matmul(transpose(HGcomp),HGcomp) &
* HGCoeff*(delta(1)*delta(2) + delta(2)*delta(3) + delta(3)*delta(1))/16.0_pReal ! hourglass stabilization matrix
@ -652,7 +661,7 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc)
MatNullSpace :: matnull
PetscErrorCode :: err_PETSc
BMatFull = 0.0
BMatFull = 0.0_pReal
BMatFull(1:3,1 :8 ) = BMat
BMatFull(4:6,9 :16) = BMat
BMatFull(7:9,17:24) = BMat
@ -682,7 +691,7 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc)
enddo; enddo; enddo
row = col
ce = ce + 1
K_ele = 0.0
K_ele = 0.0_pReal
K_ele(1 :8 ,1 :8 ) = HGMat*(homogenization_dPdF(1,1,1,1,ce) + &
homogenization_dPdF(2,2,2,2,ce) + &
homogenization_dPdF(3,3,3,3,ce))/3.0_pReal

20
src/grid/grid_mech_spectral_basic.f90
View File

@ -26,7 +26,11 @@ module grid_mechanical_spectral_basic
use homogenization
use discretization_grid
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
type(tSolutionParams) :: params
@ -117,6 +121,8 @@ subroutine grid_mechanical_spectral_basic_init
class (tNode), pointer :: &
num_grid, &
debug_grid
character(len=pStringLen) :: &
extmsg = ''
print'(/,1x,a)', '<<<+- grid_mechanical_spectral_basic init -+>>>'; flush(IO_STDOUT)
@ -143,12 +149,14 @@ subroutine grid_mechanical_spectral_basic_init
num%itmin = num_grid%get_asInt ('itmin',defaultVal=1)
num%itmax = num_grid%get_asInt ('itmax',defaultVal=250)
if (num%eps_div_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_div_atol')
if (num%eps_div_rtol < 0.0_pReal) call IO_error(301,ext_msg='eps_div_rtol')
if (num%eps_stress_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_stress_atol')
if (num%eps_stress_rtol < 0.0_pReal) call IO_error(301,ext_msg='eps_stress_rtol')
if (num%itmax <= 1) call IO_error(301,ext_msg='itmax')
if (num%itmin > num%itmax .or. num%itmin < 1) call IO_error(301,ext_msg='itmin')
if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol'
if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol'
if (num%eps_stress_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_atol'
if (num%eps_stress_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol'
if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax'
if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin'
if (extmsg /= '') call IO_error(301,ext_msg=trim(extmsg))
!--------------------------------------------------------------------------------------------------
! set default and user defined options for PETSc

28
src/grid/grid_mech_spectral_polarisation.f90
View File

@ -26,7 +26,11 @@ module grid_mechanical_spectral_polarisation
use homogenization
use discretization_grid
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
type(tSolutionParams) :: params
@ -130,6 +134,8 @@ subroutine grid_mechanical_spectral_polarisation_init
class (tNode), pointer :: &
num_grid, &
debug_grid
character(len=pStringLen) :: &
extmsg = ''
print'(/,1x,a)', '<<<+- grid_mechanical_spectral_polarization init -+>>>'; flush(IO_STDOUT)
@ -157,16 +163,18 @@ subroutine grid_mechanical_spectral_polarisation_init
num%alpha = num_grid%get_asFloat('alpha', defaultVal=1.0_pReal)
num%beta = num_grid%get_asFloat('beta', defaultVal=1.0_pReal)
if (num%eps_div_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_div_atol')
if (num%eps_div_rtol < 0.0_pReal) call IO_error(301,ext_msg='eps_div_rtol')
if (num%eps_curl_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_curl_atol')
if (num%eps_curl_rtol < 0.0_pReal) call IO_error(301,ext_msg='eps_curl_rtol')
if (num%eps_stress_atol <= 0.0_pReal) call IO_error(301,ext_msg='eps_stress_atol')
if (num%eps_stress_rtol < 0.0_pReal) call IO_error(301,ext_msg='eps_stress_rtol')
if (num%itmax <= 1) call IO_error(301,ext_msg='itmax')
if (num%itmin > num%itmax .or. num%itmin < 1) call IO_error(301,ext_msg='itmin')
if (num%alpha <= 0.0_pReal .or. num%alpha > 2.0_pReal) call IO_error(301,ext_msg='alpha')
if (num%beta < 0.0_pReal .or. num%beta > 2.0_pReal) call IO_error(301,ext_msg='beta')
if (num%eps_div_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_div_atol'
if (num%eps_div_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_div_rtol'
if (num%eps_curl_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_curl_atol'
if (num%eps_curl_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_curl_rtol'
if (num%eps_stress_atol <= 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_atol'
if (num%eps_stress_rtol < 0.0_pReal) extmsg = trim(extmsg)//' eps_stress_rtol'
if (num%itmax <= 1) extmsg = trim(extmsg)//' itmax'
if (num%itmin > num%itmax .or. num%itmin < 1) extmsg = trim(extmsg)//' itmin'
if (num%alpha <= 0.0_pReal .or. num%alpha > 2.0_pReal) extmsg = trim(extmsg)//' alpha'
if (num%beta < 0.0_pReal .or. num%beta > 2.0_pReal) extmsg = trim(extmsg)//' beta'
if (extmsg /= '') call IO_error(301,ext_msg=trim(extmsg))
!--------------------------------------------------------------------------------------------------
! set default and user defined options for PETSc

4
src/grid/grid_thermal_spectral.f90
View File

@ -25,7 +25,11 @@ module grid_thermal_spectral
use YAML_types
use config
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
type :: tNumerics

422
src/grid/spectral_utilities.f90
View File

@ -4,13 +4,12 @@
!> @brief Utilities used by the different spectral solver variants
!--------------------------------------------------------------------------------------------------
module spectral_utilities
use, intrinsic :: iso_c_binding
#include <petsc/finclude/petscsys.h>
use PETScSys
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
use MPI_f08
#endif
use FFTW3
use prec
use CLI
@ -23,30 +22,36 @@ module spectral_utilities
use discretization
use homogenization
implicit none
private
include 'fftw3-mpi.f03'
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
!--------------------------------------------------------------------------------------------------
! grid related information
real(pReal), protected, public :: wgt !< weighting factor 1/Nelems
integer, protected, public :: cells1Red !< cells(1)/2
real(pReal), protected, public, dimension(3) :: scaledGeomSize !< scaled geometry size for calculation of divergence
real(pReal), protected, public :: wgt !< weighting factor 1/Nelems
real(pReal), protected, public, dimension(3) :: scaledGeomSize !< scaled geometry size for calculation of divergence
integer :: &
cells1Red, & !< cells(1)/2+1
cells2, & !< (local) cells in 2nd direction
cells2Offset !< (local) cells offset in 2nd direction
!--------------------------------------------------------------------------------------------------
! variables storing information for spectral method and FFTW
real (C_DOUBLE), public, dimension(:,:,:,:,:), pointer :: tensorField_real !< real representation (some stress or deformation) of field_fourier
complex(C_DOUBLE_COMPLEX),public, dimension(:,:,:,:,:), pointer :: tensorField_fourier !< field on which the Fourier transform operates
real(C_DOUBLE), public, dimension(:,:,:,:), pointer :: vectorField_real !< vector field real representation for fftw
complex(C_DOUBLE_COMPLEX),public, dimension(:,:,:,:), pointer :: vectorField_fourier !< vector field fourier representation for fftw
real(C_DOUBLE), public, dimension(:,:,:), pointer :: scalarField_real !< scalar field real representation for fftw
complex(C_DOUBLE_COMPLEX),public, dimension(:,:,:), pointer :: scalarField_fourier !< scalar field fourier representation for fftw
complex(pReal), dimension(:,:,:,:,:,:,:), allocatable :: gamma_hat !< gamma operator (field) for spectral method
complex(pReal), dimension(:,:,:,:), allocatable :: xi1st !< wave vector field for first derivatives
complex(pReal), dimension(:,:,:,:), allocatable :: xi2nd !< wave vector field for second derivatives
real(pReal), dimension(3,3,3,3) :: C_ref !< mechanic reference stiffness
real(C_DOUBLE), public, dimension(:,:,:,:,:), pointer :: tensorField_real !< tensor field in real space
real(C_DOUBLE), public, dimension(:,:,:,:), pointer :: vectorField_real !< vector field in real space
real(C_DOUBLE), public, dimension(:,:,:), pointer :: scalarField_real !< scalar field in real space
complex(C_DOUBLE_COMPLEX), dimension(:,:,:,:,:), pointer :: tensorField_fourier !< tensor field in Fourier space
complex(C_DOUBLE_COMPLEX), dimension(:,:,:,:), pointer :: vectorField_fourier !< vector field in Fourier space
complex(C_DOUBLE_COMPLEX), dimension(:,:,:), pointer :: scalarField_fourier !< scalar field in Fourier space
complex(pReal), dimension(:,:,:,:,:,:,:), allocatable :: gamma_hat !< gamma operator (field) for spectral method
complex(pReal), dimension(:,:,:,:), allocatable :: xi1st !< wave vector field for first derivatives
complex(pReal), dimension(:,:,:,:), allocatable :: xi2nd !< wave vector field for second derivatives
real(pReal), dimension(3,3,3,3) :: C_ref !< mechanic reference stiffness
!--------------------------------------------------------------------------------------------------
@ -149,20 +154,23 @@ subroutine spectral_utilities_init()
FFTW_planner_flag
integer, dimension(3) :: k_s
type(C_PTR) :: &
tensorField, & !< field containing data for FFTW in real and fourier space (in place)
vectorField, & !< field containing data for FFTW in real space when debugging FFTW (no in place)
scalarField !< field containing data for FFTW in real space when debugging FFTW (no in place)
integer(C_INTPTR_T), dimension(3) :: gridFFTW
integer(C_INTPTR_T) :: alloc_local, local_K, local_K_offset
tensorField, & !< tensor data for FFTW in real and Fourier space (in-place)
vectorField, & !< vector data for FFTW in real and Fourier space (in-place)
scalarField !< scalar data for FFTW in real and Fourier space (in-place)
integer(C_INTPTR_T), dimension(3) :: cellsFFTW
integer(C_INTPTR_T) :: N, &
cells3FFTW, & !< # of cells in 3. dim on current process in real space
cells3_offset, & !< offset for cells in 3. dim on current process in real space
cells2FFTW, & !< # of cells in 2. dim on current process in Fourier space
cells2_offset !< offset for cells in 2. dim on curren process in Fourier space
integer(C_INTPTR_T), parameter :: &
scalarSize = 1_C_INTPTR_T, &
vectorSize = 3_C_INTPTR_T, &
tensorSize = 9_C_INTPTR_T
character(len=*), parameter :: &
PETSCDEBUG = ' -snes_view -snes_monitor '
class(tNode) , pointer :: &
num_grid, &
debug_grid ! pointer to grid debug options
debug_grid ! pointer to grid debug options
print'(/,1x,a)', '<<<+- spectral_utilities init -+>>>'
@ -202,7 +210,7 @@ subroutine spectral_utilities_init()
CHKERRQ(err_PETSc)
cells1Red = cells(1)/2 + 1
wgt = 1.0/real(product(cells),pReal)
wgt = real(product(cells),pReal)**(-1)
num%memory_efficient = num_grid%get_asInt('memory_efficient', defaultVal=1) > 0 ! ToDo: should be logical in YAML file
num%divergence_correction = num_grid%get_asInt('divergence_correction', defaultVal=2)
@ -228,16 +236,16 @@ subroutine spectral_utilities_init()
do j = 1, 3
if (j /= minloc(geomSize,1) .and. j /= maxloc(geomSize,1)) &
scaledGeomSize = geomSize/geomSize(j)
enddo
end do
elseif (num%divergence_correction == 2) then
do j = 1, 3
if ( j /= int(minloc(geomSize/real(cells,pReal),1)) &
.and. j /= int(maxloc(geomSize/real(cells,pReal),1))) &
scaledGeomSize = geomSize/geomSize(j)*real(cells(j),pReal)
enddo
end do
else
scaledGeomSize = geomSize
endif
end if
select case(IO_lc(num_grid%get_asString('fftw_plan_mode',defaultVal='FFTW_MEASURE')))
case('fftw_estimate') ! ordered from slow execution (but fast plan creation) to fast execution
@ -249,7 +257,7 @@ subroutine spectral_utilities_init()
case('fftw_exhaustive')
FFTW_planner_flag = FFTW_EXHAUSTIVE
case default
call IO_warning(warning_ID=47,ext_msg=trim(IO_lc(num_grid%get_asString('fftw_plan_mode'))))
call IO_warning(47,'using default FFTW_MEASURE instead of "'//trim(num_grid%get_asString('fftw_plan_mode'))//'"')
FFTW_planner_flag = FFTW_MEASURE
end select
@ -260,95 +268,108 @@ subroutine spectral_utilities_init()
print'(/,1x,a)', 'FFTW initialized'; flush(IO_STDOUT)
cellsFFTW = int(cells,C_INTPTR_T)
N = fftw_mpi_local_size_many_transposed(3,[cellsFFTW(3),cellsFFTW(2),int(cells1Red,C_INTPTR_T)], &
tensorSize,FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK,PETSC_COMM_WORLD, &
cells3FFTW,cells3_offset,cells2FFTW,cells2_offset)
cells2 = int(cells2FFTW)
cells2Offset = int(cells2_offset)
if (int(cells3FFTW) /= cells3) error stop 'domain decomposition mismatch (tensor, real space)'
tensorField = fftw_alloc_complex(N)
call c_f_pointer(tensorField,tensorField_real, &
[3_C_INTPTR_T,3_C_INTPTR_T,int(cells1Red*2,C_INTPTR_T),cellsFFTW(2),cells3FFTW])
call c_f_pointer(tensorField,tensorField_fourier, &
[3_C_INTPTR_T,3_C_INTPTR_T,int(cells1Red, C_INTPTR_T),cellsFFTW(3),cells2FFTW])
N = fftw_mpi_local_size_many_transposed(3,[cellsFFTW(3),cellsFFTW(2),int(cells1Red,C_INTPTR_T)], &
vectorSize,FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK,PETSC_COMM_WORLD, &
cells3FFTW,cells3_offset,cells2FFTW,cells2_offset)
if (int(cells3FFTW) /= cells3) error stop 'domain decomposition mismatch (vector, real space)'
if (int(cells2FFTW) /= cells2) error stop 'domain decomposition mismatch (vector, Fourier space)'
vectorField = fftw_alloc_complex(N)
call c_f_pointer(vectorField,vectorField_real, &
[3_C_INTPTR_T,int(cells1Red*2,C_INTPTR_T),cellsFFTW(2),cells3FFTW])
call c_f_pointer(vectorField,vectorField_fourier, &
[3_C_INTPTR_T,int(cells1Red, C_INTPTR_T),cellsFFTW(3),cells2FFTW])
N = fftw_mpi_local_size_3d_transposed(cellsFFTW(3),cellsFFTW(2),int(cells1Red,C_INTPTR_T), &
PETSC_COMM_WORLD,cells3FFTW,cells3_offset,cells2FFTW,cells2_offset)
if (int(cells3FFTW) /= cells3) error stop 'domain decomposition mismatch (scalar, real space)'
if (int(cells2FFTW) /= cells2) error stop 'domain decomposition mismatch (scalar, Fourier space)'
scalarField = fftw_alloc_complex(N)
call c_f_pointer(scalarField,scalarField_real, &
[int(cells1Red*2,C_INTPTR_T),cellsFFTW(2),cells3FFTW])
call c_f_pointer(scalarField,scalarField_fourier, &
[int(cells1Red, C_INTPTR_T),cellsFFTW(3),cells2FFTW])
!--------------------------------------------------------------------------------------------------
! MPI allocation
gridFFTW = int(cells,C_INTPTR_T)
alloc_local = fftw_mpi_local_size_3d(gridFFTW(3), gridFFTW(2), gridFFTW(1)/2 +1, &
PETSC_COMM_WORLD, local_K, local_K_offset)
allocate (xi1st (3,cells1Red,cells(2),cells3),source = cmplx(0.0_pReal,0.0_pReal,pReal)) ! frequencies for first derivatives, only half the size for first dimension
allocate (xi2nd (3,cells1Red,cells(2),cells3),source = cmplx(0.0_pReal,0.0_pReal,pReal)) ! frequencies for second derivatives, only half the size for first dimension
tensorField = fftw_alloc_complex(tensorSize*alloc_local)
call c_f_pointer(tensorField, tensorField_real, [3_C_INTPTR_T,3_C_INTPTR_T, &
2_C_INTPTR_T*(gridFFTW(1)/2_C_INTPTR_T + 1_C_INTPTR_T),gridFFTW(2),local_K]) ! place a pointer for a real tensor representation
call c_f_pointer(tensorField, tensorField_fourier, [3_C_INTPTR_T,3_C_INTPTR_T, &
gridFFTW(1)/2_C_INTPTR_T + 1_C_INTPTR_T , gridFFTW(2),local_K]) ! place a pointer for a fourier tensor representation
vectorField = fftw_alloc_complex(vectorSize*alloc_local)
call c_f_pointer(vectorField, vectorField_real, [3_C_INTPTR_T,&
2_C_INTPTR_T*(gridFFTW(1)/2_C_INTPTR_T + 1_C_INTPTR_T),gridFFTW(2),local_K]) ! place a pointer for a real vector representation
call c_f_pointer(vectorField, vectorField_fourier,[3_C_INTPTR_T,&
gridFFTW(1)/2_C_INTPTR_T + 1_C_INTPTR_T, gridFFTW(2),local_K]) ! place a pointer for a fourier vector representation
scalarField = fftw_alloc_complex(scalarSize*alloc_local) ! allocate data for real representation (no in place transform)
call c_f_pointer(scalarField, scalarField_real, &
[2_C_INTPTR_T*(gridFFTW(1)/2_C_INTPTR_T + 1),gridFFTW(2),local_K]) ! place a pointer for a real scalar representation
call c_f_pointer(scalarField, scalarField_fourier, &
[ gridFFTW(1)/2_C_INTPTR_T + 1 ,gridFFTW(2),local_K]) ! place a pointer for a fourier scarlar representation
! allocation
allocate (xi1st (3,cells1Red,cells(3),cells2),source = cmplx(0.0_pReal,0.0_pReal,pReal)) ! frequencies for first derivatives, only half the size for first dimension
allocate (xi2nd (3,cells1Red,cells(3),cells2),source = cmplx(0.0_pReal,0.0_pReal,pReal)) ! frequencies for second derivatives, only half the size for first dimension
!--------------------------------------------------------------------------------------------------
! tensor MPI fftw plans
planTensorForth = fftw_mpi_plan_many_dft_r2c(3,gridFFTW(3:1:-1),tensorSize, &
planTensorForth = fftw_mpi_plan_many_dft_r2c(3,cellsFFTW(3:1:-1),tensorSize, &
FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, &
tensorField_real,tensorField_fourier, &
PETSC_COMM_WORLD,FFTW_planner_flag)
if (.not. c_associated(planTensorForth)) error stop 'FFTW error'
planTensorBack = fftw_mpi_plan_many_dft_c2r(3,gridFFTW(3:1:-1),tensorSize, &
FFTW_MPI_DEFAULT_BLOCK, FFTW_MPI_DEFAULT_BLOCK, &
PETSC_COMM_WORLD,FFTW_planner_flag+FFTW_MPI_TRANSPOSED_OUT)
if (.not. c_associated(planTensorForth)) error stop 'FFTW error r2c tensor'
planTensorBack = fftw_mpi_plan_many_dft_c2r(3,cellsFFTW(3:1:-1),tensorSize, &
FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, &
tensorField_fourier,tensorField_real, &
PETSC_COMM_WORLD, FFTW_planner_flag)
if (.not. c_associated(planTensorBack)) error stop 'FFTW error'
PETSC_COMM_WORLD,FFTW_planner_flag+FFTW_MPI_TRANSPOSED_IN)
if (.not. c_associated(planTensorBack)) error stop 'FFTW error c2r tensor'
!--------------------------------------------------------------------------------------------------
! vector MPI fftw plans
planVectorForth = fftw_mpi_plan_many_dft_r2c(3,gridFFTW(3:1:-1),vectorSize, &
planVectorForth = fftw_mpi_plan_many_dft_r2c(3,cellsFFTW(3:1:-1),vectorSize, &
FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, &
vectorField_real,vectorField_fourier, &
PETSC_COMM_WORLD,FFTW_planner_flag)
if (.not. c_associated(planVectorForth)) error stop 'FFTW error'
planVectorBack = fftw_mpi_plan_many_dft_c2r(3,gridFFTW(3:1:-1),vectorSize, &
FFTW_MPI_DEFAULT_BLOCK, FFTW_MPI_DEFAULT_BLOCK, &
PETSC_COMM_WORLD,FFTW_planner_flag+FFTW_MPI_TRANSPOSED_OUT)
if (.not. c_associated(planVectorForth)) error stop 'FFTW error r2c vector'
planVectorBack = fftw_mpi_plan_many_dft_c2r(3,cellsFFTW(3:1:-1),vectorSize, &
FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, &
vectorField_fourier,vectorField_real, &
PETSC_COMM_WORLD, FFTW_planner_flag)
if (.not. c_associated(planVectorBack)) error stop 'FFTW error'
PETSC_COMM_WORLD,FFTW_planner_flag+FFTW_MPI_TRANSPOSED_IN)
if (.not. c_associated(planVectorBack)) error stop 'FFTW error c2r vector'
!--------------------------------------------------------------------------------------------------
! scalar MPI fftw plans
planScalarForth = fftw_mpi_plan_many_dft_r2c(3,gridFFTW(3:1:-1),scalarSize, &
FFTW_MPI_DEFAULT_BLOCK,FFTW_MPI_DEFAULT_BLOCK, &
scalarField_real,scalarField_fourier, &
PETSC_COMM_WORLD,FFTW_planner_flag)
if (.not. c_associated(planScalarForth)) error stop 'FFTW error'
planScalarBack = fftw_mpi_plan_many_dft_c2r(3,gridFFTW(3:1:-1),scalarSize, &
FFTW_MPI_DEFAULT_BLOCK, FFTW_MPI_DEFAULT_BLOCK, &
scalarField_fourier,scalarField_real, &
PETSC_COMM_WORLD, FFTW_planner_flag)
if (.not. c_associated(planScalarBack)) error stop 'FFTW error'
planScalarForth = fftw_mpi_plan_dft_r2c_3d(cellsFFTW(3),cellsFFTW(2),cellsFFTW(1), &
scalarField_real,scalarField_fourier, &
PETSC_COMM_WORLD,FFTW_planner_flag+FFTW_MPI_TRANSPOSED_OUT)
if (.not. c_associated(planScalarForth)) error stop 'FFTW error r2c scalar'
planScalarBack = fftw_mpi_plan_dft_c2r_3d(cellsFFTW(3),cellsFFTW(2),cellsFFTW(1), &
scalarField_fourier,scalarField_real, &
PETSC_COMM_WORLD,FFTW_planner_flag+FFTW_MPI_TRANSPOSED_IN)
if (.not. c_associated(planScalarBack)) error stop 'FFTW error c2r scalar'
!--------------------------------------------------------------------------------------------------
! calculation of discrete angular frequencies, ordered as in FFTW (wrap around)
do k = cells3Offset+1, cells3Offset+cells3
k_s(3) = k - 1
if (k > cells(3)/2 + 1) k_s(3) = k_s(3) - cells(3) ! running from 0,1,...,N/2,N/2+1,-N/2,-N/2+1,...,-1
do j = 1, cells(2)
k_s(2) = j - 1
if (j > cells(2)/2 + 1) k_s(2) = k_s(2) - cells(2) ! running from 0,1,...,N/2,N/2+1,-N/2,-N/2+1,...,-1
do j = cells2Offset+1, cells2Offset+cells2
k_s(2) = j - 1
if (j > cells(2)/2 + 1) k_s(2) = k_s(2) - cells(2) ! running from 0,1,...,N/2,N/2+1,-N/2,-N/2+1,...,-1
do k = 1, cells(3)
k_s(3) = k - 1
if (k > cells(3)/2 + 1) k_s(3) = k_s(3) - cells(3) ! running from 0,1,...,N/2,N/2+1,-N/2,-N/2+1,...,-1
do i = 1, cells1Red
k_s(1) = i - 1 ! symmetry, junst running from 0,1,...,N/2,N/2+1
xi2nd(1:3,i,j,k-cells3Offset) = utilities_getFreqDerivative(k_s)
xi2nd(1:3,i,k,j-cells2Offset) = utilities_getFreqDerivative(k_s)
where(mod(cells,2)==0 .and. [i,j,k] == cells/2+1 .and. &
spectral_derivative_ID == DERIVATIVE_CONTINUOUS_ID) ! for even grids, set the Nyquist Freq component to 0.0
xi1st(1:3,i,j,k-cells3Offset) = cmplx(0.0_pReal,0.0_pReal,pReal)
xi1st(1:3,i,k,j-cells2Offset) = cmplx(0.0_pReal,0.0_pReal,pReal)
elsewhere
xi1st(1:3,i,j,k-cells3Offset) = xi2nd(1:3,i,j,k-cells3Offset)
xi1st(1:3,i,k,j-cells2Offset) = xi2nd(1:3,i,k,j-cells2Offset)
endwhere
enddo; enddo; enddo
end do; end do; end do
if (num%memory_efficient) then ! allocate just single fourth order tensor
allocate (gamma_hat(3,3,3,3,1,1,1), source = cmplx(0.0_pReal,0.0_pReal,pReal))
else ! precalculation of gamma_hat field
allocate (gamma_hat(3,3,3,3,cells1Red,cells(2),cells3), source = cmplx(0.0_pReal,0.0_pReal,pReal))
endif
allocate (gamma_hat(3,3,3,3,cells1Red,cells(3),cells2), source = cmplx(0.0_pReal,0.0_pReal,pReal))
end if
call selfTest()
@ -376,39 +397,39 @@ subroutine utilities_updateGamma(C)
if (.not. num%memory_efficient) then
gamma_hat = cmplx(0.0_pReal,0.0_pReal,pReal) ! for the singular point and any non invertible A
!$OMP PARALLEL DO PRIVATE(l,m,n,o,temp33_cmplx,xiDyad_cmplx,A,A_inv,err)
do k = cells3Offset+1, cells3Offset+cells3; do j = 1, cells(2); do i = 1, cells1Red
do j = cells2Offset+1, cells2Offset+cells2; do k = 1, cells(3); do i = 1, cells1Red
if (any([i,j,k] /= 1)) then ! singular point at xi=(0.0,0.0,0.0) i.e. i=j=k=1
#ifndef __INTEL_COMPILER
do concurrent(l = 1:3, m = 1:3)
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,j,k-cells3Offset))*xi1st(m,i,j,k-cells3Offset)
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j-cells2Offset))*xi1st(m,i,k,j-cells2Offset)
end do
do concurrent(l = 1:3, m = 1:3)
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal)*xiDyad_cmplx)
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx)
end do
#else
forall(l = 1:3, m = 1:3) &
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,j,k-cells3Offset))*xi1st(m,i,j,k-cells3Offset)
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j-cells2Offset))*xi1st(m,i,k,j-cells2Offset)
forall(l = 1:3, m = 1:3) &
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal)*xiDyad_cmplx)
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx)
#endif
A(1:3,1:3) = temp33_cmplx%re; A(4:6,4:6) = temp33_cmplx%re
A(1:3,4:6) = temp33_cmplx%im; A(4:6,1:3) = -temp33_cmplx%im
if (abs(math_det33(A(1:3,1:3))) > 1e-16) then
if (abs(math_det33(A(1:3,1:3))) > 1.e-16_pReal) then
call math_invert(A_inv, err, A)
temp33_cmplx = cmplx(A_inv(1:3,1:3),A_inv(1:3,4:6),pReal)
#ifndef __INTEL_COMPILER
do concurrent(l=1:3, m=1:3, n=1:3, o=1:3)
gamma_hat(l,m,n,o,i,j,k-cells3Offset) = temp33_cmplx(l,n) * xiDyad_cmplx(o,m)
gamma_hat(l,m,n,o,i,k,j-cells2Offset) = temp33_cmplx(l,n) * xiDyad_cmplx(o,m)
end do
#else
forall(l=1:3, m=1:3, n=1:3, o=1:3) &
gamma_hat(l,m,n,o,i,j,k-cells3Offset) = temp33_cmplx(l,n) * xiDyad_cmplx(o,m)
gamma_hat(l,m,n,o,i,k,j-cells2Offset) = temp33_cmplx(l,n) * xiDyad_cmplx(o,m)
#endif
end if
end if
end do; end do; end do
!$OMP END PARALLEL DO
endif
end if
end subroutine utilities_updateGamma
@ -509,24 +530,24 @@ subroutine utilities_fourierGammaConvolution(fieldAim)
! do the actual spectral method calculation (mechanical equilibrium)
memoryEfficient: if (num%memory_efficient) then
!$OMP PARALLEL DO PRIVATE(l,m,n,o,temp33_cmplx,xiDyad_cmplx,A,A_inv,err,gamma_hat)
do k = 1, cells3; do j = 1, cells(2); do i = 1, cells1Red
if (any([i,j,k+cells3Offset] /= 1)) then ! singular point at xi=(0.0,0.0,0.0) i.e. i=j=k=1
do j = 1, cells2; do k = 1, cells(3); do i = 1, cells1Red
if (any([i,j+cells2Offset,k] /= 1)) then ! singular point at xi=(0.0,0.0,0.0) i.e. i=j=k=1
#ifndef __INTEL_COMPILER
do concurrent(l = 1:3, m = 1:3)
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,j,k))*xi1st(m,i,j,k)
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j))*xi1st(m,i,k,j)
end do
do concurrent(l = 1:3, m = 1:3)
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal)*xiDyad_cmplx)
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx)
end do
#else
forall(l = 1:3, m = 1:3) &
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,j,k))*xi1st(m,i,j,k)
xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,k,j))*xi1st(m,i,k,j)
forall(l = 1:3, m = 1:3) &
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal)*xiDyad_cmplx)
temp33_cmplx(l,m) = sum(cmplx(C_ref(l,1:3,m,1:3),0.0_pReal,pReal)*xiDyad_cmplx)
#endif
A(1:3,1:3) = temp33_cmplx%re; A(4:6,4:6) = temp33_cmplx%re
A(1:3,4:6) = temp33_cmplx%im; A(4:6,1:3) = -temp33_cmplx%im
if (abs(math_det33(A(1:3,1:3))) > 1e-16) then
if (abs(math_det33(A(1:3,1:3))) > 1.e-16_pReal) then
call math_invert(A_inv, err, A)
temp33_cmplx = cmplx(A_inv(1:3,1:3),A_inv(1:3,4:6),pReal)
#ifndef __INTEL_COMPILER
@ -534,33 +555,33 @@ subroutine utilities_fourierGammaConvolution(fieldAim)
gamma_hat(l,m,n,o,1,1,1) = temp33_cmplx(l,n)*xiDyad_cmplx(o,m)
end do
do concurrent(l = 1:3, m = 1:3)
temp33_cmplx(l,m) = sum(gamma_hat(l,m,1:3,1:3,1,1,1)*tensorField_fourier(1:3,1:3,i,j,k))
temp33_cmplx(l,m) = sum(gamma_hat(l,m,1:3,1:3,1,1,1)*tensorField_fourier(1:3,1:3,i,k,j))
end do
#else
forall(l=1:3, m=1:3, n=1:3, o=1:3) &
gamma_hat(l,m,n,o,1,1,1) = temp33_cmplx(l,n)*xiDyad_cmplx(o,m)
forall(l = 1:3, m = 1:3) &
temp33_cmplx(l,m) = sum(gamma_hat(l,m,1:3,1:3,1,1,1)*tensorField_fourier(1:3,1:3,i,j,k))
temp33_cmplx(l,m) = sum(gamma_hat(l,m,1:3,1:3,1,1,1)*tensorField_fourier(1:3,1:3,i,k,j))
#endif
tensorField_fourier(1:3,1:3,i,j,k) = temp33_cmplx
tensorField_fourier(1:3,1:3,i,k,j) = temp33_cmplx
else
tensorField_fourier(1:3,1:3,i,j,k) = cmplx(0.0_pReal,0.0_pReal,pReal)
tensorField_fourier(1:3,1:3,i,k,j) = cmplx(0.0_pReal,0.0_pReal,pReal)
end if
end if
end do; end do; end do
!$OMP END PARALLEL DO
else memoryEfficient
!$OMP PARALLEL DO PRIVATE(l,m,temp33_cmplx)
do k = 1, cells3; do j = 1, cells(2); do i = 1,cells1Red
do j = 1, cells2; do k = 1, cells(3); do i = 1,cells1Red
#ifndef __INTEL_COMPILER
do concurrent(l = 1:3, m = 1:3)
temp33_cmplx(l,m) = sum(gamma_hat(l,m,1:3,1:3,i,j,k)*tensorField_fourier(1:3,1:3,i,j,k))
temp33_cmplx(l,m) = sum(gamma_hat(l,m,1:3,1:3,i,k,j)*tensorField_fourier(1:3,1:3,i,k,j))
end do
#else
forall(l = 1:3, m = 1:3) &
temp33_cmplx(l,m) = sum(gamma_hat(l,m,1:3,1:3,i,j,k)*tensorField_fourier(1:3,1:3,i,j,k))
temp33_cmplx(l,m) = sum(gamma_hat(l,m,1:3,1:3,i,k,j)*tensorField_fourier(1:3,1:3,i,k,j))
#endif
tensorField_fourier(1:3,1:3,i,j,k) = temp33_cmplx
tensorField_fourier(1:3,1:3,i,k,j) = temp33_cmplx
end do; end do; end do
!$OMP END PARALLEL DO
end if memoryEfficient
@ -583,12 +604,12 @@ subroutine utilities_fourierGreenConvolution(D_ref, mu_ref, Delta_t)
!--------------------------------------------------------------------------------------------------
! do the actual spectral method calculation
!$OMP PARALLEL DO PRIVATE(GreenOp_hat)
do k = 1, cells3; do j = 1, cells(2) ;do i = 1, cells1Red
do j = 1, cells2; do k = 1, cells(3); do i = 1, cells1Red
GreenOp_hat = cmplx(1.0_pReal,0.0_pReal,pReal) &
/ (cmplx(mu_ref,0.0_pReal,pReal) + cmplx(Delta_t,0.0_pReal) &
* sum(conjg(xi1st(1:3,i,j,k))* matmul(cmplx(D_ref,0.0_pReal),xi1st(1:3,i,j,k))))
scalarField_fourier(i,j,k) = scalarField_fourier(i,j,k)*GreenOp_hat
enddo; enddo; enddo
/ (cmplx(mu_ref,0.0_pReal,pReal) + cmplx(Delta_t,0.0_pReal,pReal) &
* sum(conjg(xi1st(1:3,i,k,j))* matmul(cmplx(D_ref,0.0_pReal,pReal),xi1st(1:3,i,k,j))))
scalarField_fourier(i,k,j) = scalarField_fourier(i,k,j)*GreenOp_hat
end do; end do; end do
!$OMP END PARALLEL DO
end subroutine utilities_fourierGreenConvolution
@ -603,32 +624,33 @@ real(pReal) function utilities_divergenceRMS()
integer(MPI_INTEGER_KIND) :: err_MPI
complex(pReal), dimension(3) :: rescaledGeom
print'(/,1x,a)', '... calculating divergence ................................................'
flush(IO_STDOUT)
rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pReal)
rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pReal,pReal)
!--------------------------------------------------------------------------------------------------
! calculating RMS divergence criterion in Fourier space
utilities_divergenceRMS = 0.0_pReal
do k = 1, cells3; do j = 1, cells(2)
do j = 1, cells2; do k = 1, cells(3)
do i = 2, cells1Red -1 ! Has somewhere a conj. complex counterpart. Therefore count it twice.
utilities_divergenceRMS = utilities_divergenceRMS &
+ 2.0_pReal*(sum (real(matmul(tensorField_fourier(1:3,1:3,i,j,k), & ! (sqrt(real(a)**2 + aimag(a)**2))**2 = real(a)**2 + aimag(a)**2, i.e. do not take square root and square again
conjg(-xi1st(1:3,i,j,k))*rescaledGeom))**2) & ! --> sum squared L_2 norm of vector
+sum(aimag(matmul(tensorField_fourier(1:3,1:3,i,j,k),&
conjg(-xi1st(1:3,i,j,k))*rescaledGeom))**2))
enddo
+ 2.0_pReal*(sum (real(matmul(tensorField_fourier(1:3,1:3,i,k,j), & ! (sqrt(real(a)**2 + aimag(a)**2))**2 = real(a)**2 + aimag(a)**2, i.e. do not take square root and square again
conjg(-xi1st(1:3,i,k,j))*rescaledGeom))**2) & ! --> sum squared L_2 norm of vector
+sum(aimag(matmul(tensorField_fourier(1:3,1:3,i,k,j),&
conjg(-xi1st(1:3,i,k,j))*rescaledGeom))**2))
end do
utilities_divergenceRMS = utilities_divergenceRMS & ! these two layers (DC and Nyquist) do not have a conjugate complex counterpart (if cells(1) /= 1)
+ sum( real(matmul(tensorField_fourier(1:3,1:3,1 ,j,k), &
conjg(-xi1st(1:3,1,j,k))*rescaledGeom))**2) &
+ sum(aimag(matmul(tensorField_fourier(1:3,1:3,1 ,j,k), &
conjg(-xi1st(1:3,1,j,k))*rescaledGeom))**2) &
+ sum( real(matmul(tensorField_fourier(1:3,1:3,cells1Red,j,k), &
conjg(-xi1st(1:3,cells1Red,j,k))*rescaledGeom))**2) &
+ sum(aimag(matmul(tensorField_fourier(1:3,1:3,cells1Red,j,k), &
conjg(-xi1st(1:3,cells1Red,j,k))*rescaledGeom))**2)
enddo; enddo
+ sum( real(matmul(tensorField_fourier(1:3,1:3,1 ,k,j), &
conjg(-xi1st(1:3,1,k,j))*rescaledGeom))**2) &
+ sum(aimag(matmul(tensorField_fourier(1:3,1:3,1 ,k,j), &
conjg(-xi1st(1:3,1,k,j))*rescaledGeom))**2) &
+ sum( real(matmul(tensorField_fourier(1:3,1:3,cells1Red,k,j), &
conjg(-xi1st(1:3,cells1Red,k,j))*rescaledGeom))**2) &
+ sum(aimag(matmul(tensorField_fourier(1:3,1:3,cells1Red,k,j), &
conjg(-xi1st(1:3,cells1Red,k,j))*rescaledGeom))**2)
end do; end do
if (cells(1) == 1) utilities_divergenceRMS = utilities_divergenceRMS * 0.5_pReal ! counted twice in case of cells(1) == 1
call MPI_Allreduce(MPI_IN_PLACE,utilities_divergenceRMS,1_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
@ -650,46 +672,46 @@ real(pReal) function utilities_curlRMS()
print'(/,1x,a)', '... calculating curl ......................................................'
flush(IO_STDOUT)
rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pReal)
rescaledGeom = cmplx(geomSize/scaledGeomSize,0.0_pReal,pReal)
!--------------------------------------------------------------------------------------------------
! calculating max curl criterion in Fourier space
utilities_curlRMS = 0.0_pReal
do k = 1, cells3; do j = 1, cells(2);
do j = 1, cells2; do k = 1, cells(3);
do i = 2, cells1Red - 1
do l = 1, 3
curl_fourier(l,1) = (+tensorField_fourier(l,3,i,j,k)*xi1st(2,i,j,k)*rescaledGeom(2) &
-tensorField_fourier(l,2,i,j,k)*xi1st(3,i,j,k)*rescaledGeom(3))
curl_fourier(l,2) = (+tensorField_fourier(l,1,i,j,k)*xi1st(3,i,j,k)*rescaledGeom(3) &
-tensorField_fourier(l,3,i,j,k)*xi1st(1,i,j,k)*rescaledGeom(1))
curl_fourier(l,3) = (+tensorField_fourier(l,2,i,j,k)*xi1st(1,i,j,k)*rescaledGeom(1) &
-tensorField_fourier(l,1,i,j,k)*xi1st(2,i,j,k)*rescaledGeom(2))
enddo
curl_fourier(l,1) = (+tensorField_fourier(l,3,i,k,j)*xi1st(2,i,k,j)*rescaledGeom(2) &
-tensorField_fourier(l,2,i,k,j)*xi1st(3,i,k,j)*rescaledGeom(3))
curl_fourier(l,2) = (+tensorField_fourier(l,1,i,k,j)*xi1st(3,i,k,j)*rescaledGeom(3) &
-tensorField_fourier(l,3,i,k,j)*xi1st(1,i,k,j)*rescaledGeom(1))
curl_fourier(l,3) = (+tensorField_fourier(l,2,i,k,j)*xi1st(1,i,k,j)*rescaledGeom(1) &
-tensorField_fourier(l,1,i,k,j)*xi1st(2,i,k,j)*rescaledGeom(2))
end do
utilities_curlRMS = utilities_curlRMS &
+2.0_pReal*sum(curl_fourier%re**2+curl_fourier%im**2) ! Has somewhere a conj. complex counterpart. Therefore count it twice.
enddo
end do
do l = 1, 3
curl_fourier = (+tensorField_fourier(l,3,1,j,k)*xi1st(2,1,j,k)*rescaledGeom(2) &
-tensorField_fourier(l,2,1,j,k)*xi1st(3,1,j,k)*rescaledGeom(3))
curl_fourier = (+tensorField_fourier(l,1,1,j,k)*xi1st(3,1,j,k)*rescaledGeom(3) &
-tensorField_fourier(l,3,1,j,k)*xi1st(1,1,j,k)*rescaledGeom(1))
curl_fourier = (+tensorField_fourier(l,2,1,j,k)*xi1st(1,1,j,k)*rescaledGeom(1) &
-tensorField_fourier(l,1,1,j,k)*xi1st(2,1,j,k)*rescaledGeom(2))
enddo
curl_fourier = (+tensorField_fourier(l,3,1,k,j)*xi1st(2,1,k,j)*rescaledGeom(2) &
-tensorField_fourier(l,2,1,k,j)*xi1st(3,1,k,j)*rescaledGeom(3))
curl_fourier = (+tensorField_fourier(l,1,1,k,j)*xi1st(3,1,k,j)*rescaledGeom(3) &
-tensorField_fourier(l,3,1,k,j)*xi1st(1,1,k,j)*rescaledGeom(1))
curl_fourier = (+tensorField_fourier(l,2,1,k,j)*xi1st(1,1,k,j)*rescaledGeom(1) &
-tensorField_fourier(l,1,1,k,j)*xi1st(2,1,k,j)*rescaledGeom(2))
end do
utilities_curlRMS = utilities_curlRMS &
+ sum(curl_fourier%re**2 + curl_fourier%im**2) ! this layer (DC) does not have a conjugate complex counterpart (if cells(1) /= 1)
do l = 1, 3
curl_fourier = (+tensorField_fourier(l,3,cells1Red,j,k)*xi1st(2,cells1Red,j,k)*rescaledGeom(2) &
-tensorField_fourier(l,2,cells1Red,j,k)*xi1st(3,cells1Red,j,k)*rescaledGeom(3))
curl_fourier = (+tensorField_fourier(l,1,cells1Red,j,k)*xi1st(3,cells1Red,j,k)*rescaledGeom(3) &
-tensorField_fourier(l,3,cells1Red,j,k)*xi1st(1,cells1Red,j,k)*rescaledGeom(1))
curl_fourier = (+tensorField_fourier(l,2,cells1Red,j,k)*xi1st(1,cells1Red,j,k)*rescaledGeom(1) &
-tensorField_fourier(l,1,cells1Red,j,k)*xi1st(2,cells1Red,j,k)*rescaledGeom(2))
enddo
curl_fourier = (+tensorField_fourier(l,3,cells1Red,k,j)*xi1st(2,cells1Red,k,j)*rescaledGeom(2) &
-tensorField_fourier(l,2,cells1Red,k,j)*xi1st(3,cells1Red,k,j)*rescaledGeom(3))
curl_fourier = (+tensorField_fourier(l,1,cells1Red,k,j)*xi1st(3,cells1Red,k,j)*rescaledGeom(3) &
-tensorField_fourier(l,3,cells1Red,k,j)*xi1st(1,cells1Red,k,j)*rescaledGeom(1))
curl_fourier = (+tensorField_fourier(l,2,cells1Red,k,j)*xi1st(1,cells1Red,k,j)*rescaledGeom(1) &
-tensorField_fourier(l,1,cells1Red,k,j)*xi1st(2,cells1Red,k,j)*rescaledGeom(2))
end do
utilities_curlRMS = utilities_curlRMS &
+ sum(curl_fourier%re**2 + curl_fourier%im**2) ! this layer (Nyquist) does not have a conjugate complex counterpart (if cells(1) /= 1)
enddo; enddo
end do; end do
call MPI_Allreduce(MPI_IN_PLACE,utilities_curlRMS,1_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
@ -731,11 +753,11 @@ function utilities_maskedCompliance(rot_BC,mask_stress,C)
print'(/,1x,a,/,8(9(2x,f12.7,1x)/),9(2x,f12.7,1x))', &
'Stiffness C (load) / GPa =', transpose(temp99_Real)*1.0e-9_pReal
flush(IO_STDOUT)
endif
end if
do i = 1,9; do j = 1,9
mask(i,j) = mask_stressVector(i) .and. mask_stressVector(j)
enddo; enddo
end do; end do
c_reduced = reshape(pack(temp99_Real,mask),[size_reduced,size_reduced])
allocate(s_reduced,mold = c_reduced)
@ -752,11 +774,11 @@ function utilities_maskedCompliance(rot_BC,mask_stress,C)
print trim(formatString), 'C * S (load) ', transpose(matmul(c_reduced,s_reduced))
print trim(formatString), 'S (load) ', transpose(s_reduced)
if (errmatinv) error stop 'matrix inversion error'
endif
end if
temp99_real = reshape(unpack(reshape(s_reduced,[size_reduced**2]),reshape(mask,[81]),0.0_pReal),[9,9])
else
temp99_real = 0.0_pReal
endif
end if
utilities_maskedCompliance = math_99to3333(temp99_Real)
@ -764,7 +786,7 @@ function utilities_maskedCompliance(rot_BC,mask_stress,C)
print'(/,1x,a,/,9(9(2x,f10.5,1x)/),9(2x,f10.5,1x))', &
'Masked Compliance (load) * GPa =', transpose(temp99_Real)*1.0e9_pReal
flush(IO_STDOUT)
endif
end if
end function utilities_maskedCompliance
@ -777,8 +799,8 @@ subroutine utilities_fourierScalarGradient()
integer :: i, j, k
do k = 1, cells3; do j = 1, cells(2); do i = 1,cells1Red
vectorField_fourier(1:3,i,j,k) = scalarField_fourier(i,j,k)*xi1st(1:3,i,j,k) ! ToDo: no -conjg?
do j = 1, cells2; do k = 1, cells(3); do i = 1,cells1Red
vectorField_fourier(1:3,i,k,j) = scalarField_fourier(i,k,j)*xi1st(1:3,i,k,j) ! ToDo: no -conjg?
end do; end do; end do
end subroutine utilities_fourierScalarGradient
@ -789,8 +811,7 @@ end subroutine utilities_fourierScalarGradient
!--------------------------------------------------------------------------------------------------
subroutine utilities_fourierVectorDivergence()
scalarField_fourier(1:cells1Red,1:cells(2),1:cells3) = sum(vectorField_fourier(1:3,1:cells1Red,1:cells(2),1:cells3) &
scalarField_fourier(1:cells1Red,1:cells(3),1:cells2) = sum(vectorField_fourier(1:3,1:cells1Red,1:cells(3),1:cells2) &
*conjg(-xi1st),1)
end subroutine utilities_fourierVectorDivergence
@ -803,10 +824,9 @@ subroutine utilities_fourierVectorGradient()
integer :: i, j, k, m, n
do k = 1, cells3; do j = 1, cells(2); do i = 1,cells1Red
do j = 1, cells2; do k = 1, cells(3); do i = 1,cells1Red
do m = 1, 3; do n = 1, 3
tensorField_fourier(m,n,i,j,k) = vectorField_fourier(m,i,j,k)*xi1st(n,i,j,k)
tensorField_fourier(m,n,i,k,j) = vectorField_fourier(m,i,k,j)*xi1st(n,i,k,j)
end do; end do
end do; end do; end do
@ -820,9 +840,8 @@ subroutine utilities_fourierTensorDivergence()
integer :: i, j, k
do k = 1, cells3; do j = 1, cells(2); do i = 1,cells1Red
vectorField_fourier(:,i,j,k) = matmul(tensorField_fourier(:,:,i,j,k),conjg(-xi1st(:,i,j,k)))
do j = 1, cells2; do k = 1, cells(3); do i = 1,cells1Red
vectorField_fourier(:,i,k,j) = matmul(tensorField_fourier(:,:,i,k,j),conjg(-xi1st(:,i,k,j)))
end do; end do; end do
end subroutine utilities_fourierTensorDivergence
@ -878,12 +897,12 @@ subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,&
if (dPdF_norm_max < sum(homogenization_dPdF(1:3,1:3,1:3,1:3,i)**2)) then
dPdF_max = homogenization_dPdF(1:3,1:3,1:3,1:3,i)
dPdF_norm_max = sum(homogenization_dPdF(1:3,1:3,1:3,1:3,i)**2)
endif
end if
if (dPdF_norm_min > sum(homogenization_dPdF(1:3,1:3,1:3,1:3,i)**2)) then
dPdF_min = homogenization_dPdF(1:3,1:3,1:3,1:3,i)
dPdF_norm_min = sum(homogenization_dPdF(1:3,1:3,1:3,1:3,i)**2)
endif
enddo
end if
end do
valueAndRank = [dPdF_norm_max,real(worldrank,pReal)]
call MPI_Allreduce(MPI_IN_PLACE,valueAndRank,1_MPI_INTEGER_KIND,MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,err_MPI)
@ -946,20 +965,22 @@ function utilities_forwardField(Delta_t,field_lastInc,rate,aim)
rate !< rate by which to forward
real(pReal), intent(in), optional, dimension(3,3) :: &
aim !< average field value aim
real(pReal), dimension(3,3,cells(1),cells(2),cells3) :: &
utilities_forwardField
real(pReal), dimension(3,3) :: fieldDiff !< <a + adot*t> - aim
real(pReal), dimension(3,3) :: fieldDiff !< <a + adot*t> - aim
integer(MPI_INTEGER_KIND) :: err_MPI
utilities_forwardField = field_lastInc + rate*Delta_t
if (present(aim)) then !< correct to match average
fieldDiff = sum(sum(sum(utilities_forwardField,dim=5),dim=4),dim=3)*wgt
call MPI_Allreduce(MPI_IN_PLACE,fieldDiff,9_MPI_INTEGER_KIND,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
fieldDiff = fieldDiff - aim
utilities_forwardField = utilities_forwardField - &
spread(spread(spread(fieldDiff,3,cells(1)),4,cells(2)),5,cells3)
endif
utilities_forwardField = utilities_forwardField &
- spread(spread(spread(fieldDiff,3,cells(1)),4,cells(2)),5,cells3)
end if
end function utilities_forwardField
@ -972,8 +993,10 @@ end function utilities_forwardField
pure function utilities_getFreqDerivative(k_s)
integer, intent(in), dimension(3) :: k_s !< indices of frequency
complex(pReal), dimension(3) :: utilities_getFreqDerivative
select case (spectral_derivative_ID)
case (DERIVATIVE_CONTINUOUS_ID)
utilities_getFreqDerivative = cmplx(0.0_pReal, TAU*real(k_s,pReal)/geomSize,pReal)
@ -1059,12 +1082,12 @@ subroutine utilities_updateCoords(F)
call utilities_FFTtensorForward()
!$OMP PARALLEL DO
do k = 1, cells3; do j = 1, cells(2); do i = 1, cells1Red
if (any([i,j,k+cells3Offset] /= 1)) then
vectorField_fourier(1:3,i,j,k) = matmul(tensorField_fourier(1:3,1:3,i,j,k),xi2nd(1:3,i,j,k)) &
/ sum(conjg(-xi2nd(1:3,i,j,k))*xi2nd(1:3,i,j,k)) * cmplx(wgt,0.0,pReal)
do j = 1, cells2; do k = 1, cells(3); do i = 1, cells1Red
if (any([i,j+cells2Offset,k] /= 1)) then
vectorField_fourier(1:3,i,k,j) = matmul(tensorField_fourier(1:3,1:3,i,k,j),xi2nd(1:3,i,k,j)) &
/ sum(conjg(-xi2nd(1:3,i,k,j))*xi2nd(1:3,i,k,j)) * cmplx(wgt,0.0,pReal)
else
vectorField_fourier(1:3,i,j,k) = cmplx(0.0,0.0,pReal)
vectorField_fourier(1:3,i,k,j) = cmplx(0.0,0.0,pReal)
end if
end do; end do; end do
!$OMP END PARALLEL DO
@ -1073,7 +1096,7 @@ subroutine utilities_updateCoords(F)
!--------------------------------------------------------------------------------------------------
! average F
if (cells3Offset == 0) Favg = real(tensorField_fourier(1:3,1:3,1,1,1),pReal)*wgt
if (cells3Offset == 0) Favg = tensorField_fourier(1:3,1:3,1,1,1)%re*wgt
call MPI_Bcast(Favg,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
@ -1107,21 +1130,21 @@ subroutine utilities_updateCoords(F)
!--------------------------------------------------------------------------------------------------
! calculate nodal displacements
nodeCoords = 0.0_pReal
do k = 0,cells3; do j = 0,cells(2); do i = 0,cells(1)
do j = 0,cells(2); do k = 0,cells3; do i = 0,cells(1)
nodeCoords(1:3,i+1,j+1,k+1) = matmul(Favg,step*(real([i,j,k+cells3Offset],pReal)))
averageFluct: do n = 1,8
me = [i+neighbor(1,n),j+neighbor(2,n),k+neighbor(3,n)]
nodeCoords(1:3,i+1,j+1,k+1) = nodeCoords(1:3,i+1,j+1,k+1) &
+ IPfluct_padded(1:3,modulo(me(1)-1,cells(1))+1,modulo(me(2)-1,cells(2))+1,me(3)+1)*0.125_pReal
enddo averageFluct
enddo; enddo; enddo
end do averageFluct
end do; end do; end do
!--------------------------------------------------------------------------------------------------
! calculate cell center displacements
do k = 1,cells3; do j = 1,cells(2); do i = 1,cells(1)
IPcoords(1:3,i,j,k) = vectorField_real(1:3,i,j,k) &
+ matmul(Favg,step*(real([i,j,k+cells3Offset],pReal)-0.5_pReal))
enddo; enddo; enddo
end do; end do; end do
call discretization_setNodeCoords(reshape(NodeCoords,[3,(cells(1)+1)*(cells(2)+1)*(cells3+1)]))
call discretization_setIPcoords (reshape(IPcoords, [3,cells(1)*cells(2)*cells3]))
@ -1137,6 +1160,7 @@ subroutine utilities_saveReferenceStiffness
integer :: &
fileUnit,ierr
if (worldrank == 0) then
print'(/,1x,a)', '... writing reference stiffness data required for restart to file .........'; flush(IO_STDOUT)
open(newunit=fileUnit, file=getSolverJobName()//'.C_ref',&
@ -1144,7 +1168,7 @@ subroutine utilities_saveReferenceStiffness
if (ierr /=0) call IO_error(100,ext_msg='could not open file '//getSolverJobName()//'.C_ref')
write(fileUnit) C_ref
close(fileUnit)
endif
end if
end subroutine utilities_saveReferenceStiffness
@ -1163,6 +1187,10 @@ subroutine selfTest()
tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
tensorField_real_ = tensorField_real
call utilities_FFTtensorForward()
if (worldsize==1) then
if (any(dNeq(sum(sum(sum(tensorField_real_,dim=5),dim=4),dim=3)/tensorField_fourier(:,:,1,1,1)%re,1.0_pReal,1.0e-12_pReal))) &
error stop 'tensorField avg'
endif
call utilities_FFTtensorBackward()
tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
if (maxval(abs(tensorField_real_ - tensorField_real))>5.0e-15_pReal) error stop 'tensorField'
@ -1171,6 +1199,10 @@ subroutine selfTest()
vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
vectorField_real_ = vectorField_real
call utilities_FFTvectorForward()
if (worldsize==1) then
if (any(dNeq(sum(sum(sum(vectorField_real_,dim=4),dim=3),dim=2)/vectorField_fourier(:,1,1,1)%re,1.0_pReal,1.0e-12_pReal))) &
error stop 'vector avg'
endif
call utilities_FFTvectorBackward()
vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
if (maxval(abs(vectorField_real_ - vectorField_real))>5.0e-15_pReal) error stop 'vectorField'
@ -1179,6 +1211,10 @@ subroutine selfTest()
scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
scalarField_real_ = scalarField_real
call utilities_FFTscalarForward()
if (worldsize==1) then
if (dNeq(sum(sum(sum(scalarField_real_,dim=3),dim=2),dim=1)/scalarField_fourier(1,1,1)%re,1.0_pReal,1.0e-12_pReal)) &
error stop 'scalar avg'
endif
call utilities_FFTscalarBackward()
scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
if (maxval(abs(scalarField_real_ - scalarField_real))>5.0e-15_pReal) error stop 'scalarField'

18
src/grid/zlib.f90
View File

@ -5,7 +5,7 @@
module zlib
use prec
implicit none
implicit none(type,external)
private
public :: &
@ -13,15 +13,14 @@ module zlib
interface
subroutine inflate_C(s_deflated,s_inflated,deflated,inflated) bind(C)
use, intrinsic :: ISO_C_Binding, only: &
C_SIGNED_CHAR, C_INT64_T
subroutine inflate_C(s_deflated,s_inflated,deflated,inflated) bind(C)
use, intrinsic :: ISO_C_Binding, only: C_SIGNED_CHAR, C_INT64_T
implicit none(type,external)
integer(C_INT64_T), intent(in) :: s_deflated,s_inflated
integer(C_SIGNED_CHAR), dimension(s_deflated), intent(in) :: deflated
integer(C_SIGNED_CHAR), dimension(s_inflated), intent(out) :: inflated
end subroutine inflate_C
integer(C_INT64_T), intent(in) :: s_deflated,s_inflated
integer(C_SIGNED_CHAR), dimension(s_deflated), intent(in) :: deflated
integer(C_SIGNED_CHAR), dimension(s_inflated), intent(out) :: inflated
end subroutine inflate_C
end interface
@ -37,6 +36,7 @@ function zlib_inflate(deflated,size_inflated)
integer(C_SIGNED_CHAR), dimension(size_inflated) :: zlib_inflate
call inflate_C(size(deflated,kind=C_INT64_T),int(size_inflated,C_INT64_T),deflated,zlib_inflate)
end function zlib_inflate

16
src/homogenization.f90
View File

@ -18,7 +18,7 @@ module homogenization
use results
use lattice
implicit none
implicit none(type,external)
private
type :: tState
@ -365,7 +365,7 @@ subroutine homogenization_results
call thermal_results(ho,group)
end if
enddo
end do
end subroutine homogenization_results
@ -383,7 +383,7 @@ subroutine homogenization_forward
homogState (ho)%state0 = homogState (ho)%state
if(damageState_h(ho)%sizeState > 0) &
damageState_h(ho)%state0 = damageState_h(ho)%state
enddo
end do
end subroutine homogenization_forward
@ -408,7 +408,7 @@ subroutine homogenization_restartWrite(fileHandle)
call HDF5_closeGroup(groupHandle(2))
enddo
end do
call HDF5_closeGroup(groupHandle(1))
@ -435,7 +435,7 @@ subroutine homogenization_restartRead(fileHandle)
call HDF5_closeGroup(groupHandle(2))
enddo
end do
call HDF5_closeGroup(groupHandle(1))
@ -476,7 +476,7 @@ subroutine parseHomogenization
case default
call IO_error(500,ext_msg=homogThermal%get_asString('type'))
end select
endif
end if
if (homog%contains('damage')) then
homogDamage => homog%get('damage')
@ -486,8 +486,8 @@ subroutine parseHomogenization
case default
call IO_error(500,ext_msg=homogDamage%get_asString('type'))
end select
endif
enddo
end if
end do
end subroutine parseHomogenization

24
src/homogenization_damage.f90
View File

@ -3,8 +3,6 @@
!--------------------------------------------------------------------------------------------------
submodule(homogenization) damage
use lattice
interface
module subroutine pass_init
@ -65,9 +63,9 @@ module subroutine damage_init()
allocate(damageState_h(ho)%state (1,Nmembers), source=1.0_pReal)
else
prm%output = emptyStringArray
endif
end if
end associate
enddo
end do
call pass_init()
@ -79,8 +77,9 @@ end subroutine damage_init
!--------------------------------------------------------------------------------------------------
module subroutine damage_partition(ce)
integer, intent(in) :: ce
real(pReal) :: phi
integer, intent(in) :: ce
if(damageState_h(material_homogenizationID(ce))%sizeState < 1) return
@ -91,7 +90,7 @@ end subroutine damage_partition
!--------------------------------------------------------------------------------------------------
!> @brief Homogenized damage viscosity.
!> @brief Homogenize damage viscosity.
!--------------------------------------------------------------------------------------------------
module function homogenization_mu_phi(ce) result(mu)
@ -105,7 +104,7 @@ end function homogenization_mu_phi
!--------------------------------------------------------------------------------------------------
!> @brief Homogenized damage conductivity/diffusivity in reference configuration.
!> @brief Homogenize damage conductivity.
!--------------------------------------------------------------------------------------------------
module function homogenization_K_phi(ce) result(K)
@ -119,13 +118,12 @@ end function homogenization_K_phi
!--------------------------------------------------------------------------------------------------
!> @brief Homogenized damage driving force.
!> @brief Homogenize damage driving force.
!--------------------------------------------------------------------------------------------------
module function homogenization_f_phi(phi,ce) result(f)
integer, intent(in) :: ce
real(pReal), intent(in) :: &
phi
real(pReal), intent(in) :: phi
real(pReal) :: f
@ -140,8 +138,7 @@ end function homogenization_f_phi
module subroutine homogenization_set_phi(phi,ce)
integer, intent(in) :: ce
real(pReal), intent(in) :: &
phi
real(pReal), intent(in) :: phi
integer :: &
ho, &
@ -166,6 +163,7 @@ module subroutine damage_results(ho,group)
integer :: o
associate(prm => param(ho))
outputsLoop: do o = 1,size(prm%output)
select case(prm%output(o))
@ -173,7 +171,7 @@ module subroutine damage_results(ho,group)
call results_writeDataset(damagestate_h(ho)%state(1,:),group,prm%output(o),&
'damage indicator','-')
end select
enddo outputsLoop
end do outputsLoop
end associate
end subroutine damage_results

8
src/homogenization_mechanical_RGC.f90
View File

@ -561,7 +561,7 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
*cosh(prm%c_alpha*nDefNorm) &
*0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_LeviCivita(k,l,j) &
*tanh(nDefNorm/num%xSmoo)
end do; end do;enddo; end do
end do; end do;end do; end do
end do interfaceLoop
@ -601,9 +601,9 @@ module function RGC_updateState(P,F,avgF,dt,dPdF,ce) result(doneAndHappy)
! calculate the stress and penalty due to volume discrepancy
vPen = 0.0_pReal
do i = 1,nGrain
vPen(:,:,i) = -1.0_pReal/real(nGrain,pReal)*num%volDiscrMod*num%volDiscrPow/num%maxVolDiscr* &
sign((abs(vDiscrep)/num%maxVolDiscr)**(num%volDiscrPow - 1.0),vDiscrep)* &
gVol(i)*transpose(math_inv33(fDef(:,:,i)))
vPen(:,:,i) = -real(nGrain,pReal)**(-1)*num%volDiscrMod*num%volDiscrPow/num%maxVolDiscr &
* sign((abs(vDiscrep)/num%maxVolDiscr)**(num%volDiscrPow - 1.0_pReal),vDiscrep) &
* gVol(i)*transpose(math_inv33(fDef(:,:,i)))
end do
end subroutine volumePenalty

13
src/homogenization_thermal.f90
View File

@ -3,8 +3,6 @@
!--------------------------------------------------------------------------------------------------
submodule(homogenization) thermal
use lattice
interface
module subroutine pass_init
@ -89,7 +87,7 @@ end subroutine thermal_init
!--------------------------------------------------------------------------------------------------
module subroutine thermal_partition(ce)
integer, intent(in) :: ce
integer, intent(in) :: ce
real(pReal) :: T, dot_T
integer :: co
@ -105,7 +103,7 @@ end subroutine thermal_partition
!--------------------------------------------------------------------------------------------------
!> @brief Homogenized thermal viscosity.
!> @brief Homogenize thermal viscosity.
!--------------------------------------------------------------------------------------------------
module function homogenization_mu_T(ce) result(mu)
@ -124,7 +122,7 @@ end function homogenization_mu_T
!--------------------------------------------------------------------------------------------------
!> @brief Homogenized thermal conductivity in reference configuration.
!> @brief Homogenize thermal conductivity.
!--------------------------------------------------------------------------------------------------
module function homogenization_K_T(ce) result(K)
@ -143,7 +141,7 @@ end function homogenization_K_T
!--------------------------------------------------------------------------------------------------
!> @brief Homogenized heat generation rate.
!> @brief Homogenize heat generation rate.
!--------------------------------------------------------------------------------------------------
module function homogenization_f_T(ce) result(f)
@ -167,7 +165,7 @@ end function homogenization_f_T
module subroutine homogenization_thermal_setField(T,dot_T, ce)
integer, intent(in) :: ce
real(pReal), intent(in) :: T, dot_T
real(pReal), intent(in) :: T, dot_T
current(material_homogenizationID(ce))%T(material_homogenizationEntry(ce)) = T
@ -187,6 +185,7 @@ module subroutine thermal_results(ho,group)
integer :: o
associate(prm => param(ho))
outputsLoop: do o = 1,size(prm%output)
select case(trim(prm%output(o)))

68
src/lattice.f90
View File

@ -13,7 +13,7 @@ module lattice
use math
use rotations
implicit none
implicit none(type,external)
private
!--------------------------------------------------------------------------------------------------
@ -484,8 +484,8 @@ function lattice_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character
case default
call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(lattice))
end select
enddo mySystems
enddo myFamilies
end do mySystems
end do myFamilies
end function lattice_characteristicShear_Twin
@ -523,7 +523,7 @@ function lattice_C66_twin(Ntwin,C66,lattice,CoverA)
do i = 1, sum(Ntwin)
call R%fromAxisAngle([coordinateSystem(1:3,2,i),PI],P=1) ! ToDo: Why always 180 deg?
lattice_C66_twin(1:6,1:6,i) = R%rotStiffness(C66)
enddo
end do
end function lattice_C66_twin
@ -572,19 +572,19 @@ function lattice_C66_trans(Ntrans,C_parent66,lattice_target, &
C_target_unrotated66 = C_parent66
else
call IO_error(137,ext_msg='lattice_C66_trans : '//trim(lattice_target))
endif
end if
do i = 1,6
if (abs(C_target_unrotated66(i,i))<tol_math_check) &
call IO_error(135,el=i,ext_msg='matrix diagonal "el"ement in transformation')
enddo
call IO_error(135,'matrix diagonal in transformation',label1='entry',ID1=i)
end do
call buildTransformationSystem(Q,S,Ntrans,cOverA_trans,a_cF,a_cI)
do i = 1,sum(Ntrans)
call R%fromMatrix(Q(1:3,1:3,i))
lattice_C66_trans(1:6,1:6,i) = R%rotStiffness(C_target_unrotated66)
enddo
end do
end function lattice_C66_trans
@ -632,7 +632,7 @@ function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSc
math_cross(normal, direction))
if (size(nonSchmidCoefficients)>5) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) &
+ nonSchmidCoefficients(6) * math_outer(direction, direction)
enddo
end do
end function lattice_nonSchmidMatrix
@ -1431,8 +1431,8 @@ function lattice_SchmidMatrix_slip(Nslip,lattice,cOverA) result(SchmidMatrix)
do i = 1, sum(Nslip)
SchmidMatrix(1:3,1:3,i) = math_outer(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i))
if (abs(math_trace33(SchmidMatrix(1:3,1:3,i))) > tol_math_check) &
call IO_error(0,i,ext_msg = 'dilatational Schmid matrix for slip')
enddo
error stop 'dilatational Schmid matrix for slip'
end do
end function lattice_SchmidMatrix_slip
@ -1478,8 +1478,8 @@ function lattice_SchmidMatrix_twin(Ntwin,lattice,cOverA) result(SchmidMatrix)
do i = 1, sum(Ntwin)
SchmidMatrix(1:3,1:3,i) = math_outer(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i))
if (abs(math_trace33(SchmidMatrix(1:3,1:3,i))) > tol_math_check) &
call IO_error(0,i,ext_msg = 'dilatational Schmid matrix for twin')
enddo
error stop 'dilatational Schmid matrix for twin'
end do
end function lattice_SchmidMatrix_twin
@ -1552,7 +1552,7 @@ function lattice_SchmidMatrix_cleavage(Ncleavage,lattice,cOverA) result(SchmidMa
SchmidMatrix(1:3,1:3,1,i) = math_outer(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i))
SchmidMatrix(1:3,1:3,2,i) = math_outer(coordinateSystem(1:3,3,i),coordinateSystem(1:3,2,i))
SchmidMatrix(1:3,1:3,3,i) = math_outer(coordinateSystem(1:3,2,i),coordinateSystem(1:3,2,i))
enddo
end do
end function lattice_SchmidMatrix_cleavage
@ -1719,8 +1719,8 @@ pure function lattice_symmetrize_C66(C66,lattice) result(C66_sym)
do i = 1, 6
do j = i+1, 6
C66_sym(j,i) = C66_sym(i,j)
enddo
enddo
end do
end do
end function lattice_symmetrize_C66
@ -1782,7 +1782,7 @@ function slipProjection_transverse(Nslip,lattice,cOverA) result(projection)
do i=1, sum(Nslip); do j=1, sum(Nslip)
projection(i,j) = abs(math_inner(n(:,i),t(:,j)))
enddo; enddo
end do; end do
end function slipProjection_transverse
@ -1806,7 +1806,7 @@ function slipProjection_direction(Nslip,lattice,cOverA) result(projection)
do i=1, sum(Nslip); do j=1, sum(Nslip)
projection(i,j) = abs(math_inner(n(:,i),d(:,j)))
enddo; enddo
end do; end do
end function slipProjection_direction
@ -1890,8 +1890,8 @@ function buildInteraction(reacting_used,acting_used,reacting_max,acting_max,valu
buildInteraction(l,k) = values(matrix(i,j))
enddo; enddo
enddo; enddo
end do; end do
end do; end do
end function buildInteraction
@ -1957,8 +1957,8 @@ function buildCoordinateSystem(active,potential,system,lattice,cOverA)
buildCoordinateSystem(1:3,3,a) = math_cross(direction/norm2(direction),&
normal /norm2(normal))
enddo activeSystems
enddo activeFamilies
end do activeSystems
end do activeFamilies
end function buildCoordinateSystem
@ -2008,7 +2008,7 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
],pReal),shape(CFTOHP_SYSTEMTRANS))
real(pReal), dimension(4,cF_Ntrans), parameter :: &
CFTOCI_SYSTEMTRANS = reshape([&
CFTOCI_SYSTEMTRANS = real(reshape([&
0.0, 1.0, 0.0, 10.26, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3)
0.0,-1.0, 0.0, 10.26, &
0.0, 0.0, 1.0, 10.26, &
@ -2021,7 +2021,7 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
-1.0, 0.0, 0.0, 10.26, &
0.0, 1.0, 0.0, 10.26, &
0.0,-1.0, 0.0, 10.26 &
],shape(CFTOCI_SYSTEMTRANS))
],shape(CFTOCI_SYSTEMTRANS)),pReal)
integer, dimension(9,cF_Ntrans), parameter :: &
CFTOCI_BAINVARIANT = reshape( [&
@ -2040,7 +2040,7 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
],shape(CFTOCI_BAINVARIANT))
real(pReal), dimension(4,cF_Ntrans), parameter :: &
CFTOCI_BAINROT = reshape([&
CFTOCI_BAINROT = real(reshape([&
1.0, 0.0, 0.0, 45.0, & ! Rotate cF austensite to bain variant
1.0, 0.0, 0.0, 45.0, &
1.0, 0.0, 0.0, 45.0, &
@ -2053,7 +2053,7 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
0.0, 0.0, 1.0, 45.0, &
0.0, 0.0, 1.0, 45.0, &
0.0, 0.0, 1.0, 45.0 &
],shape(CFTOCI_BAINROT))
],shape(CFTOCI_BAINROT)),pReal)
if (present(a_cI) .and. present(a_cF)) then
do i = 1,sum(Ntrans)
@ -2066,7 +2066,7 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_cF,a_cI)
U = (a_cI/a_cF) * (math_outer(x,x) + (math_outer(y,y)+math_outer(z,z)) * sqrt(2.0_pReal))
Q(1:3,1:3,i) = matmul(R%asMatrix(),B%asMatrix())
S(1:3,1:3,i) = matmul(R%asMatrix(),U) - MATH_I3
enddo
end do
else if (present(cOverA)) then
ss = MATH_I3
sd = MATH_I3
@ -2125,7 +2125,7 @@ function getlabels(active,potential,system) result(labels)
write(label(i+1:i+2),'(I2.1)') int(system(j,p))
label(i+3:i+3) = ' '
i = i + 3
enddo direction
end do direction
label(i:i) = ']'
i = i +1
@ -2134,13 +2134,13 @@ function getlabels(active,potential,system) result(labels)
write(label(i+1:i+2),'(I2.1)') int(system(j,p))
label(i+3:i+3) = ' '
i = i + 3
enddo normal
end do normal
label(i:i) = ')'
labels(a) = label
enddo activeSystems
enddo activeFamilies
end do activeSystems
end do activeFamilies
end function getlabels
@ -2170,7 +2170,7 @@ pure function lattice_equivalent_nu(C,assumption) result(nu)
/ (S(1,1)+S(2,2)+S(3,3) +2.0_pReal*(S(1,2)+S(2,3)+S(1,3)))
else
error stop 'invalid assumption'
endif
end if
mu = lattice_equivalent_mu(C,assumption)
nu = (1.5_pReal*K-mu)/(3.0_pReal*K+mu)
@ -2202,7 +2202,7 @@ pure function lattice_equivalent_mu(C,assumption) result(mu)
/ (4.0_pReal*(S(1,1)+S(2,2)+S(3,3)) -4.0_pReal*(S(1,2)+S(2,3)+S(1,3)) +3.0_pReal*(S(4,4)+S(5,5)+S(6,6)))
else
error stop 'invalid assumption'
endif
end if
end function lattice_equivalent_mu
@ -2266,7 +2266,7 @@ subroutine selfTest
if (any(dNeq(T(1,1),[T_hP(1,1),T_hP(2,2)]))) error stop 'Symmetry33_11-22/hP'
if (any(dNeq(T(1,1),[T_tI(1,1),T_tI(2,2)]))) error stop 'Symmetry33_11-22/tI'
enddo
end do
call random_number(C)
C(1,1) = C(1,1) + C(1,2) + 0.1_pReal

2
src/material.f90
View File

@ -14,7 +14,7 @@ module material
use discretization
use YAML_types
implicit none
implicit none(type,external)
private
type, public :: tRotationContainer

2
src/materialpoint.f90
View File

@ -31,7 +31,7 @@ module materialpoint
use discretization_grid
#endif
implicit none
implicit none(type,external)
public
contains

80
src/math.f90
View File

@ -12,7 +12,7 @@ module math
use YAML_types
use LAPACK_interface
implicit none
implicit none(type,external)
public
#if __INTEL_COMPILER >= 1900
! do not make use of associated entities available to other modules
@ -135,25 +135,25 @@ pure recursive subroutine math_sort(a, istart, iend, sortDim)
s = istart
else
s = lbound(a,2)
endif
end if
if (present(iend)) then
e = iend
else
e = ubound(a,2)
endif
end if
if (present(sortDim)) then
d = sortDim
else
d = 1
endif
end if
if (s < e) then
call qsort_partition(a,ipivot, s,e, d)
call math_sort(a, s, ipivot-1, d)
call math_sort(a, ipivot+1, e, d)
endif
end if
contains
@ -175,11 +175,11 @@ pure recursive subroutine math_sort(a, istart, iend, sortDim)
! find the first element on the right side less than or equal to the pivot point
do j = iend, istart, -1
if (a(sort,j) <= a(sort,istart)) exit
enddo
end do
! find the first element on the left side greater than the pivot point
do i = istart, iend
if (a(sort,i) > a(sort,istart)) exit
enddo
end do
cross: if (i >= j) then ! exchange left value with pivot and return with the partition index
tmp = a(:,istart)
a(:,istart) = a(:,j)
@ -190,8 +190,8 @@ pure recursive subroutine math_sort(a, istart, iend, sortDim)
tmp = a(:,i)
a(:,i) = a(:,j)
a(:,j) = tmp
endif cross
enddo
end if cross
end do
end subroutine qsort_partition
@ -216,7 +216,7 @@ pure function math_expand(what,how)
do i = 1, size(how)
math_expand(sum(how(1:i-1))+1:sum(how(1:i))) = what(mod(i-1,size(what))+1)
enddo
end do
end function math_expand
@ -251,7 +251,7 @@ pure function math_eye(d)
math_eye = 0.0_pReal
do i=1,d
math_eye(i,i) = 1.0_pReal
enddo
end do
end function math_eye
@ -270,7 +270,7 @@ pure function math_identity4th()
#ifndef __INTEL_COMPILER
do concurrent(i=1:3, j=1:3, k=1:3, l=1:3)
math_identity4th(i,j,k,l) = 0.5_pReal*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k))
enddo
end do
#else
forall(i=1:3, j=1:3, k=1:3, l=1:3) &
math_identity4th(i,j,k,l) = 0.5_pReal*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k))
@ -298,7 +298,7 @@ real(pReal) pure function math_LeviCivita(i,j,k)
math_LeviCivita = -1.0_pReal
else
math_LeviCivita = 0.0_pReal
endif
end if
end function math_LeviCivita
@ -348,7 +348,7 @@ pure function math_outer(A,B)
#ifndef __INTEL_COMPILER
do concurrent(i=1:size(A,1), j=1:size(B,1))
math_outer(i,j) = A(i)*B(j)
enddo
end do
#else
forall(i=1:size(A,1), j=1:size(B,1)) math_outer(i,j) = A(i)*B(j)
#endif
@ -398,7 +398,7 @@ pure function math_mul3333xx33(A,B)
#ifndef __INTEL_COMPILER
do concurrent(i=1:3, j=1:3)
math_mul3333xx33(i,j) = sum(A(i,j,1:3,1:3)*B(1:3,1:3))
enddo
end do
#else
forall (i=1:3, j=1:3) math_mul3333xx33(i,j) = sum(A(i,j,1:3,1:3)*B(1:3,1:3))
#endif
@ -421,7 +421,7 @@ pure function math_mul3333xx3333(A,B)
#ifndef __INTEL_COMPILER
do concurrent(i=1:3, j=1:3, k=1:3, l=1:3)
math_mul3333xx3333(i,j,k,l) = sum(A(i,j,1:3,1:3)*B(1:3,1:3,k,l))
enddo
end do
#else
forall(i=1:3, j=1:3, k=1:3, l=1:3) math_mul3333xx3333(i,j,k,l) = sum(A(i,j,1:3,1:3)*B(1:3,1:3,k,l))
#endif
@ -446,7 +446,7 @@ pure function math_exp33(A,n)
n_ = n
else
n_ = 5
endif
end if
invFac = 1.0_pReal ! 0!
B = math_I3
@ -456,7 +456,7 @@ pure function math_exp33(A,n)
invFac = invFac/real(i,pReal) ! invfac = 1/(i!)
B = matmul(B,A)
math_exp33 = math_exp33 + invFac*B ! exp = SUM (A^i)/(i!)
enddo
end do
end function math_exp33
@ -514,7 +514,7 @@ pure subroutine math_invert33(InvA, DetA, error, A)
InvA = InvA/DetA
error = .false.
endif
end if
end subroutine math_invert33
@ -541,7 +541,7 @@ pure function math_invSym3333(A)
error stop 'matrix inversion error'
else
math_invSym3333 = math_66toSym3333(temp66)
endif
end if
end function math_invSym3333
@ -696,7 +696,7 @@ pure function math_9to33(v9)
do i = 1, 9
math_9to33(MAPPLAIN(1,i),MAPPLAIN(2,i)) = v9(i)
enddo
end do
end function math_9to33
@ -721,7 +721,7 @@ pure function math_sym33to6(m33,weighted)
w = merge(NRMMANDEL,1.0_pReal,weighted)
else
w = NRMMANDEL
endif
end if
math_sym33to6 = [(w(i)*m33(MAPNYE(1,i),MAPNYE(2,i)),i=1,6)]
@ -748,12 +748,12 @@ pure function math_6toSym33(v6,weighted)
w = merge(INVNRMMANDEL,1.0_pReal,weighted)
else
w = INVNRMMANDEL
endif
end if
do i=1,6
math_6toSym33(MAPNYE(1,i),MAPNYE(2,i)) = w(i)*v6(i)
math_6toSym33(MAPNYE(2,i),MAPNYE(1,i)) = w(i)*v6(i)
enddo
end do
end function math_6toSym33
@ -772,7 +772,7 @@ pure function math_3333to99(m3333)
#ifndef __INTEL_COMPILER
do concurrent(i=1:9, j=1:9)
math_3333to99(i,j) = m3333(MAPPLAIN(1,i),MAPPLAIN(2,i),MAPPLAIN(1,j),MAPPLAIN(2,j))
enddo
end do
#else
forall(i=1:9, j=1:9) math_3333to99(i,j) = m3333(MAPPLAIN(1,i),MAPPLAIN(2,i),MAPPLAIN(1,j),MAPPLAIN(2,j))
#endif
@ -794,7 +794,7 @@ pure function math_99to3333(m99)
#ifndef __INTEL_COMPILER
do concurrent(i=1:9, j=1:9)
math_99to3333(MAPPLAIN(1,i),MAPPLAIN(2,i),MAPPLAIN(1,j),MAPPLAIN(2,j)) = m99(i,j)
enddo
end do
#else
forall(i=1:9, j=1:9) math_99to3333(MAPPLAIN(1,i),MAPPLAIN(2,i),MAPPLAIN(1,j),MAPPLAIN(2,j)) = m99(i,j)
#endif
@ -827,7 +827,7 @@ pure function math_sym3333to66(m3333,weighted)
#ifndef __INTEL_COMPILER
do concurrent(i=1:6, j=1:6)
math_sym3333to66(i,j) = w(i)*w(j)*m3333(MAPNYE(1,i),MAPNYE(2,i),MAPNYE(1,j),MAPNYE(2,j))
enddo
end do
#else
forall(i=1:6, j=1:6) math_sym3333to66(i,j) = w(i)*w(j)*m3333(MAPNYE(1,i),MAPNYE(2,i),MAPNYE(1,j),MAPNYE(2,j))
#endif
@ -1080,8 +1080,8 @@ pure subroutine math_eigh33(w,v,m)
else fallback2
v(1:3,2) = v(1:3, 2) / norm
v(1:3,3) = math_cross(v(1:3,1),v(1:3,2))
endif fallback2
endif fallback1
end if fallback2
end if fallback1
end subroutine math_eigh33
@ -1110,7 +1110,7 @@ pure function math_rotationalPart(F) result(R)
C = matmul(transpose(F),F)
I_C = math_invariantsSym33(C)
I_F = [math_trace33(F), 0.5*(math_trace33(F)**2 - math_trace33(matmul(F,F)))]
I_F = [math_trace33(F), 0.5_pReal*(math_trace33(F)**2 - math_trace33(matmul(F,F)))]
x = math_clip(I_C(1)**2 -3.0_pReal*I_C(2),0.0_pReal)**(3.0_pReal/2.0_pReal)
if (dNeq0(x)) then
@ -1120,7 +1120,7 @@ pure function math_rotationalPart(F) result(R)
lambda = sqrt(math_clip(lambda,0.0_pReal)/3.0_pReal)
else
lambda = sqrt(I_C(1)/3.0_pReal)
endif
end if
I_U = [sum(lambda), lambda(1)*lambda(2)+lambda(2)*lambda(3)+lambda(3)*lambda(1), product(lambda)]
@ -1129,7 +1129,7 @@ pure function math_rotationalPart(F) result(R)
- I_U(1)*I_F(1) * transpose(F) &
+ I_U(1) * transpose(matmul(F,F)) &
- matmul(F,C)
R = R /(I_U(1)*I_U(2)-I_U(3))
R = R*math_det33(R)**(-1.0_pReal/3.0_pReal)
end function math_rotationalPart
@ -1188,7 +1188,7 @@ pure function math_eigvalsh33(m)
cos((phi+2.0_pReal*TAU)/3.0_pReal) &
] &
+ I(1)/3.0_pReal
endif
end if
end function math_eigvalsh33
@ -1238,7 +1238,7 @@ integer pure function math_binomial(n,k)
do i = 1, k_
math_binomial = (math_binomial * n_)/i
n_ = n_ -1
enddo
end do
end function math_binomial
@ -1302,7 +1302,7 @@ real(pReal) pure elemental function math_clip(a, left, right)
if (present(right)) math_clip = min(right,math_clip)
if (present(left) .and. present(right)) then
if (left>right) error stop 'left > right'
endif
end if
end function math_clip
@ -1386,7 +1386,7 @@ subroutine selfTest()
call random_number(v3_3)
call random_number(v3_4)
if (dNeq(abs(dot_product(math_cross(v3_1-v3_4,v3_2-v3_4),v3_3-v3_4))/6.0, &
if (dNeq(abs(dot_product(math_cross(v3_1-v3_4,v3_2-v3_4),v3_3-v3_4))/6.0_pReal, &
math_volTetrahedron(v3_1,v3_2,v3_3,v3_4),tol=1.0e-12_pReal)) &
error stop 'math_volTetrahedron'
@ -1402,7 +1402,7 @@ subroutine selfTest()
do while(abs(math_det33(t33))<1.0e-9_pReal)
call random_number(t33)
enddo
end do
if (any(dNeq0(matmul(t33,math_inv33(t33)) - math_eye(3),tol=1.0e-9_pReal))) &
error stop 'math_inv33'
@ -1418,11 +1418,13 @@ subroutine selfTest()
do while(math_det33(t33)<1.0e-2_pReal) ! O(det(F)) = 1
call random_number(t33)
enddo
end do
t33_2 = math_rotationalPart(transpose(t33))
t33 = math_rotationalPart(t33)
if (any(dNeq0(matmul(t33_2,t33) - math_I3,tol=1.0e-10_pReal))) &
error stop 'math_rotationalPart'
error stop 'math_rotationalPart (forward-backward)'
if (dNeq(1.0_pReal,math_det33(math_rotationalPart(t33)),tol=1.0e-10_pReal)) &
error stop 'math_rotationalPart (determinant)'
call random_number(r)
d = int(r*5.0_pReal) + 1

2
src/mesh/DAMASK_mesh.f90
View File

@ -20,7 +20,7 @@ program DAMASK_mesh
use FEM_Utilities
use mesh_mechanical_FEM
implicit none
implicit none(type,external)
type :: tLoadCase
real(pReal) :: time = 0.0_pReal !< length of increment

2
src/mesh/FEM_quadrature.f90
View File

@ -5,7 +5,7 @@
module FEM_quadrature
use prec
implicit none
implicit none(type,external)
private
integer, parameter :: &

11
src/mesh/FEM_utilities.f90
View File

@ -21,7 +21,11 @@ module FEM_utilities
use homogenization
use FEM_quadrature
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
logical, public :: cutBack = .false. !< cut back of BVP solver in case convergence is not achieved or a material point is terminally ill
@ -65,6 +69,11 @@ module FEM_utilities
type(tComponentBC), allocatable, dimension(:) :: componentBC
end type tFieldBC
external :: & ! ToDo: write interfaces
PetscSectionGetFieldComponents, &
PetscSectionGetFieldDof, &
PetscSectionGetFieldOffset
public :: &
FEM_utilities_init, &
utilities_constitutiveResponse, &
@ -131,7 +140,7 @@ subroutine FEM_utilities_init
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_optionsOrder),err_PETSc)
CHKERRQ(err_PETSc)
wgt = 1.0/real(mesh_maxNips*mesh_NcpElemsGlobal,pReal)
wgt = real(mesh_maxNips*mesh_NcpElemsGlobal,pReal)**(-1)
end subroutine FEM_utilities_init

17
src/mesh/discretization_mesh.f90
View File

@ -25,7 +25,11 @@ module discretization_mesh
use YAML_types
use prec
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
integer, public, protected :: &
@ -52,6 +56,11 @@ module discretization_mesh
real(pReal), dimension(:,:,:), allocatable :: &
mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!)
external :: &
#ifdef PETSC_USE_64BIT_INDICES
DMDestroy, &
#endif
DMView ! ToDo: write interface
public :: &
discretization_mesh_init, &
mesh_FEM_build_ipVolumes, &
@ -242,12 +251,12 @@ subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints)
call DMPlexComputeCellGeometryAffineFEM(geomMesh,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc)
CHKERRQ(err_PETSc)
qOffset = 0
do qPt = 1, mesh_maxNips
do dirI = 1, dimPlex
do qPt = 1_pPETSCINT, mesh_maxNips
do dirI = 1_pPETSCINT, dimPlex
mesh_ipCoordinates(dirI,qPt,cell+1) = pV0(dirI)
do dirJ = 1, dimPlex
do dirJ = 1_pPETSCINT, dimPlex
mesh_ipCoordinates(dirI,qPt,cell+1) = mesh_ipCoordinates(dirI,qPt,cell+1) + &
pCellJ((dirI-1)*dimPlex+dirJ)*(qPoints(qOffset+dirJ) + 1.0)
pCellJ((dirI-1)*dimPlex+dirJ)*(qPoints(qOffset+dirJ) + 1.0_pReal)
enddo
enddo
qOffset = qOffset + dimPlex

148
src/mesh/mesh_mech_FEM.f90
View File

@ -26,7 +26,11 @@ module mesh_mechanical_FEM
use homogenization
use math
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
!--------------------------------------------------------------------------------------------------
@ -67,6 +71,18 @@ module mesh_mechanical_FEM
logical :: ForwardData
real(pReal), parameter :: eps = 1.0e-18_pReal
external :: & ! ToDo: write interfaces
#ifdef PETSC_USE_64BIT_INDICES
ISDestroy, &
#endif
PetscSectionGetNumFields, &
PetscFESetQuadrature, &
PetscFEGetDimension, &
PetscFEDestroy, &
PetscSectionGetDof, &
PetscFEGetDualSpace, &
PetscDualSpaceGetFunctional
public :: &
FEM_mechanical_init, &
FEM_mechanical_solution, &
@ -230,14 +246,14 @@ subroutine FEM_mechanical_init(fieldBC)
CHKERRQ(err_PETSc)
call SNESSetConvergenceTest(mechanical_snes,FEM_mechanical_converged,PETSC_NULL_VEC,PETSC_NULL_FUNCTION,err_PETSc)
CHKERRQ(err_PETSc)
call SNESSetTolerances(mechanical_snes,1.0,0.0,0.0,num%itmax,num%itmax,err_PETSc)
call SNESSetTolerances(mechanical_snes,1.0_pReal,0.0_pReal,0.0_pReal,num%itmax,num%itmax,err_PETSc)
CHKERRQ(err_PETSc)
call SNESSetFromOptions(mechanical_snes,err_PETSc); CHKERRQ(err_PETSc)
!--------------------------------------------------------------------------------------------------
! init fields
call VecSet(solution ,0.0,err_PETSc); CHKERRQ(err_PETSc)
call VecSet(solution_rate ,0.0,err_PETSc); CHKERRQ(err_PETSc)
call VecSet(solution ,0.0_pReal,err_PETSc); CHKERRQ(err_PETSc)
call VecSet(solution_rate,0.0_pReal,err_PETSc); CHKERRQ(err_PETSc)
allocate(x_scal(cellDof))
allocate(nodalWeightsP(1))
allocate(nodalPointsP(dimPlex))
@ -338,11 +354,10 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
PetscInt :: cellStart, cellEnd, cell, field, face, &
qPt, basis, comp, cidx, &
numFields, &
bcSize,m
bcSize,m,i
PetscReal :: detFAvg, detJ
PetscReal, dimension(dimPlex*dimPlex,cellDof) :: BMat
IS :: bcPoints
IS :: bcPoints
allocate(pV0(dimPlex))
@ -358,9 +373,9 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
CHKERRQ(err_PETSc)
call DMGetLocalVector(dm_local,x_local,err_PETSc)
CHKERRQ(err_PETSc)
call VecWAXPY(x_local,1.0,xx_local,solution_local,err_PETSc)
call VecWAXPY(x_local,1.0_pReal,xx_local,solution_local,err_PETSc)
CHKERRQ(err_PETSc)
do field = 1, dimPlex; do face = 1, mesh_Nboundaries
do field = 1_pPETSCINT, dimPlex; do face = 1_pPETSCINT, mesh_Nboundaries
if (params%fieldBC%componentBC(field)%Mask(face)) then
call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,err_PETSc)
if (bcSize > 0) then
@ -375,7 +390,7 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
!--------------------------------------------------------------------------------------------------
! evaluate field derivatives
do cell = cellStart, cellEnd-1 !< loop over all elements
do cell = cellStart, cellEnd-1_pPETSCINT !< loop over all elements
call PetscSectionGetNumFields(section,numFields,err_PETSc)
CHKERRQ(err_PETSc)
@ -384,25 +399,25 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc)
CHKERRQ(err_PETSc)
IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex])
do qPt = 0, nQuadrature-1
m = cell*nQuadrature + qPt+1
BMat = 0.0
do basis = 0, nBasis-1
do comp = 0, dimPlex-1
do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
m = cell*nQuadrature + qPt+1_pPETSCINT
BMat = 0.0_pReal
do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
cidx = basis*dimPlex+comp
BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = &
matmul(IcellJMat,basisFieldDer((((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp )*dimPlex+1: &
(((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp+1)*dimPlex))
i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = &
matmul(IcellJMat,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
enddo
enddo
homogenization_F(1:dimPlex,1:dimPlex,m) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1])
enddo
if (num%BBarStabilisation) then
detFAvg = math_det33(sum(homogenization_F(1:3,1:3,cell*nQuadrature+1:(cell+1)*nQuadrature),dim=3)/real(nQuadrature))
detFAvg = math_det33(sum(homogenization_F(1:3,1:3,cell*nQuadrature+1:(cell+1)*nQuadrature),dim=3)/real(nQuadrature,pReal))
do qPt = 0, nQuadrature-1
m = cell*nQuadrature + qPt+1
homogenization_F(1:dimPlex,1:dimPlex,m) = homogenization_F(1:dimPlex,1:dimPlex,m) &
* (detFAvg/math_det33(homogenization_F(1:3,1:3,m)))**(1.0/real(dimPlex))
* (detFAvg/math_det33(homogenization_F(1:3,1:3,m)))**(1.0_pReal/real(dimPlex,pReal))
enddo
endif
@ -425,22 +440,22 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc
call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc)
CHKERRQ(err_PETSc)
IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex])
f_scal = 0.0
do qPt = 0, nQuadrature-1
m = cell*nQuadrature + qPt+1
BMat = 0.0
do basis = 0, nBasis-1
do comp = 0, dimPlex-1
f_scal = 0.0_pReal
do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
m = cell*nQuadrature + qPt+1_pPETSCINT
BMat = 0.0_pReal
do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
cidx = basis*dimPlex+comp
BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = &
matmul(IcellJMat,basisFieldDer((((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp )*dimPlex+1: &
(((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp+1)*dimPlex))
i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = &
matmul(IcellJMat,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
enddo
enddo
f_scal = f_scal + &
matmul(transpose(BMat), &
reshape(transpose(homogenization_P(1:dimPlex,1:dimPlex,m)), &
shape=[dimPlex*dimPlex]))*qWeights(qPt+1)
f_scal = f_scal &
+ matmul(transpose(BMat), &
reshape(transpose(homogenization_P(1:dimPlex,1:dimPlex,m)), &
shape=[dimPlex*dimPlex]))*qWeights(qPt+1_pPETSCINT)
enddo
f_scal = f_scal*abs(detJ)
pf_scal => f_scal
@ -465,28 +480,25 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
PetscObject, intent(in) :: dummy
PetscErrorCode :: err_PETSc
PetscDS :: prob
Vec :: x_local, xx_local
PetscSection :: section, gSection
PetscDS :: prob
Vec :: x_local, xx_local
PetscSection :: section, gSection
PetscReal, dimension(1, cellDof) :: MatB
PetscReal, dimension(dimPlex**2,cellDof) :: BMat, BMatAvg, MatA
PetscReal, dimension(3,3) :: F, FAvg, FInv
PetscReal :: detJ
PetscReal, dimension(:), pointer :: basisField, basisFieldDer, &
PetscReal, dimension(3,3) :: F, FAvg, FInv
PetscReal :: detJ
PetscReal, dimension(:), pointer :: basisField, basisFieldDer, &
pV0, pCellJ, pInvcellJ
PetscScalar, dimension(:), pointer :: pK_e, x_scal
PetscScalar,dimension(cellDOF,cellDOF), target :: K_e
PetscScalar,dimension(cellDOF,cellDOF) :: K_eA , &
K_eB
PetscScalar,dimension(cellDOF,cellDOF) :: K_eA, K_eB
PetscInt :: cellStart, cellEnd, cell, field, face, &
qPt, basis, comp, cidx,bcSize, m
IS :: bcPoints
PetscInt :: cellStart, cellEnd, cell, field, face, &
qPt, basis, comp, cidx,bcSize, m, i
IS :: bcPoints
allocate(pV0(dimPlex))
@ -530,30 +542,29 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
CHKERRQ(err_PETSc)
call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,err_PETSc)
CHKERRQ(err_PETSc)
K_eA = 0.0
K_eB = 0.0
MatB = 0.0
FAvg = 0.0
BMatAvg = 0.0
do qPt = 0, nQuadrature-1
m = cell*nQuadrature + qPt + 1
BMat = 0.0
do basis = 0, nBasis-1
do comp = 0, dimPlex-1
K_eA = 0.0_pReal
K_eB = 0.0_pReal
MatB = 0.0_pReal
FAvg = 0.0_pReal
BMatAvg = 0.0_pReal
do qPt = 0_pPETSCINT, nQuadrature-1_pPETSCINT
m = cell*nQuadrature + qPt + 1_pPETSCINT
BMat = 0.0_pReal
do basis = 0_pPETSCINT, nBasis-1_pPETSCINT
do comp = 0_pPETSCINT, dimPlex-1_pPETSCINT
cidx = basis*dimPlex+comp
BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = &
matmul( reshape(pInvcellJ, shape = [dimPlex,dimPlex]),&
basisFieldDer((((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp )*dimPlex+1: &
(((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp+1)*dimPlex))
i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = &
matmul(reshape(pInvcellJ,[dimPlex,dimPlex]),basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
enddo
enddo
MatA = matmul(reshape(reshape(homogenization_dPdF(1:dimPlex,1:dimPlex,1:dimPlex,1:dimPlex,m), &
shape=[dimPlex,dimPlex,dimPlex,dimPlex], order=[2,1,4,3]), &
shape=[dimPlex*dimPlex,dimPlex*dimPlex]),BMat)*qWeights(qPt+1)
shape=[dimPlex*dimPlex,dimPlex*dimPlex]),BMat)*qWeights(qPt+1_pPETSCINT)
if (num%BBarStabilisation) then
F(1:dimPlex,1:dimPlex) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex])
FInv = math_inv33(F)
K_eA = K_eA + matmul(transpose(BMat),MatA)*math_det33(FInv)**(1.0/real(dimPlex))
K_eA = K_eA + matmul(transpose(BMat),MatA)*math_det33(FInv)**(1.0_pReal/real(dimPlex,pReal))
K_eB = K_eB - &
matmul(transpose(matmul(reshape(homogenization_F(1:dimPlex,1:dimPlex,m),shape=[dimPlex**2,1_pPETSCINT]), &
matmul(reshape(FInv(1:dimPlex,1:dimPlex), &
@ -568,10 +579,10 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P
enddo
if (num%BBarStabilisation) then
FInv = math_inv33(FAvg)
K_e = K_eA*math_det33(FAvg/real(nQuadrature))**(1.0/real(dimPlex)) + &
K_e = K_eA*math_det33(FAvg/real(nQuadrature,pReal))**(1.0_pReal/real(dimPlex,pReal)) + &
(matmul(matmul(transpose(BMatAvg), &
reshape(FInv(1:dimPlex,1:dimPlex),shape=[dimPlex**2,1_pPETSCINT],order=[2,1])),MatB) + &
K_eB)/real(dimPlex)
K_eB)/real(dimPlex,pReal)
else
K_e = K_eA
endif
@ -641,7 +652,7 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC)
CHKERRQ(err_PETSc)
call DMGlobalToLocalEnd(dm_local,solution,INSERT_VALUES,x_local,err_PETSc)
CHKERRQ(err_PETSc)
call VecAXPY(solution_local,1.0,x_local,err_PETSc); CHKERRQ(err_PETSc)
call VecAXPY(solution_local,1.0_pReal,x_local,err_PETSc); CHKERRQ(err_PETSc)
do field = 1, dimPlex; do face = 1, mesh_Nboundaries
if (fieldBC%componentBC(field)%Mask(face)) then
call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,err_PETSc)
@ -659,7 +670,7 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC)
!--------------------------------------------------------------------------------------------------
! update rate and forward last inc
call VecCopy(solution,solution_rate,err_PETSc); CHKERRQ(err_PETSc)
call VecScale(solution_rate,1.0/timeinc_old,err_PETSc); CHKERRQ(err_PETSc)
call VecScale(solution_rate,timeinc_old**(-1),err_PETSc); CHKERRQ(err_PETSc)
endif
call VecCopy(solution_rate,solution,err_PETSc); CHKERRQ(err_PETSc)
call VecScale(solution,timeinc,err_PETSc); CHKERRQ(err_PETSc)
@ -685,9 +696,8 @@ subroutine FEM_mechanical_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reaso
call SNESConvergedDefault(snes_local,PETScIter,xnorm,snorm,fnorm/divTol,reason,dummy,err_PETSc)
CHKERRQ(err_PETSc)
if (terminallyIll) reason = SNES_DIVERGED_FUNCTION_DOMAIN
print'(/,1x,a,a,i0,a,i0,f0.3)', trim(incInfo), &
' @ Iteration ',PETScIter,' mechanical residual norm = ', &
int(fnorm/divTol),fnorm/divTol-int(fnorm/divTol) ! ToDo: int casting?
print'(/,1x,a,a,i0,a,f0.3)', trim(incInfo), &
' @ Iteration ',PETScIter,' mechanical residual norm = ',fnorm/divTol
print'(/,1x,a,/,2(3(2x,f12.4,1x)/),3(2x,f12.4,1x))', &
'Piola--Kirchhoff stress / MPa =',transpose(P_av)*1.e-6_pReal
flush(IO_STDOUT)
@ -747,7 +757,7 @@ subroutine FEM_mechanical_updateCoords()
call PetscDSGetTabulation(mechQuad,0_pPETSCINT,basisField,basisFieldDer,err_PETSc)
CHKERRQ(err_PETSc)
allocate(ipCoords(3,nQuadrature,mesh_NcpElems),source=0.0_pReal)
do c=cellStart,cellEnd-1
do c=cellStart,cellEnd-1_pPETSCINT
qOffset=0
call DMPlexVecGetClosure(dm_local,section,x_local,c,x_scal,err_PETSc) !< get nodal coordinates of each element
CHKERRQ(err_PETSc)

12
src/parallelization.f90
View File

@ -18,7 +18,11 @@ module parallelization
use prec
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
#ifndef PETSC
@ -90,14 +94,14 @@ subroutine parallelization_init
#ifdef LOGFILE
write(rank_str,'(i4.4)') worldrank
open(OUTPUT_UNIT,file='out.'//rank_str,status='replace',encoding='UTF-8')
open(ERROR_UNIT,file='error.'//rank_str,status='replace',encoding='UTF-8')
open(ERROR_UNIT,file='err.'//rank_str,status='replace',encoding='UTF-8')
#else
if (worldrank /= 0) then
close(OUTPUT_UNIT) ! disable output
open(OUTPUT_UNIT,file='/dev/null',status='replace') ! close() alone will leave some temp files in cwd
else
open(OUTPUT_UNIT,encoding='UTF-8') ! for special characters in output
endif
end if
#endif
print'(/,1x,a)', '<<<+- parallelization init -+>>>'
@ -142,8 +146,8 @@ subroutine parallelization_init
!$ if (OMP_NUM_THREADS < 1_pI32) then
!$ print'(1x,a)', 'Invalid OMP_NUM_THREADS: "'//trim(NumThreadsString)//'", using default'
!$ OMP_NUM_THREADS = 4_pI32
!$ endif
!$ endif
!$ end if
!$ end if
!$ print'(1x,a,i0)', 'OMP_NUM_THREADS: ',OMP_NUM_THREADS
!$ call omp_set_num_threads(OMP_NUM_THREADS)

35
src/phase.f90
View File

@ -19,7 +19,7 @@ module phase
use HDF5
use HDF5_utilities
implicit none
implicit none(type,external)
private
type :: tState
@ -539,7 +539,8 @@ subroutine crystallite_init()
class(tNode), pointer :: &
num_crystallite, &
phases
character(len=pStringLen) :: &
extmsg = ''
num_crystallite => config_numerics%get('crystallite',defaultVal=emptyDict)
@ -555,22 +556,19 @@ subroutine crystallite_init()
num%nState = num_crystallite%get_asInt ('nState', defaultVal=20)
num%nStress = num_crystallite%get_asInt ('nStress', defaultVal=40)
if (num%subStepMinCryst <= 0.0_pReal) call IO_error(301,ext_msg='subStepMinCryst')
if (num%subStepSizeCryst <= 0.0_pReal) call IO_error(301,ext_msg='subStepSizeCryst')
if (num%stepIncreaseCryst <= 0.0_pReal) call IO_error(301,ext_msg='stepIncreaseCryst')
if (num%subStepSizeLp <= 0.0_pReal) call IO_error(301,ext_msg='subStepSizeLp')
if (num%subStepSizeLi <= 0.0_pReal) call IO_error(301,ext_msg='subStepSizeLi')
if (num%rtol_crystalliteState <= 0.0_pReal) call IO_error(301,ext_msg='rtol_crystalliteState')
if (num%rtol_crystalliteStress <= 0.0_pReal) call IO_error(301,ext_msg='rtol_crystalliteStress')
if (num%atol_crystalliteStress <= 0.0_pReal) call IO_error(301,ext_msg='atol_crystalliteStress')
if (num%iJacoLpresiduum < 1) call IO_error(301,ext_msg='iJacoLpresiduum')
if (num%nState < 1) call IO_error(301,ext_msg='nState')
if (num%nStress< 1) call IO_error(301,ext_msg='nStress')
if (num%subStepMinCryst <= 0.0_pReal) extmsg = trim(extmsg)//' subStepMinCryst'
if (num%subStepSizeCryst <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeCryst'
if (num%stepIncreaseCryst <= 0.0_pReal) extmsg = trim(extmsg)//' stepIncreaseCryst'
if (num%subStepSizeLp <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeLp'
if (num%subStepSizeLi <= 0.0_pReal) extmsg = trim(extmsg)//' subStepSizeLi'
if (num%rtol_crystalliteState <= 0.0_pReal) extmsg = trim(extmsg)//' rtol_crystalliteState'
if (num%rtol_crystalliteStress <= 0.0_pReal) extmsg = trim(extmsg)//' rtol_crystalliteStress'
if (num%atol_crystalliteStress <= 0.0_pReal) extmsg = trim(extmsg)//' atol_crystalliteStress'
if (num%iJacoLpresiduum < 1) extmsg = trim(extmsg)//' iJacoLpresiduum'
if (num%nState < 1) extmsg = trim(extmsg)//' nState'
if (num%nStress < 1) extmsg = trim(extmsg)//' nStress'
if (extmsg /= '') call IO_error(301,ext_msg=trim(extmsg))
phases => config_material%get('phase')
@ -628,9 +626,10 @@ function crystallite_push33ToRef(co,ce, tensor33)
ce
real(pReal), dimension(3,3) :: crystallite_push33ToRef
real(pReal), dimension(3,3) :: T
real(pReal), dimension(3,3) :: T
integer :: ph, en
ph = material_phaseID(co,ce)
en = material_phaseEntry(co,ce)
T = matmul(phase_O_0(ph)%data(en)%asMatrix(),transpose(math_inv33(phase_F(co,ce)))) ! ToDo: initial orientation correct?

22
src/phase_damage.f90
View File

@ -4,8 +4,9 @@
submodule(phase) damage
type :: tDamageParameters
real(pReal) :: mu = 0.0_pReal !< viscosity
real(pReal), dimension(3,3) :: D = 0.0_pReal !< conductivity/diffusivity
real(pReal) :: &
mu = 0.0_pReal, & !< viscosity
l_c = 0.0_pReal !< characteristic length
end type tDamageParameters
enum, bind(c); enumerator :: &
@ -104,10 +105,8 @@ module subroutine damage_init
if (sources%length == 1) then
damage_active = .true.
source => sources%get(1)
param(ph)%mu = source%get_asFloat('mu')
param(ph)%D(1,1) = source%get_asFloat('D_11')
if (any(phase_lattice(ph) == ['hP','tI'])) param(ph)%D(3,3) = source%get_asFloat('D_33')
param(ph)%D = lattice_symmetrize_33(param(ph)%D,phase_lattice(ph))
param(ph)%mu = source%get_asFloat('mu')
param(ph)%l_c = source%get_asFloat('l_c')
end if
end do
@ -119,7 +118,7 @@ module subroutine damage_init
where(anisobrittle_init()) phase_damage = DAMAGE_ANISOBRITTLE_ID
end if
phase_damage_maxSizeDotState = maxval(damageState%sizeDotState)
phase_damage_maxSizeDotState = maxval(damageState%sizeDotState)
end subroutine damage_init
@ -159,9 +158,9 @@ module function phase_damage_C66(C66,ph,en) result(C66_degraded)
damageType: select case (phase_damage(ph))
case (DAMAGE_ISOBRITTLE_ID) damageType
C66_degraded = C66 * damage_phi(ph,en)**2
C66_degraded = C66 * damage_phi(ph,en)**2
case default damageType
C66_degraded = C66
C66_degraded = C66
end select damageType
end function phase_damage_C66
@ -385,9 +384,9 @@ module function phase_K_phi(co,ce) result(K)
integer, intent(in) :: co, ce
real(pReal), dimension(3,3) :: K
real(pReal), parameter :: l = 1.0_pReal
K = crystallite_push33ToRef(co,ce,param(material_phaseID(co,ce))%D) * l**2
K = crystallite_push33ToRef(co,ce,param(material_phaseID(co,ce))%l_c**2*math_I3)
end function phase_K_phi
@ -403,6 +402,7 @@ function phase_damage_deltaState(Fe, ph, en) result(broken)
en
real(pReal), intent(in), dimension(3,3) :: &
Fe !< elastic deformation gradient
integer :: &
myOffset, &
mySize

2
src/phase_damage_anisobrittle.f90
View File

@ -157,7 +157,7 @@ module subroutine anisobrittle_results(phase,group)
outputsLoop: do o = 1,size(prm%output)
select case(trim(prm%output(o)))
case ('f_phi')
call results_writeDataset(stt,group,trim(prm%output(o)),'driving force','J/m³')
call results_writeDataset(stt,group,trim(prm%output(o)),'driving force','-')
end select
end do outputsLoop
end associate

6
src/phase_damage_isobrittle.f90
View File

@ -63,7 +63,7 @@ module function isobrittle_init() result(mySources)
associate(prm => param(ph), dlt => deltaState(ph), stt => state(ph))
src => sources%get(1)
prm%W_crit = src%get_asFloat('W_crit')
prm%W_crit = src%get_asFloat('G_crit')/src%get_asFloat('l_c')
#if defined (__GFORTRAN__)
prm%output = output_as1dString(src)
@ -75,7 +75,7 @@ module function isobrittle_init() result(mySources)
if (prm%W_crit <= 0.0_pReal) extmsg = trim(extmsg)//' W_crit'
Nmembers = count(material_phaseID==ph)
call phase_allocateState(damageState(ph),Nmembers,1,1,1)
call phase_allocateState(damageState(ph),Nmembers,1,0,1)
damageState(ph)%atol = src%get_asFloat('atol_phi',defaultVal=1.0e-9_pReal)
if (any(damageState(ph)%atol < 0.0_pReal)) extmsg = trim(extmsg)//' atol_phi'
@ -139,7 +139,7 @@ module subroutine isobrittle_results(phase,group)
outputsLoop: do o = 1,size(prm%output)
select case(trim(prm%output(o)))
case ('f_phi')
call results_writeDataset(stt,group,trim(prm%output(o)),'driving force','J/m³') ! Wrong, this is dimensionless
call results_writeDataset(stt,group,trim(prm%output(o)),'driving force','-')
end select
end do outputsLoop

86
src/phase_mechanical.f90
View File

@ -255,7 +255,7 @@ module subroutine mechanical_init(phases)
#else
output_mechanical(ph)%label = mech%get_as1dString('output',defaultVal=emptyStringArray)
#endif
enddo
end do
do ce = 1, size(material_phaseID,2)
ma = discretization_materialAt((ce-1)/discretization_nIPs+1)
@ -267,14 +267,14 @@ module subroutine mechanical_init(phases)
phase_mechanical_Fe(ph)%data(1:3,1:3,en) = matmul(material_V_e_0(ma)%data(1:3,1:3,co), &
transpose(phase_mechanical_Fp(ph)%data(1:3,1:3,en)))
phase_mechanical_Fi(ph)%data(1:3,1:3,en) = material_O_0(ma)%data(co)%rotate(math_inv33(material_V_e_0(ma)%data(1:3,1:3,co)))
enddo
enddo
end do
end do
do ph = 1, phases%length
phase_mechanical_F0(ph)%data = phase_mechanical_F(ph)%data
phase_mechanical_Fp0(ph)%data = phase_mechanical_Fp(ph)%data
phase_mechanical_Fi0(ph)%data = phase_mechanical_Fi(ph)%data
enddo
end do
call elastic_init(phases)
@ -284,7 +284,7 @@ module subroutine mechanical_init(phases)
call plastic_init()
do ph = 1,phases%length
plasticState(ph)%state0 = plasticState(ph)%state
enddo
end do
num_crystallite => config_numerics%get('crystallite',defaultVal=emptyDict)
@ -473,25 +473,25 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
Lpguess = Lpguess_old &
+ deltaLp * stepLengthLp
cycle LpLoop
endif
end if
calculateJacobiLp: if (mod(jacoCounterLp, num%iJacoLpresiduum) == 0) then
jacoCounterLp = jacoCounterLp + 1
do o=1,3; do p=1,3
dFe_dLp(o,1:3,p,1:3) = - Delta_t * A(o,p)*transpose(invFi_new) ! dFe_dLp(i,j,k,l) = -Delta_t * A(i,k) invFi(l,j)
enddo; enddo
end do; end do
dRLp_dLp = math_eye(9) &
- math_3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dS,dS_dFe),dFe_dLp))
temp_9 = math_33to9(residuumLp)
call dgesv(9,1,dRLp_dLp,9,devNull_9,temp_9,9,ierr) ! solve dRLp/dLp * delta Lp = -res for delta Lp
if (ierr /= 0) return ! error
deltaLp = - math_9to33(temp_9)
endif calculateJacobiLp
end if calculateJacobiLp
Lpguess = Lpguess &
+ deltaLp * steplengthLp
enddo LpLoop
end do LpLoop
call phase_LiAndItsTangents(Li_constitutive, dLi_dS, dLi_dFi, &
S, Fi_new, ph,en)
@ -513,7 +513,7 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
Liguess = Liguess_old &
+ deltaLi * steplengthLi
cycle LiLoop
endif
end if
calculateJacobiLi: if (mod(jacoCounterLi, num%iJacoLpresiduum) == 0) then
jacoCounterLi = jacoCounterLi + 1
@ -522,10 +522,10 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
do o=1,3; do p=1,3
dFe_dLi(1:3,o,1:3,p) = -Delta_t*math_I3(o,p)*temp_33 ! dFe_dLp(i,j,k,l) = -Delta_t * A(i,k) invFi(l,j)
dFi_dLi(1:3,o,1:3,p) = -Delta_t*math_I3(o,p)*invFi_current
enddo; enddo
end do; end do
do o=1,3; do p=1,3
dFi_dLi(1:3,1:3,o,p) = matmul(matmul(Fi_new,dFi_dLi(1:3,1:3,o,p)),Fi_new)
enddo; enddo
end do; end do
dRLi_dLi = math_eye(9) &
- math_3333to99(math_mul3333xx3333(dLi_dS, math_mul3333xx3333(dS_dFe, dFe_dLi) &
+ math_mul3333xx3333(dS_dFi, dFi_dLi))) &
@ -534,11 +534,11 @@ function integrateStress(F,subFp0,subFi0,Delta_t,ph,en) result(broken)
call dgesv(9,1,dRLi_dLi,9,devNull_9,temp_9,9,ierr) ! solve dRLi/dLp * delta Li = -res for delta Li
if (ierr /= 0) return ! error
deltaLi = - math_9to33(temp_9)
endif calculateJacobiLi
end if calculateJacobiLi
Liguess = Liguess &
+ deltaLi * steplengthLi
enddo LiLoop
end do LiLoop
invFp_new = matmul(invFp_current,B)
call math_invert33(Fp_new,devNull,error,invFp_new)
@ -593,7 +593,7 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b
iteration: do NiterationState = 1, num%nState
dotState_last(1:sizeDotState,2) = merge(dotState_last(1:sizeDotState,1),0.0, nIterationState > 1)
dotState_last(1:sizeDotState,2) = merge(dotState_last(1:sizeDotState,1),0.0_pReal, nIterationState > 1)
dotState_last(1:sizeDotState,1) = dotState
broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en)
@ -613,9 +613,9 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b
if (converged(r,plasticState(ph)%state(1:sizeDotState,en),plasticState(ph)%atol(1:sizeDotState))) then
broken = plastic_deltaState(ph,en)
exit iteration
endif
end if
enddo iteration
end do iteration
contains
@ -638,7 +638,7 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b
damper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22)
else
damper = 1.0_pReal
endif
end if
end function damper
@ -756,7 +756,7 @@ function integrateStateRK4(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b
real(pReal), dimension(3), parameter :: &
C = [0.5_pReal, 0.5_pReal, 1.0_pReal]
real(pReal), dimension(4), parameter :: &
B = [1.0_pReal/6.0_pReal, 1.0_pReal/3.0_pReal, 1.0_pReal/3.0_pReal, 1.0_pReal/6.0_pReal]
B = [6.0_pReal, 3.0_pReal, 3.0_pReal, 6.0_pReal]**(-1)
broken = integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C)
@ -844,7 +844,7 @@ function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB)
#else
dotState = IEEE_FMA(A(n,stage),plastic_RKdotState(1:sizeDotState,n),dotState)
#endif
enddo
end do
#ifndef __INTEL_LLVM_COMPILER
plasticState(ph)%state(1:sizeDotState,en) = subState0 + dotState*Delta_t
@ -858,7 +858,7 @@ function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB)
dotState = plastic_dotState(Delta_t*C(stage), ph,en)
if (any(IEEE_is_NaN(dotState))) exit
enddo
end do
if(broken) return
@ -950,7 +950,7 @@ subroutine results(group,ph)
do i = 1, size(dataset,1)
to_quaternion(:,i) = dataset(i)%asQuaternion()
enddo
end do
end function to_quaternion
@ -974,7 +974,7 @@ module subroutine mechanical_forward()
phase_mechanical_Lp0(ph) = phase_mechanical_Lp(ph)
phase_mechanical_S0(ph) = phase_mechanical_S(ph)
plasticState(ph)%state0 = plasticState(ph)%state
enddo
end do
end subroutine mechanical_forward
@ -1037,7 +1037,7 @@ module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_)
subFp0 = phase_mechanical_Fp(ph)%data(1:3,1:3,en)
subFi0 = phase_mechanical_Fi(ph)%data(1:3,1:3,en)
subState0 = plasticState(ph)%state(:,en)
endif
end if
!--------------------------------------------------------------------------------------------------
! cut back (reduced time and restore)
else
@ -1048,10 +1048,10 @@ module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_)
if (subStep < 1.0_pReal) then ! actual (not initial) cutback
phase_mechanical_Lp(ph)%data(1:3,1:3,en) = subLp0
phase_mechanical_Li(ph)%data(1:3,1:3,en) = subLi0
endif
end if
plasticState(ph)%state(:,en) = subState0
todo = subStep > num%subStepMinCryst ! still on track or already done (beyond repair)
endif
end if
!--------------------------------------------------------------------------------------------------
! prepare for integration
@ -1060,9 +1060,9 @@ module function phase_mechanical_constitutive(Delta_t,co,ce) result(converged_)
subF = subF0 &
+ subStep * (phase_mechanical_F(ph)%data(1:3,1:3,en) - phase_mechanical_F0(ph)%data(1:3,1:3,en))
converged_ = .not. integrateState(subF0,subF,subFp0,subFi0,subState0(1:sizeDotState),subStep * Delta_t,ph,en)
endif
end if
enddo cutbackLooping
end do cutbackLooping
end function phase_mechanical_constitutive
@ -1086,14 +1086,14 @@ module subroutine mechanical_restore(ce,includeL)
if (includeL) then
phase_mechanical_Lp(ph)%data(1:3,1:3,en) = phase_mechanical_Lp0(ph)%data(1:3,1:3,en)
phase_mechanical_Li(ph)%data(1:3,1:3,en) = phase_mechanical_Li0(ph)%data(1:3,1:3,en)
endif ! maybe protecting everything from overwriting makes more sense
end if ! maybe protecting everything from overwriting makes more sense
phase_mechanical_Fp(ph)%data(1:3,1:3,en) = phase_mechanical_Fp0(ph)%data(1:3,1:3,en)
phase_mechanical_Fi(ph)%data(1:3,1:3,en) = phase_mechanical_Fi0(ph)%data(1:3,1:3,en)
phase_mechanical_S(ph)%data(1:3,1:3,en) = phase_mechanical_S0(ph)%data(1:3,1:3,en)
plasticState(ph)%state(:,en) = plasticState(ph)%State0(:,en)
enddo
end do
end subroutine mechanical_restore
@ -1164,17 +1164,17 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
lhs_3333(1:3,o,1:3,p) = IEEE_FMA(invFi,invFi(p,o),lhs_3333(1:3,o,1:3,p))
rhs_3333(1:3,1:3,o,p) = IEEE_FMA(matmul(invSubFi0,dLidS(1:3,1:3,o,p)),-Delta_t,rhs_3333(1:3,1:3,o,p))
#endif
enddo; enddo
end do; end do
call math_invert(temp_99,error,math_3333to99(lhs_3333))
if (error) then
call IO_warning(warning_ID=600, &
ext_msg='inversion error in analytic tangent calculation')
call IO_warning(600,'inversion error in analytic tangent calculation', &
label1='phase',ID1=ph,label2='entry',ID2=en)
dFidS = 0.0_pReal
else
dFidS = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333)
endif
end if
dLidS = math_mul3333xx3333(dLidFi,dFidS) + dLidS
endif
end if
call plastic_LpAndItsTangents(devNull,dLpdS,dLpdFi, &
phase_mechanical_S(ph)%data(1:3,1:3,en), &
@ -1191,7 +1191,7 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
rhs_3333(p,o,1:3,1:3) = matmul(dSdFe(p,o,1:3,1:3),temp_33_1)
temp_3333(1:3,1:3,p,o) = matmul(matmul(temp_33_2,dLpdS(1:3,1:3,p,o)), invFi) &
+ matmul(temp_33_3,dLidS(1:3,1:3,p,o))
enddo; enddo
end do; end do
#ifndef __INTEL_LLVM_COMPILER
lhs_3333 = math_mul3333xx3333(dSdFe,temp_3333) * Delta_t &
+ math_mul3333xx3333(dSdFi,dFidS)
@ -1201,19 +1201,19 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
call math_invert(temp_99,error,math_eye(9)+math_3333to99(lhs_3333))
if (error) then
call IO_warning(warning_ID=600, &
ext_msg='inversion error in analytic tangent calculation')
call IO_warning(600,'inversion error in analytic tangent calculation', &
label1='phase',ID1=ph,label2='entry',ID2=en)
dSdF = rhs_3333
else
dSdF = math_mul3333xx3333(math_99to3333(temp_99),rhs_3333)
endif
end if
!--------------------------------------------------------------------------------------------------
! calculate dFpinvdF
temp_3333 = math_mul3333xx3333(dLpdS,dSdF)
do o=1,3; do p=1,3
dFpinvdF(1:3,1:3,p,o) = - matmul(invSubFp0, matmul(temp_3333(1:3,1:3,p,o),invFi)) * Delta_t
enddo; enddo
end do; end do
!--------------------------------------------------------------------------------------------------
! assemble dPdF
@ -1224,13 +1224,13 @@ module function phase_mechanical_dPdF(Delta_t,co,ce) result(dPdF)
dPdF = 0.0_pReal
do p=1,3
dPdF(p,1:3,p,1:3) = transpose(matmul(invFp,temp_33_1))
enddo
end do
do o=1,3; do p=1,3
dPdF(1:3,1:3,p,o) = dPdF(1:3,1:3,p,o) &
+ matmul(matmul(phase_mechanical_F(ph)%data(1:3,1:3,en),dFpinvdF(1:3,1:3,p,o)),temp_33_1) &
+ matmul(matmul(temp_33_2,dSdF(1:3,1:3,p,o)),transpose(invFp)) &
+ matmul(temp_33_3,transpose(dFpinvdF(1:3,1:3,p,o)))
enddo; enddo
end do; end do
end function phase_mechanical_dPdF
@ -1263,8 +1263,6 @@ module subroutine mechanical_restartRead(groupHandle,ph)
integer(HID_T), intent(in) :: groupHandle
integer, intent(in) :: ph
integer :: en
call HDF5_read(plasticState(ph)%state0,groupHandle,'omega_plastic')
call HDF5_read(phase_mechanical_S0(ph)%data,groupHandle,'S')

2
src/phase_mechanical_eigen.f90
View File

@ -61,7 +61,7 @@ module subroutine eigen_init(phases)
if (maxval(Nmodels) /= 0) then
where(thermalexpansion_init(maxval(Nmodels))) model = EIGEN_thermal_expansion_ID
endif
end if
allocate(model_damage(phases%length), source = EIGEN_UNDEFINED_ID)

2
src/phase_mechanical_plastic.f90
View File

@ -435,7 +435,7 @@ function plastic_active(plastic_label) result(active_plastic)
mech => phase%get('mechanical')
pl => mech%get('plastic',defaultVal = emptyDict)
active_plastic(ph) = pl%get_asString('type',defaultVal='none') == plastic_label
enddo
end do
end function plastic_active

2
src/phase_mechanical_plastic_dislotungsten.f90
View File

@ -252,7 +252,7 @@ module function plastic_dislotungsten_init() result(myPlasticity)
!--------------------------------------------------------------------------------------------------
! exit if any parameter is out of range
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'(dislotungsten)')
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg))
end do

80
src/phase_mechanical_plastic_dislotwin.f90
View File

@ -9,28 +9,28 @@
!--------------------------------------------------------------------------------------------------
submodule(phase:plastic) dislotwin
real(pReal), parameter :: gamma_char_tr = sqrt(0.125_pReal) !< Characteristic shear for transformation
type :: tParameters
real(pReal) :: &
Q_cl = 1.0_pReal, & !< activation energy for dislocation climb
omega = 1.0_pReal, & !< frequency factor for dislocation climb
D = 1.0_pReal, & !< grain size
p_sb = 1.0_pReal, & !< p-exponent in shear band velocity
q_sb = 1.0_pReal, & !< q-exponent in shear band velocity
i_tw = 1.0_pReal, & !< adjustment parameter to calculate MFP for twinning
i_tr = 1.0_pReal, & !< adjustment parameter to calculate MFP for transformation
L_tw = 1.0_pReal, & !< length of twin nuclei
L_tr = 1.0_pReal, & !< length of trans nuclei
x_c = 1.0_pReal, & !< critical distance for formation of twin/trans nucleus
V_cs = 1.0_pReal, & !< cross slip volume
xi_sb = 1.0_pReal, & !< value for shearband resistance
v_sb = 1.0_pReal, & !< value for shearband velocity_0
E_sb = 1.0_pReal, & !< activation energy for shear bands
h = 1.0_pReal, & !< stack height of hex nucleus
gamma_char_tr = sqrt(0.125_pReal), & !< Characteristic shear for transformation
a_cF = 1.0_pReal, &
cOverA_hP = 1.0_pReal, &
V_mol = 1.0_pReal, &
rho = 1.0_pReal
Q_cl = 1.0_pReal, & !< activation energy for dislocation climb
omega = 1.0_pReal, & !< frequency factor for dislocation climb
D = 1.0_pReal, & !< grain size
p_sb = 1.0_pReal, & !< p-exponent in shear band velocity
q_sb = 1.0_pReal, & !< q-exponent in shear band velocity
i_tw = 1.0_pReal, & !< adjustment parameter to calculate MFP for twinning
i_tr = 1.0_pReal, & !< adjustment parameter to calculate MFP for transformation
L_tw = 1.0_pReal, & !< length of twin nuclei
L_tr = 1.0_pReal, & !< length of trans nuclei
x_c = 1.0_pReal, & !< critical distance for formation of twin/trans nucleus
V_cs = 1.0_pReal, & !< cross slip volume
tau_sb = 1.0_pReal, & !< value for shearband resistance
gamma_0_sb = 1.0_pReal, & !< value for shearband velocity_0
E_sb = 1.0_pReal, & !< activation energy for shear bands
h = 1.0_pReal, & !< stack height of hex nucleus
a_cF = 1.0_pReal, &
cOverA_hP = 1.0_pReal, &
V_mol = 1.0_pReal, &
rho = 1.0_pReal
type(tPolynomial) :: &
Gamma_sf, & !< stacking fault energy
Delta_G !< free energy difference between austensite and martensite
@ -331,18 +331,18 @@ module function plastic_dislotwin_init() result(myPlasticity)
!--------------------------------------------------------------------------------------------------
! shearband related parameters
prm%v_sb = pl%get_asFloat('v_sb',defaultVal=0.0_pReal)
if (prm%v_sb > 0.0_pReal) then
prm%xi_sb = pl%get_asFloat('xi_sb')
prm%gamma_0_sb = pl%get_asFloat('gamma_0_sb',defaultVal=0.0_pReal)
if (prm%gamma_0_sb > 0.0_pReal) then
prm%tau_sb = pl%get_asFloat('tau_sb')
prm%E_sb = pl%get_asFloat('Q_sb')
prm%p_sb = pl%get_asFloat('p_sb')
prm%q_sb = pl%get_asFloat('q_sb')
! sanity checks
if (prm%xi_sb < 0.0_pReal) extmsg = trim(extmsg)//' xi_sb'
if (prm%E_sb < 0.0_pReal) extmsg = trim(extmsg)//' Q_sb'
if (prm%p_sb <= 0.0_pReal) extmsg = trim(extmsg)//' p_sb'
if (prm%q_sb <= 0.0_pReal) extmsg = trim(extmsg)//' q_sb'
if (prm%tau_sb < 0.0_pReal) extmsg = trim(extmsg)//' tau_sb'
if (prm%E_sb < 0.0_pReal) extmsg = trim(extmsg)//' Q_sb'
if (prm%p_sb <= 0.0_pReal) extmsg = trim(extmsg)//' p_sb'
if (prm%q_sb <= 0.0_pReal) extmsg = trim(extmsg)//' q_sb'
end if
!--------------------------------------------------------------------------------------------------
@ -364,13 +364,13 @@ module function plastic_dislotwin_init() result(myPlasticity)
prm%h_sl_tw = lattice_interaction_SlipByTwin(N_sl,prm%N_tw,pl%get_as1dFloat('h_sl-tw'), &
phase_lattice(ph))
if (prm%fccTwinTransNucleation .and. size(prm%N_tw) /= 1) extmsg = trim(extmsg)//' N_tw: nucleation'
endif slipAndTwinActive
end if slipAndTwinActive
slipAndTransActive: if (prm%sum_N_sl * prm%sum_N_tr > 0) then
prm%h_sl_tr = lattice_interaction_SlipByTrans(N_sl,prm%N_tr,pl%get_as1dFloat('h_sl-tr'), &
phase_lattice(ph))
if (prm%fccTwinTransNucleation .and. size(prm%N_tr) /= 1) extmsg = trim(extmsg)//' N_tr: nucleation'
endif slipAndTransActive
end if slipAndTransActive
!--------------------------------------------------------------------------------------------------
! allocate state arrays
@ -430,7 +430,7 @@ module function plastic_dislotwin_init() result(myPlasticity)
!--------------------------------------------------------------------------------------------------
! exit if any parameter is out of range
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'(dislotwin)')
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg))
end do
@ -569,7 +569,7 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
Lp = Lp * f_matrix
dLp_dMp = dLp_dMp * f_matrix
shearBandingContribution: if (dNeq0(prm%v_sb)) then
shearBandingContribution: if (dNeq0(prm%gamma_0_sb)) then
E_kB_T = prm%E_sb/(K_B*T)
call math_eigh33(eigValues,eigVectors,Mp) ! is Mp symmetric by design?
@ -580,10 +580,10 @@ module subroutine dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,ph,en)
tau = math_tensordot(Mp,P_sb)
significantShearBandStress: if (abs(tau) > tol_math_check) then
StressRatio_p = (abs(tau)/prm%xi_sb)**prm%p_sb
dot_gamma_sb = sign(prm%v_sb*exp(-E_kB_T*(1-StressRatio_p)**prm%q_sb), tau)
ddot_gamma_dtau = abs(dot_gamma_sb)*E_kB_T*prm%p_sb*prm%q_sb/prm%xi_sb &
* (abs(tau)/prm%xi_sb)**(prm%p_sb-1.0_pReal) &
StressRatio_p = (abs(tau)/prm%tau_sb)**prm%p_sb
dot_gamma_sb = sign(prm%gamma_0_sb*exp(-E_kB_T*(1-StressRatio_p)**prm%q_sb), tau)
ddot_gamma_dtau = abs(dot_gamma_sb)*E_kB_T*prm%p_sb*prm%q_sb/prm%tau_sb &
* (abs(tau)/prm%tau_sb)**(prm%p_sb-1.0_pReal) &
* (1.0_pReal-StressRatio_p)**(prm%q_sb-1.0_pReal)
Lp = Lp + dot_gamma_sb * P_sb
@ -697,7 +697,7 @@ module function dislotwin_dotState(Mp,ph,en) result(dotState)
dot_f_tw = f_matrix*dot_gamma_tw/prm%gamma_char_tw
if (prm%sum_N_tr > 0) call kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,dot_gamma_tr)
dot_f_tr = f_matrix*dot_gamma_tr/prm%gamma_char_tr
dot_f_tr = f_matrix*dot_gamma_tr/gamma_char_tr
end associate
@ -912,7 +912,7 @@ pure subroutine kinetics_tw(Mp,T,abs_dot_gamma_sl,ph,en,&
real(pReal), dimension(param(ph)%sum_N_tw), optional, intent(out) :: &
ddot_gamma_dtau_tw
real :: &
real(pReal) :: &
tau, tau_r, tau_hat, &
dot_N_0, &
x0, V, &
@ -988,7 +988,7 @@ pure subroutine kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,&
real(pReal), dimension(param(ph)%sum_N_tr), optional, intent(out) :: &
ddot_gamma_dtau_tr
real :: &
real(pReal) :: &
tau, tau_r, tau_hat, &
dot_N_0, &
x0, V, &
@ -1026,9 +1026,9 @@ pure subroutine kinetics_tr(Mp,T,abs_dot_gamma_sl,ph,en,&
dP_ncs_dtau = prm%V_cs / (K_B * T) * (P_ncs - 1.0_pReal)
V = PI/4.0_pReal*dst%Lambda_tr(i,en)**2*prm%t_tr(i)
dot_gamma_tr(i) = V*dot_N_0*P_ncs*P*prm%gamma_char_tr
dot_gamma_tr(i) = V*dot_N_0*P_ncs*P*gamma_char_tr
if (present(ddot_gamma_dtau_tr)) &
ddot_gamma_dtau_tr(i) = V*dot_N_0*(P*dP_ncs_dtau + P_ncs*dP_dtau)*prm%gamma_char_tr
ddot_gamma_dtau_tr(i) = V*dot_N_0*(P*dP_ncs_dtau + P_ncs*dP_dtau)*gamma_char_tr
else
dot_gamma_tr(i) = 0.0_pReal
if (present(ddot_gamma_dtau_tr)) ddot_gamma_dtau_tr(i) = 0.0_pReal

6
src/phase_mechanical_plastic_isotropic.f90
View File

@ -69,8 +69,8 @@ module function plastic_isotropic_init() result(myPlasticity)
print'(/,1x,a)', '<<<+- phase:mechanical:plastic:isotropic init -+>>>'
print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT)
print'(/,a)', 'T. Maiti and P. Eisenlohr, Scripta Materialia 145:37–40, 2018'
print'(/,a)', 'https://doi.org/10.1016/j.scriptamat.2017.09.047'
print'(/,1x,a)', 'T. Maiti and P. Eisenlohr, Scripta Materialia 145:37–40, 2018'
print'( 1x,a)', 'https://doi.org/10.1016/j.scriptamat.2017.09.047'
phases => config_material%get('phase')
allocate(param(phases%length))
@ -135,7 +135,7 @@ module function plastic_isotropic_init() result(myPlasticity)
!--------------------------------------------------------------------------------------------------
! exit if any parameter is out of range
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'(isotropic)')
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg))
end do

2
src/phase_mechanical_plastic_kinehardening.f90
View File

@ -224,7 +224,7 @@ module function plastic_kinehardening_init() result(myPlasticity)
!--------------------------------------------------------------------------------------------------
! exit if any parameter is out of range
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'(kinehardening)')
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg))
end do

2
src/phase_mechanical_plastic_nonlocal.f90
View File

@ -504,7 +504,7 @@ module function plastic_nonlocal_init() result(myPlasticity)
!--------------------------------------------------------------------------------------------------
! exit if any parameter is out of range
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'(nonlocal)')
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg))
end do

2
src/phase_mechanical_plastic_phenopowerlaw.f90
View File

@ -269,7 +269,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
!--------------------------------------------------------------------------------------------------
! exit if any parameter is out of range
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg)//'(phenopowerlaw)')
if (extmsg /= '') call IO_error(211,ext_msg=trim(extmsg))
end do

39
src/phase_thermal.f90
View File

@ -4,8 +4,8 @@
submodule(phase) thermal
type :: tThermalParameters
real(pReal) :: C_p = 0.0_pReal !< heat capacity
real(pReal), dimension(3,3) :: K = 0.0_pReal !< thermal conductivity
real(pReal) :: C_p = 0.0_pReal !< heat capacity
real(pReal), dimension(3,3) :: K = 0.0_pReal !< thermal conductivity
character(len=pStringLen), allocatable, dimension(:) :: output
end type tThermalParameters
@ -72,7 +72,7 @@ submodule(phase) thermal
contains
!----------------------------------------------------------------------------------------------
!< @brief initializes thermal sources and kinematics mechanism
!< @brief Initializes thermal sources and kinematics mechanism.
!----------------------------------------------------------------------------------------------
module subroutine thermal_init(phases)
@ -122,31 +122,31 @@ module subroutine thermal_init(phases)
allocate(thermalstate(ph)%p(thermal_Nsources(ph)))
enddo
end do
allocate(thermal_source(maxval(thermal_Nsources),phases%length), source = THERMAL_UNDEFINED_ID)
if (maxval(thermal_Nsources) /= 0) then
where(dissipation_init (maxval(thermal_Nsources))) thermal_source = THERMAL_DISSIPATION_ID
where(externalheat_init(maxval(thermal_Nsources))) thermal_source = THERMAL_EXTERNALHEAT_ID
endif
end if
thermal_source_maxSizeDotState = 0
do ph = 1,phases%length
do so = 1,thermal_Nsources(ph)
thermalState(ph)%p(so)%state = thermalState(ph)%p(so)%state0
enddo
end do
thermal_source_maxSizeDotState = max(thermal_source_maxSizeDotState, &
maxval(thermalState(ph)%p%sizeDotState))
enddo
end do
end subroutine thermal_init
!----------------------------------------------------------------------------------------------
!< @brief calculates thermal dissipation rate
!< @brief Calculate thermal source.
!----------------------------------------------------------------------------------------------
module function phase_f_T(ph,en) result(f)
@ -170,13 +170,13 @@ module function phase_f_T(ph,en) result(f)
end select
enddo
end do
end function phase_f_T
!--------------------------------------------------------------------------------------------------
!> @brief contains the constitutive equation for calculating the rate of change of microstructure
!> @brief tbd.
!--------------------------------------------------------------------------------------------------
function phase_thermal_collectDotState(ph,en) result(broken)
@ -195,7 +195,7 @@ function phase_thermal_collectDotState(ph,en) result(broken)
broken = broken .or. any(IEEE_is_NaN(thermalState(ph)%p(i)%dotState(:,en)))
enddo SourceLoop
end do SourceLoop
end function phase_thermal_collectDotState
@ -216,7 +216,7 @@ end function phase_mu_T
!--------------------------------------------------------------------------------------------------
!> @brief Thermal conductivity/diffusivity in reference configuration.
!> @brief Thermal conductivity in reference configuration.
!--------------------------------------------------------------------------------------------------
module function phase_K_T(co,ce) result(K)
@ -255,6 +255,7 @@ function integrateThermalState(Delta_t, ph,en) result(broken)
so, &
sizeDotState
broken = phase_thermal_collectDotState(ph,en)
if (broken) return
@ -262,7 +263,7 @@ function integrateThermalState(Delta_t, ph,en) result(broken)
sizeDotState = thermalState(ph)%p(so)%sizeDotState
thermalState(ph)%p(so)%state(1:sizeDotState,en) = thermalState(ph)%p(so)%state0(1:sizeDotState,en) &
+ thermalState(ph)%p(so)%dotState(1:sizeDotState,en) * Delta_t
enddo
end do
end function integrateThermalState
@ -277,7 +278,7 @@ module subroutine thermal_restartWrite(groupHandle,ph)
do so = 1,thermal_Nsources(ph)
call HDF5_write(thermalState(ph)%p(so)%state,groupHandle,'omega_thermal')
enddo
end do
end subroutine thermal_restartWrite
@ -292,7 +293,7 @@ module subroutine thermal_restartRead(groupHandle,ph)
do so = 1,thermal_Nsources(ph)
call HDF5_read(thermalState(ph)%p(so)%state0,groupHandle,'omega_thermal')
enddo
end do
end subroutine thermal_restartRead
@ -305,8 +306,8 @@ module subroutine thermal_forward()
do ph = 1, size(thermalState)
do so = 1, size(thermalState(ph)%p)
thermalState(ph)%p(so)%state0 = thermalState(ph)%p(so)%state
enddo
enddo
end do
end do
end subroutine thermal_forward
@ -380,8 +381,8 @@ function thermal_active(source_label,src_length) result(active_source)
do s = 1, sources%length
src => sources%get(s)
active_source(s,p) = src%get_asString('type') == source_label
enddo
enddo
end do
end do
end function thermal_active

4
src/polynomials.f90
View File

@ -8,7 +8,7 @@ module polynomials
use YAML_parse
use YAML_types
implicit none
implicit none(type,external)
private
type, public :: tPolynomial
@ -112,7 +112,7 @@ pure function eval(self,x) result(y)
#else
y = IEEE_FMA(y,x-self%x_ref,self%coef(o))
#endif
enddo
end do
end function eval

2
src/prec.f90
View File

@ -15,7 +15,7 @@ module prec
use PETScSys
#endif
implicit none
implicit none(type,external)
public
! https://stevelionel.com/drfortran/2017/03/27/doctor-fortran-in-it-takes-all-kinds

16
src/quit.f90
View File

@ -12,28 +12,34 @@ subroutine quit(stop_id)
#endif
use HDF5
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
integer, intent(in) :: stop_id
integer, dimension(8) :: dateAndTime
integer :: err_HDF5
integer(MPI_INTEGER_KIND) :: err_MPI
PetscErrorCode :: err_PETSc
call h5open_f(err_HDF5)
if (err_HDF5 /= 0_MPI_INTEGER_KIND) write(6,'(a,i5)') ' Error in h5open_f ',err_HDF5 ! prevents error if not opened yet
call h5close_f(err_HDF5)
if (err_HDF5 /= 0_MPI_INTEGER_KIND) write(6,'(a,i5)') ' Error in h5close_f ',err_HDF5
call PetscFinalize(err_PETSc)
CHKERRQ(err_PETSc)
#ifdef _OPENMP
call MPI_finalize(err_MPI)
if (err_MPI /= 0_MPI_INTEGER_KIND) write(6,'(a,i5)') ' Error in MPI_finalize',err_MPI
#else
err_MPI = 0_MPI_INTEGER_KIND
#endif
call date_and_time(values = dateAndTime)
write(6,'(/,a)') ' DAMASK terminated on:'
write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',&
@ -42,7 +48,7 @@ subroutine quit(stop_id)
write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',&
dateAndTime(6),':',&
dateAndTime(7)
if (stop_id == 0 .and. &
err_HDF5 == 0 .and. &
err_MPI == 0_MPI_INTEGER_KIND .and. &

124
src/results.f90
View File

@ -21,7 +21,11 @@ module results
use DAMASK_interface
#endif
#if (PETSC_VERSION_MAJOR==3 && PETSC_VERSION_MINOR>14) && !defined(PETSC_HAVE_MPI_F90MODULE_VISIBILITY)
implicit none(type,external)
#else
implicit none
#endif
private
integer(HID_T) :: resultsFile
@ -95,11 +99,11 @@ subroutine results_init(restart)
call results_openJobFile
call get_command(commandLine)
call results_addAttribute('call (restart at '//date//')',trim(commandLine))
call h5gmove_f(resultsFile,'setup','tmp',hdferr)
call H5Gmove_f(resultsFile,'setup','tmp',hdferr)
call results_addAttribute('description','input data used to run the simulation up to restart at '//date,'tmp')
call results_closeGroup(results_addGroup('setup'))
call results_addAttribute('description','input data used to run the simulation','setup')
call h5gmove_f(resultsFile,'tmp','setup/previous',hdferr)
call H5Gmove_f(resultsFile,'tmp','setup/previous',hdferr)
end if
call results_closeJobFile
@ -333,8 +337,8 @@ subroutine results_removeLink(link)
integer :: hdferr
call h5ldelete_f(resultsFile,link, hdferr)
if (hdferr < 0) call IO_error(1,ext_msg = 'results_removeLink: h5ldelete_soft_f ('//trim(link)//')')
call H5Ldelete_f(resultsFile,link, hdferr)
if (hdferr < 0) call IO_error(1,ext_msg = 'results_removeLink: H5Ldelete_soft_f ('//trim(link)//')')
end subroutine results_removeLink
@ -522,7 +526,7 @@ subroutine results_mapping_phase(ID,entry,label)
writeSize = 0
writeSize(worldrank) = size(entry(1,:)) ! total number of entries of this process
call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr)
call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
#ifndef PETSC
@ -530,7 +534,7 @@ subroutine results_mapping_phase(ID,entry,label)
#else
!--------------------------------------------------------------------------------------------------
! MPI settings and communication
call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr)
call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call MPI_Allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get output at each process
@ -558,82 +562,82 @@ subroutine results_mapping_phase(ID,entry,label)
!---------------------------------------------------------------------------------------------------
! compound type: label(ID) + entry
call h5tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr)
call H5Tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr)
call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tget_size_f(dt_id, type_size_string, hdferr)
call H5Tget_size_f(dt_id, type_size_string, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND)
call h5tget_size_f(pI64_t, type_size_int, hdferr)
call H5Tget_size_f(pI64_t, type_size_int, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr)
call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr)
call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
!--------------------------------------------------------------------------------------------------
! create memory types for each component of the compound type
call h5tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr)
call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tcreate_f(H5T_COMPOUND_F, type_size_int, entry_id, hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_int, entry_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tinsert_f(entry_id, 'entry', 0_SIZE_T, pI64_t, hdferr)
call H5Tinsert_f(entry_id, 'entry', 0_SIZE_T, pI64_t, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tclose_f(dt_id, hdferr)
call H5Tclose_f(dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
!--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape = hyperslab) and in file (global shape)
call h5screate_simple_f(2,myShape,memspace_id,hdferr,myShape)
call H5Screate_simple_f(2,myShape,memspace_id,hdferr,myShape)
if(hdferr < 0) error stop 'HDF5 error'
call h5screate_simple_f(2,totalShape,filespace_id,hdferr,totalShape)
call H5Screate_simple_f(2,totalShape,filespace_id,hdferr,totalShape)
if(hdferr < 0) error stop 'HDF5 error'
call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, hdferr)
call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
!--------------------------------------------------------------------------------------------------
! write the components of the compound type individually
call h5pset_preserve_f(plist_id, .true., hdferr)
call H5Pset_preserve_f(plist_id, .true., hdferr)
if(hdferr < 0) error stop 'HDF5 error'
loc_id = results_openGroup('/cell_to')
call h5dcreate_f(loc_id, 'phase', dtype_id, filespace_id, dset_id, hdferr)
call H5Dcreate_f(loc_id, 'phase', dtype_id, filespace_id, dset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5dwrite_f(dset_id, label_id, reshape(label(pack(ID,.true.)),myShape), &
call H5Dwrite_f(dset_id, label_id, reshape(label(pack(ID,.true.)),myShape), &
myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error'
call h5dwrite_f(dset_id, entry_id, reshape(pack(entryGlobal,.true.),myShape), &
call H5Dwrite_f(dset_id, entry_id, reshape(pack(entryGlobal,.true.),myShape), &
myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error'
!--------------------------------------------------------------------------------------------------
! close all
call HDF5_closeGroup(loc_id)
call h5pclose_f(plist_id, hdferr)
call H5Pclose_f(plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5sclose_f(filespace_id, hdferr)
call H5Sclose_f(filespace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5sclose_f(memspace_id, hdferr)
call H5Sclose_f(memspace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5dclose_f(dset_id, hdferr)
call H5Dclose_f(dset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tclose_f(dtype_id, hdferr)
call H5Tclose_f(dtype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tclose_f(label_id, hdferr)
call H5Tclose_f(label_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tclose_f(entry_id, hdferr)
call H5Tclose_f(entry_id, hdferr)
call executionStamp('cell_to/phase','cell ID and constituent ID to phase results')
@ -678,7 +682,7 @@ subroutine results_mapping_homogenization(ID,entry,label)
writeSize = 0
writeSize(worldrank) = size(entry) ! total number of entries of this process
call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr)
call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
#ifndef PETSC
@ -686,7 +690,7 @@ subroutine results_mapping_homogenization(ID,entry,label)
#else
!--------------------------------------------------------------------------------------------------
! MPI settings and communication
call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr)
call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call MPI_Allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get output at each process
@ -710,82 +714,82 @@ subroutine results_mapping_homogenization(ID,entry,label)
!---------------------------------------------------------------------------------------------------
! compound type: label(ID) + entry
call h5tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr)
call H5Tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr)
call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tget_size_f(dt_id, type_size_string, hdferr)
call H5Tget_size_f(dt_id, type_size_string, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND)
call h5tget_size_f(pI64_t, type_size_int, hdferr)
call H5Tget_size_f(pI64_t, type_size_int, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr)
call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr)
call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
!--------------------------------------------------------------------------------------------------
! create memory types for each component of the compound type
call h5tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr)
call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tcreate_f(H5T_COMPOUND_F, type_size_int, entry_id, hdferr)
call H5Tcreate_f(H5T_COMPOUND_F, type_size_int, entry_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tinsert_f(entry_id, 'entry', 0_SIZE_T, pI64_t, hdferr)
call H5Tinsert_f(entry_id, 'entry', 0_SIZE_T, pI64_t, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tclose_f(dt_id, hdferr)
call H5Tclose_f(dt_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
!--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape = hyperslab) and in file (global shape)
call h5screate_simple_f(1,myShape,memspace_id,hdferr,myShape)
call H5Screate_simple_f(1,myShape,memspace_id,hdferr,myShape)
if(hdferr < 0) error stop 'HDF5 error'
call h5screate_simple_f(1,totalShape,filespace_id,hdferr,totalShape)
call H5Screate_simple_f(1,totalShape,filespace_id,hdferr,totalShape)
if(hdferr < 0) error stop 'HDF5 error'
call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, hdferr)
call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
!--------------------------------------------------------------------------------------------------
! write the components of the compound type individually
call h5pset_preserve_f(plist_id, .true., hdferr)
call H5Pset_preserve_f(plist_id, .true., hdferr)
if(hdferr < 0) error stop 'HDF5 error'
loc_id = results_openGroup('/cell_to')
call h5dcreate_f(loc_id, 'homogenization', dtype_id, filespace_id, dset_id, hdferr)
call H5Dcreate_f(loc_id, 'homogenization', dtype_id, filespace_id, dset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5dwrite_f(dset_id, label_id, reshape(label(pack(ID,.true.)),myShape), &
call H5Dwrite_f(dset_id, label_id, reshape(label(pack(ID,.true.)),myShape), &
myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error'
call h5dwrite_f(dset_id, entry_id, reshape(pack(entryGlobal,.true.),myShape), &
call H5Dwrite_f(dset_id, entry_id, reshape(pack(entryGlobal,.true.),myShape), &
myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error'
!--------------------------------------------------------------------------------------------------
! close all
call HDF5_closeGroup(loc_id)
call h5pclose_f(plist_id, hdferr)
call H5Pclose_f(plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5sclose_f(filespace_id, hdferr)
call H5Sclose_f(filespace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5sclose_f(memspace_id, hdferr)
call H5Sclose_f(memspace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5dclose_f(dset_id, hdferr)
call H5Dclose_f(dset_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tclose_f(dtype_id, hdferr)
call H5Tclose_f(dtype_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tclose_f(label_id, hdferr)
call H5Tclose_f(label_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call h5tclose_f(entry_id, hdferr)
call H5Tclose_f(entry_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error'
call executionStamp('cell_to/homogenization','cell ID to homogenization results')

902
src/rotations.f90
View File

File diff suppressed because it is too large Load Diff

2
src/signals.f90
View File

@ -6,7 +6,7 @@ module signals
use prec
use system_routines
implicit none
implicit none(type,external)
private
logical, volatile, public, protected :: &

21
src/system_routines.f90
View File

@ -7,7 +7,7 @@ module system_routines
use prec
implicit none
implicit none(type,external)
private
public :: &
@ -24,8 +24,10 @@ module system_routines
interface
function setCWD_C(cwd) bind(C)
use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR
implicit none(type,external)
integer(C_INT) :: setCWD_C
character(kind=C_CHAR), dimension(*), intent(in) :: cwd
@ -34,6 +36,7 @@ module system_routines
subroutine getCWD_C(cwd, stat) bind(C)
use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR
use prec
implicit none(type,external)
character(kind=C_CHAR), dimension(pPathLen+1), intent(out) :: cwd ! NULL-terminated array
integer(C_INT), intent(out) :: stat
@ -42,6 +45,7 @@ module system_routines
subroutine getHostName_C(hostname, stat) bind(C)
use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR
use prec
implicit none(type,external)
character(kind=C_CHAR), dimension(pStringLen+1), intent(out) :: hostname ! NULL-terminated array
integer(C_INT), intent(out) :: stat
@ -50,6 +54,7 @@ module system_routines
subroutine getUserName_C(username, stat) bind(C)
use, intrinsic :: ISO_C_Binding, only: C_INT, C_CHAR
use prec
implicit none(type,external)
character(kind=C_CHAR), dimension(pStringLen+1), intent(out) :: username ! NULL-terminated array
integer(C_INT), intent(out) :: stat
@ -57,27 +62,31 @@ module system_routines
subroutine signalint_C(handler) bind(C)
use, intrinsic :: ISO_C_Binding, only: C_FUNPTR
implicit none(type,external)
type(C_FUNPTR), intent(in), value :: handler
end subroutine signalint_C
subroutine signalusr1_C(handler) bind(C)
use, intrinsic :: ISO_C_Binding, only: C_FUNPTR
implicit none(type,external)
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
implicit none(type,external)
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
use, intrinsic :: ISO_C_Binding, only: C_PTR
implicit none(type,external)
type(C_PTR), value :: ptr
end subroutine free_C
end interface
@ -114,7 +123,7 @@ function getCWD()
getCWD = c_f_string(getCWD_Cstring)
else
error stop 'invalid working directory'
endif
end if
end function getCWD
@ -136,7 +145,7 @@ function getHostName()
getHostName = c_f_string(getHostName_Cstring)
else
getHostName = 'n/a (Error!)'
endif
end if
end function getHostName