diff --git a/CMakeLists.txt b/CMakeLists.txt index d24d9b8b8..6827d31b8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -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") diff --git a/LICENSE b/LICENSE index 8f9664407..11b05b50f 100644 --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/PRIVATE b/PRIVATE index 0e82975b2..cdca8ab0c 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 0e82975b23a1bd4310c523388f1cadf1b8e03dd0 +Subproject commit cdca8ab0c14b637c18279e0ea236caa148d15e5e diff --git a/VERSION b/VERSION index 00e433ed7..36fddc4d8 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -3.0.0-alpha6-395-g9696c1967 +3.0.0-alpha6-523-g66f129273 diff --git a/cmake/Compiler-GNU.cmake b/cmake/Compiler-GNU.cmake index 6eedffc21..397d1277b 100644 --- a/cmake/Compiler-GNU.cmake +++ b/cmake/Compiler-GNU.cmake @@ -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 diff --git a/cmake/Compiler-Intel.cmake b/cmake/Compiler-Intel.cmake index 7f34e4a13..4125aa8ef 100644 --- a/cmake/Compiler-Intel.cmake +++ b/cmake/Compiler-Intel.cmake @@ -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) diff --git a/cmake/Compiler-IntelLLVM.cmake b/cmake/Compiler-IntelLLVM.cmake index 883873e1c..bd0f07ee8 100644 --- a/cmake/Compiler-IntelLLVM.cmake +++ b/cmake/Compiler-IntelLLVM.cmake @@ -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) diff --git a/examples/config/phase/damage/anisobrittle_cubic.yaml b/examples/config/phase/damage/anisobrittle_cubic.yaml index 372fdc6d0..4f8db50ee 100644 --- a/examples/config/phase/damage/anisobrittle_cubic.yaml +++ b/examples/config/phase/damage/anisobrittle_cubic.yaml @@ -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 diff --git a/examples/config/phase/damage/isobrittle_generic.yaml b/examples/config/phase/damage/isobrittle_generic.yaml index 851302a49..64a51fa42 100644 --- a/examples/config/phase/damage/isobrittle_generic.yaml +++ b/examples/config/phase/damage/isobrittle_generic.yaml @@ -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 diff --git a/examples/config/phase/mechanical/plastic/dislotwin_alpha-Brass-shearbanding.yaml b/examples/config/phase/mechanical/plastic/dislotwin_alpha-Brass-shearbanding.yaml new file mode 100644 index 000000000..414be0b85 --- /dev/null +++ b/examples/config/phase/mechanical/plastic/dislotwin_alpha-Brass-shearbanding.yaml @@ -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 diff --git a/install/MarcMentat/2021.3.1/Marc_tools/include_linux64.patch b/install/MarcMentat/2021.3.1/Marc_tools/include_linux64.patch index 5d78b22f8..a90c60aa6 100644 --- a/install/MarcMentat/2021.3.1/Marc_tools/include_linux64.patch +++ b/install/MarcMentat/2021.3.1/Marc_tools/include_linux64.patch @@ -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 diff --git a/install/MarcMentat/2022.1/Marc_tools/include_linux64.patch b/install/MarcMentat/2022.1/Marc_tools/include_linux64.patch index 8cf6d2113..d11e84f1a 100644 --- a/install/MarcMentat/2022.1/Marc_tools/include_linux64.patch +++ b/install/MarcMentat/2022.1/Marc_tools/include_linux64.patch @@ -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" diff --git a/install/MarcMentat/apply_DAMASK_modifications.py b/install/MarcMentat/apply_DAMASK_modifications.py index a17120895..353df955e 100755 --- a/install/MarcMentat/apply_DAMASK_modifications.py +++ b/install/MarcMentat/apply_DAMASK_modifications.py @@ -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...') diff --git a/python/damask/_colormap.py b/python/damask/_colormap.py index 5253e0acb..688070529 100644 --- a/python/damask/_colormap.py +++ b/python/damask/_colormap.py @@ -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) diff --git a/python/damask/_config.py b/python/damask/_config.py index ff889bf5d..06ac13894 100644 --- a/python/damask/_config.py +++ b/python/damask/_config.py @@ -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) diff --git a/python/damask/_crystal.py b/python/damask/_crystal.py index 05a3d3384..fb2dc3438 100644 --- a/python/damask/_crystal.py +++ b/python/damask/_crystal.py @@ -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 ---------- diff --git a/python/damask/_grid.py b/python/damask/_grid.py index 4e82a4180..e5c36413f 100644 --- a/python/damask/_grid.py +++ b/python/damask/_grid.py @@ -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 diff --git a/python/damask/_orientation.py b/python/damask/_orientation.py index dcc139b7c..f60772901 100644 --- a/python/damask/_orientation.py +++ b/python/damask/_orientation.py @@ -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 diff --git a/python/damask/_result.py b/python/damask/_result.py index 1ad25bdbf..d991e898c 100644 --- a/python/damask/_result.py +++ b/python/damask/_result.py @@ -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: diff --git a/python/damask/_rotation.py b/python/damask/_rotation.py index 61529eb46..229e1324e 100644 --- a/python/damask/_rotation.py +++ b/python/damask/_rotation.py @@ -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]) \ diff --git a/python/damask/_table.py b/python/damask/_table.py index 78d7ddcb9..6e7dcf146 100644 --- a/python/damask/_table.py +++ b/python/damask/_table.py @@ -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, ) diff --git a/python/damask/_vtk.py b/python/damask/_vtk.py index c41470638..46d779023 100644 --- a/python/damask/_vtk.py +++ b/python/damask/_vtk.py @@ -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 diff --git a/python/damask/seeds.py b/python/damask/seeds.py index a4ddfb418..11be5cc93 100644 --- a/python/damask/seeds.py +++ b/python/damask/seeds.py @@ -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 diff --git a/python/damask/solver/_marc.py b/python/damask/solver/_marc.py index 8b7f7acba..51c65a695 100644 --- a/python/damask/solver/_marc.py +++ b/python/damask/solver/_marc.py @@ -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)') diff --git a/python/damask/util.py b/python/damask/util.py index 1ab58e8b6..ec42dede0 100644 --- a/python/damask/util.py +++ b/python/damask/util.py @@ -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() diff --git a/python/tests/test_Orientation.py b/python/tests/test_Orientation.py index 5f9b83e70..2cb97d252 100644 --- a/python/tests/test_Orientation.py +++ b/python/tests/test_Orientation.py @@ -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) diff --git a/python/tests/test_Rotation.py b/python/tests/test_Rotation.py index c9dfc68b8..8b1bd0de8 100644 --- a/python/tests/test_Rotation.py +++ b/python/tests/test_Rotation.py @@ -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): diff --git a/src/CLI.f90 b/src/CLI.f90 index ff3d7349f..ee1555cb2 100644 --- a/src/CLI.f90 +++ b/src/CLI.f90 @@ -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)) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index fcd2c189a..ee1e3cf8c 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -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' diff --git a/src/IO.f90 b/src/IO.f90 index 047d11add..31bb0ed2d 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -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 : pair' + msg = 'space expected after a colon for : 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' diff --git a/src/LAPACK_interface.f90 b/src/LAPACK_interface.f90 index e11f74875..cc451b59c 100644 --- a/src/LAPACK_interface.f90 +++ b/src/LAPACK_interface.f90 @@ -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 diff --git a/src/Marc/DAMASK_Marc.f90 b/src/Marc/DAMASK_Marc.f90 index 28cdf9223..c1f5b1d68 100644 --- a/src/Marc/DAMASK_Marc.f90 +++ b/src/Marc/DAMASK_Marc.f90 @@ -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 diff --git a/src/Marc/discretization_Marc.f90 b/src/Marc/discretization_Marc.f90 index c1525b05e..a0667d049 100644 --- a/src/Marc/discretization_Marc.f90 +++ b/src/Marc/discretization_Marc.f90 @@ -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 diff --git a/src/Marc/element.f90 b/src/Marc/element.f90 index 295a41547..2940704bd 100644 --- a/src/Marc/element.f90 +++ b/src/Marc/element.f90 @@ -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 diff --git a/src/Marc/materialpoint_Marc.f90 b/src/Marc/materialpoint_Marc.f90 index 79b06b80d..72c718a87 100644 --- a/src/Marc/materialpoint_Marc.f90 +++ b/src/Marc/materialpoint_Marc.f90 @@ -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) diff --git a/src/YAML_parse.f90 b/src/YAML_parse.f90 index bfce06bc9..e7d64770d 100644 --- a/src/YAML_parse.f90 +++ b/src/YAML_parse.f90 @@ -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 diff --git a/src/YAML_types.f90 b/src/YAML_types.f90 index 857b24bd0..e9bdff88d 100644 --- a/src/YAML_types.f90 +++ b/src/YAML_types.f90 @@ -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 diff --git a/src/config.f90 b/src/config.f90 index 78723c19f..5c31e3b25 100644 --- a/src/config.f90 +++ b/src/config.f90 @@ -9,7 +9,7 @@ module config use results use parallelization - implicit none + implicit none(type,external) private class(tNode), pointer, public :: & diff --git a/src/constants.f90 b/src/constants.f90 index 1effb8d95..7d1892e9d 100644 --- a/src/constants.f90 +++ b/src/constants.f90 @@ -5,7 +5,7 @@ module constants use prec - implicit none + implicit none(type,external) public real(pReal), parameter :: & diff --git a/src/discretization.f90 b/src/discretization.f90 index 5f4d1c5a6..f24b0eadf 100644 --- a/src/discretization.f90 +++ b/src/discretization.f90 @@ -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 diff --git a/src/geometry_plastic_nonlocal.f90 b/src/geometry_plastic_nonlocal.f90 index 571ca2e6a..09c40f8b3 100644 --- a/src/geometry_plastic_nonlocal.f90 +++ b/src/geometry_plastic_nonlocal.f90 @@ -9,7 +9,7 @@ module geometry_plastic_nonlocal use prec use results - implicit none + implicit none(type,external) public integer, protected :: & diff --git a/src/grid/DAMASK_grid.f90 b/src/grid/DAMASK_grid.f90 index 824d867c5..4395c1581 100644 --- a/src/grid/DAMASK_grid.f90 +++ b/src/grid/DAMASK_grid.f90 @@ -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 diff --git a/src/grid/FFTW.f90 b/src/grid/FFTW.f90 new file mode 100644 index 000000000..5df432061 --- /dev/null +++ b/src/grid/FFTW.f90 @@ -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 diff --git a/src/grid/VTI.f90 b/src/grid/VTI.f90 index a5918137e..72f57fb86 100644 --- a/src/grid/VTI.f90 +++ b/src/grid/VTI.f90 @@ -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 diff --git a/src/grid/base64.f90 b/src/grid/base64.f90 index 448f57d2a..6e580f043 100644 --- a/src/grid/base64.f90 +++ b/src/grid/base64.f90 @@ -7,7 +7,7 @@ module base64 use prec use IO - implicit none + implicit none(type,external) private character(len=*), parameter :: & diff --git a/src/grid/discretization_grid.f90 b/src/grid/discretization_grid.f90 index ddb36a246..158ee0a8d 100644 --- a/src/grid/discretization_grid.f90 +++ b/src/grid/discretization_grid.f90 @@ -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 diff --git a/src/grid/grid_damage_spectral.f90 b/src/grid/grid_damage_spectral.f90 index dc21a1a2c..8b544ec87 100644 --- a/src/grid/grid_damage_spectral.f90 +++ b/src/grid/grid_damage_spectral.f90 @@ -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 diff --git a/src/grid/grid_mech_FEM.f90 b/src/grid/grid_mech_FEM.f90 index 53d788987..4bb705807 100644 --- a/src/grid/grid_mech_FEM.f90 +++ b/src/grid/grid_mech_FEM.f90 @@ -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 diff --git a/src/grid/grid_mech_spectral_basic.f90 b/src/grid/grid_mech_spectral_basic.f90 index c0b85d00e..dec677df8 100644 --- a/src/grid/grid_mech_spectral_basic.f90 +++ b/src/grid/grid_mech_spectral_basic.f90 @@ -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 diff --git a/src/grid/grid_mech_spectral_polarisation.f90 b/src/grid/grid_mech_spectral_polarisation.f90 index ec27c7390..d0d229c46 100644 --- a/src/grid/grid_mech_spectral_polarisation.f90 +++ b/src/grid/grid_mech_spectral_polarisation.f90 @@ -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 diff --git a/src/grid/grid_thermal_spectral.f90 b/src/grid/grid_thermal_spectral.f90 index 8483fe336..ff0c5b403 100644 --- a/src/grid/grid_thermal_spectral.f90 +++ b/src/grid/grid_thermal_spectral.f90 @@ -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 diff --git a/src/grid/spectral_utilities.f90 b/src/grid/spectral_utilities.f90 index c8321f83f..f5e1642cc 100644 --- a/src/grid/spectral_utilities.f90 +++ b/src/grid/spectral_utilities.f90 @@ -4,13 +4,12 @@ !> @brief Utilities used by the different spectral solver variants !-------------------------------------------------------------------------------------------------- module spectral_utilities - use, intrinsic :: iso_c_binding - #include 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 !< - aim + real(pReal), dimension(3,3) :: fieldDiff !< - 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' diff --git a/src/grid/zlib.f90 b/src/grid/zlib.f90 index 21428255c..f0fc274ed 100644 --- a/src/grid/zlib.f90 +++ b/src/grid/zlib.f90 @@ -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 diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 203c7bb1c..b1e462794 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -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 diff --git a/src/homogenization_damage.f90 b/src/homogenization_damage.f90 index 6ae4ac07a..3363408d0 100644 --- a/src/homogenization_damage.f90 +++ b/src/homogenization_damage.f90 @@ -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 diff --git a/src/homogenization_mechanical_RGC.f90 b/src/homogenization_mechanical_RGC.f90 index c74b9fb6c..8e8ae1df9 100644 --- a/src/homogenization_mechanical_RGC.f90 +++ b/src/homogenization_mechanical_RGC.f90 @@ -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 diff --git a/src/homogenization_thermal.f90 b/src/homogenization_thermal.f90 index e9c9d2195..ceed47365 100644 --- a/src/homogenization_thermal.f90 +++ b/src/homogenization_thermal.f90 @@ -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))) diff --git a/src/lattice.f90 b/src/lattice.f90 index afff2a309..7bd846d0f 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -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))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 diff --git a/src/material.f90 b/src/material.f90 index eafc411cd..1ec844382 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -14,7 +14,7 @@ module material use discretization use YAML_types - implicit none + implicit none(type,external) private type, public :: tRotationContainer diff --git a/src/materialpoint.f90 b/src/materialpoint.f90 index d83307738..5b8b690e0 100644 --- a/src/materialpoint.f90 +++ b/src/materialpoint.f90 @@ -31,7 +31,7 @@ module materialpoint use discretization_grid #endif - implicit none + implicit none(type,external) public contains diff --git a/src/math.f90 b/src/math.f90 index 25c90ccf4..07b657cab 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -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 diff --git a/src/mesh/DAMASK_mesh.f90 b/src/mesh/DAMASK_mesh.f90 index f0f2a872e..5489ac36e 100644 --- a/src/mesh/DAMASK_mesh.f90 +++ b/src/mesh/DAMASK_mesh.f90 @@ -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 diff --git a/src/mesh/FEM_quadrature.f90 b/src/mesh/FEM_quadrature.f90 index f519dc377..a2217847a 100644 --- a/src/mesh/FEM_quadrature.f90 +++ b/src/mesh/FEM_quadrature.f90 @@ -5,7 +5,7 @@ module FEM_quadrature use prec - implicit none + implicit none(type,external) private integer, parameter :: & diff --git a/src/mesh/FEM_utilities.f90 b/src/mesh/FEM_utilities.f90 index 4e31a0475..c97c2bbe2 100644 --- a/src/mesh/FEM_utilities.f90 +++ b/src/mesh/FEM_utilities.f90 @@ -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 diff --git a/src/mesh/discretization_mesh.f90 b/src/mesh/discretization_mesh.f90 index b898c4e6b..a53c50655 100644 --- a/src/mesh/discretization_mesh.f90 +++ b/src/mesh/discretization_mesh.f90 @@ -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 diff --git a/src/mesh/mesh_mech_FEM.f90 b/src/mesh/mesh_mech_FEM.f90 index 5f02011eb..3b162d97b 100644 --- a/src/mesh/mesh_mech_FEM.f90 +++ b/src/mesh/mesh_mech_FEM.f90 @@ -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) diff --git a/src/parallelization.f90 b/src/parallelization.f90 index 8cc6d3abb..5c7e9bff3 100644 --- a/src/parallelization.f90 +++ b/src/parallelization.f90 @@ -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) diff --git a/src/phase.f90 b/src/phase.f90 index 2ce559a99..f304707b9 100644 --- a/src/phase.f90 +++ b/src/phase.f90 @@ -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? diff --git a/src/phase_damage.f90 b/src/phase_damage.f90 index 9022131e2..7211f2db5 100644 --- a/src/phase_damage.f90 +++ b/src/phase_damage.f90 @@ -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 diff --git a/src/phase_damage_anisobrittle.f90 b/src/phase_damage_anisobrittle.f90 index f193119eb..167d0829b 100644 --- a/src/phase_damage_anisobrittle.f90 +++ b/src/phase_damage_anisobrittle.f90 @@ -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 diff --git a/src/phase_damage_isobrittle.f90 b/src/phase_damage_isobrittle.f90 index 2d501b58f..76b382d62 100644 --- a/src/phase_damage_isobrittle.f90 +++ b/src/phase_damage_isobrittle.f90 @@ -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 diff --git a/src/phase_mechanical.f90 b/src/phase_mechanical.f90 index 88b86a8d9..3a66bdf95 100644 --- a/src/phase_mechanical.f90 +++ b/src/phase_mechanical.f90 @@ -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') diff --git a/src/phase_mechanical_eigen.f90 b/src/phase_mechanical_eigen.f90 index f0b86319c..4cd02d090 100644 --- a/src/phase_mechanical_eigen.f90 +++ b/src/phase_mechanical_eigen.f90 @@ -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) diff --git a/src/phase_mechanical_plastic.f90 b/src/phase_mechanical_plastic.f90 index 15a8ae2a7..6469c6e45 100644 --- a/src/phase_mechanical_plastic.f90 +++ b/src/phase_mechanical_plastic.f90 @@ -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 diff --git a/src/phase_mechanical_plastic_dislotungsten.f90 b/src/phase_mechanical_plastic_dislotungsten.f90 index 5a6ac8f5c..9e72a1ebd 100644 --- a/src/phase_mechanical_plastic_dislotungsten.f90 +++ b/src/phase_mechanical_plastic_dislotungsten.f90 @@ -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 diff --git a/src/phase_mechanical_plastic_dislotwin.f90 b/src/phase_mechanical_plastic_dislotwin.f90 index 3ecd13cc7..f01a7e95d 100644 --- a/src/phase_mechanical_plastic_dislotwin.f90 +++ b/src/phase_mechanical_plastic_dislotwin.f90 @@ -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 diff --git a/src/phase_mechanical_plastic_isotropic.f90 b/src/phase_mechanical_plastic_isotropic.f90 index 49efc9fae..c855f5c25 100644 --- a/src/phase_mechanical_plastic_isotropic.f90 +++ b/src/phase_mechanical_plastic_isotropic.f90 @@ -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 diff --git a/src/phase_mechanical_plastic_kinehardening.f90 b/src/phase_mechanical_plastic_kinehardening.f90 index 0f6bd53d4..bc8c7df4e 100644 --- a/src/phase_mechanical_plastic_kinehardening.f90 +++ b/src/phase_mechanical_plastic_kinehardening.f90 @@ -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 diff --git a/src/phase_mechanical_plastic_nonlocal.f90 b/src/phase_mechanical_plastic_nonlocal.f90 index dbc02b7a4..4995f15d2 100644 --- a/src/phase_mechanical_plastic_nonlocal.f90 +++ b/src/phase_mechanical_plastic_nonlocal.f90 @@ -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 diff --git a/src/phase_mechanical_plastic_phenopowerlaw.f90 b/src/phase_mechanical_plastic_phenopowerlaw.f90 index 0b018562c..f0dc04869 100644 --- a/src/phase_mechanical_plastic_phenopowerlaw.f90 +++ b/src/phase_mechanical_plastic_phenopowerlaw.f90 @@ -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 diff --git a/src/phase_thermal.f90 b/src/phase_thermal.f90 index 2aab37529..ed374e142 100644 --- a/src/phase_thermal.f90 +++ b/src/phase_thermal.f90 @@ -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 diff --git a/src/polynomials.f90 b/src/polynomials.f90 index c883528ca..eeb4152f2 100644 --- a/src/polynomials.f90 +++ b/src/polynomials.f90 @@ -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 diff --git a/src/prec.f90 b/src/prec.f90 index 73563d4f2..963391c39 100644 --- a/src/prec.f90 +++ b/src/prec.f90 @@ -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 diff --git a/src/quit.f90 b/src/quit.f90 index 3c5f5e6f2..4fc6bf11b 100644 --- a/src/quit.f90 +++ b/src/quit.f90 @@ -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. & diff --git a/src/results.f90 b/src/results.f90 index bd7f7d34d..17efc87e3 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -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') diff --git a/src/rotations.f90 b/src/rotations.f90 index 5367f2c07..5c8677c81 100644 --- a/src/rotations.f90 +++ b/src/rotations.f90 @@ -27,7 +27,7 @@ ! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ! ################################################################### -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @brief rotation storage and conversion @@ -44,13 +44,13 @@ ! Convention 5: the rotation angle ω is limited to the interval [0, π] ! Convention 6: the real part of a quaternion is positive, Re(q) > 0 ! Convention 7: P = -1 -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- module rotations use IO use math - implicit none + implicit none(type,external) private real(pReal), parameter :: P = -1.0_pReal !< parameter for orientation conversion. @@ -61,7 +61,6 @@ module rotations procedure, public :: asQuaternion procedure, public :: asEulers procedure, public :: asAxisAngle - procedure, public :: asRodrigues procedure, public :: asMatrix !------------------------------------------ procedure, public :: fromQuaternion @@ -112,77 +111,64 @@ subroutine rotations_init end subroutine rotations_init -!--------------------------------------------------------------------------------------------------- -! Return rotation in different representations -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- +! Return rotation in different representations. +!-------------------------------------------------------------------------------------------------- pure function asQuaternion(self) class(tRotation), intent(in) :: self real(pReal), dimension(4) :: asQuaternion + asQuaternion = self%q end function asQuaternion -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- pure function asEulers(self) class(tRotation), intent(in) :: self real(pReal), dimension(3) :: asEulers + asEulers = qu2eu(self%q) end function asEulers -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- pure function asAxisAngle(self) class(tRotation), intent(in) :: self real(pReal), dimension(4) :: asAxisAngle + asAxisAngle = qu2ax(self%q) end function asAxisAngle -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- pure function asMatrix(self) class(tRotation), intent(in) :: self real(pReal), dimension(3,3) :: asMatrix + asMatrix = qu2om(self%q) end function asMatrix -!--------------------------------------------------------------------------------------------------- -pure function asRodrigues(self) - class(tRotation), intent(in) :: self - real(pReal), dimension(4) :: asRodrigues - - asRodrigues = qu2ro(self%q) - -end function asRodrigues -!--------------------------------------------------------------------------------------------------- -pure function asHomochoric(self) - - class(tRotation), intent(in) :: self - real(pReal), dimension(3) :: asHomochoric - - asHomochoric = qu2ho(self%q) - -end function asHomochoric - -!--------------------------------------------------------------------------------------------------- -! Initialize rotation from different representations -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- +! Initialize rotation from different representations. +!-------------------------------------------------------------------------------------------------- subroutine fromQuaternion(self,qu) class(tRotation), intent(out) :: self real(pReal), dimension(4), intent(in) :: qu + if (dNeq(norm2(qu),1.0_pReal,1.0e-8_pReal)) call IO_error(402,ext_msg='fromQuaternion') self%q = qu end subroutine fromQuaternion -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- subroutine fromEulers(self,eu,degrees) class(tRotation), intent(out) :: self @@ -191,11 +177,12 @@ subroutine fromEulers(self,eu,degrees) real(pReal), dimension(3) :: Eulers + if (.not. present(degrees)) then Eulers = eu else Eulers = merge(eu*INRAD,eu,degrees) - endif + end if if (any(Eulers<0.0_pReal) .or. any(Eulers>TAU) .or. Eulers(2) > PI) & call IO_error(402,ext_msg='fromEulers') @@ -203,7 +190,7 @@ subroutine fromEulers(self,eu,degrees) self%q = eu2qu(Eulers) end subroutine fromEulers -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- subroutine fromAxisAngle(self,ax,degrees,P) class(tRotation), intent(out) :: self @@ -214,18 +201,19 @@ subroutine fromAxisAngle(self,ax,degrees,P) real(pReal) :: angle real(pReal),dimension(3) :: axis + if (.not. present(degrees)) then angle = ax(4) else angle = merge(ax(4)*INRAD,ax(4),degrees) - endif + end if if (.not. present(P)) then axis = ax(1:3) else axis = ax(1:3) * merge(-1.0_pReal,1.0_pReal,P == 1) if(abs(P) /= 1) call IO_error(402,ext_msg='fromAxisAngle (P)') - endif + end if if(dNeq(norm2(axis),1.0_pReal) .or. angle < 0.0_pReal .or. angle > PI) & call IO_error(402,ext_msg='fromAxisAngle') @@ -233,51 +221,54 @@ subroutine fromAxisAngle(self,ax,degrees,P) self%q = ax2qu([axis,angle]) end subroutine fromAxisAngle -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- subroutine fromMatrix(self,om) class(tRotation), intent(out) :: self real(pReal), dimension(3,3), intent(in) :: om + if (dNeq(math_det33(om),1.0_pReal,tol=1.0e-5_pReal)) & call IO_error(402,ext_msg='fromMatrix') self%q = om2qu(om) end subroutine fromMatrix -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- -!--------------------------------------------------------------------------------------------------- -!> @brief: Rotate a rotation -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- +!> @brief: Compose rotations. +!-------------------------------------------------------------------------------------------------- pure elemental function rotRot__(self,R) result(rRot) type(tRotation) :: rRot class(tRotation), intent(in) :: self,R - rRot = tRotation(multiply_quaternion(self%q,R%q)) + + rRot = tRotation(multiplyQuaternion(self%q,R%q)) call rRot%standardize() end function rotRot__ -!--------------------------------------------------------------------------------------------------- -!> @brief quaternion representation with positive q -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- +!> @brief Convert to quaternion representation with positive q(1). +!-------------------------------------------------------------------------------------------------- pure elemental subroutine standardize(self) class(tRotation), intent(inout) :: self + if (sign(1.0_pReal,self%q(1)) < 0.0_pReal) self%q = - self%q end subroutine standardize -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University !> @brief Rotate a vector passively (default) or actively. -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- pure function rotVector(self,v,active) result(vRot) real(pReal), dimension(3) :: vRot @@ -288,32 +279,31 @@ pure function rotVector(self,v,active) result(vRot) real(pReal), dimension(4) :: v_normed, q logical :: passive + if (present(active)) then passive = .not. active else passive = .true. - endif + end if if (dEq0(norm2(v))) then vRot = v else v_normed = [0.0_pReal,v]/norm2(v) - if (passive) then - q = multiply_quaternion(self%q, multiply_quaternion(v_normed, conjugate_quaternion(self%q))) - else - q = multiply_quaternion(conjugate_quaternion(self%q), multiply_quaternion(v_normed, self%q)) - endif + q = merge(multiplyQuaternion(self%q, multiplyQuaternion(v_normed, conjugateQuaternion(self%q))), & + multiplyQuaternion(conjugateQuaternion(self%q), multiplyQuaternion(v_normed, self%q)), & + passive) vRot = q(2:4)*norm2(v) - endif + end if end function rotVector -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University !> @brief Rotate a rank-2 tensor passively (default) or actively. !> @details: Rotation is based on rotation matrix -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- pure function rotTensor2(self,T,active) result(tRot) real(pReal), dimension(3,3) :: tRot @@ -328,7 +318,7 @@ pure function rotTensor2(self,T,active) result(tRot) passive = .not. active else passive = .true. - endif + end if tRot = merge(matmul(matmul(self%asMatrix(),T),transpose(self%asMatrix())), & matmul(matmul(transpose(self%asMatrix()),T),self%asMatrix()), & @@ -337,11 +327,11 @@ pure function rotTensor2(self,T,active) result(tRot) end function rotTensor2 -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @brief Rotate a rank-4 tensor passively (default) or actively. !> @details: rotation is based on rotation matrix !! ToDo: Need to check active/passive !!! -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- pure function rotTensor4(self,T,active) result(tRot) real(pReal), dimension(3,3,3,3) :: tRot @@ -357,23 +347,23 @@ pure function rotTensor4(self,T,active) result(tRot) R = merge(transpose(self%asMatrix()),self%asMatrix(),active) else R = self%asMatrix() - endif + end if tRot = 0.0_pReal do i = 1,3;do j = 1,3;do k = 1,3;do l = 1,3 do m = 1,3;do n = 1,3;do o = 1,3;do p = 1,3 tRot(i,j,k,l) = tRot(i,j,k,l) & + R(i,m) * R(j,n) * R(k,o) * R(l,p) * T(m,n,o,p) - enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo + end do; end do; end do; end do; end do; end do; end do; end do end function rotTensor4 -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @brief Rotate a rank-4 stiffness tensor in Voigt 6x6 notation passively (default) or actively. !> @details: https://scicomp.stackexchange.com/questions/35600 !! ToDo: Need to check active/passive !!! -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- pure function rotStiffness(self,C,active) result(cRot) real(pReal), dimension(6,6) :: cRot @@ -389,7 +379,7 @@ pure function rotStiffness(self,C,active) result(cRot) R = merge(transpose(self%asMatrix()),self%asMatrix(),active) else R = self%asMatrix() - endif + end if M = reshape([R(1,1)**2, R(2,1)**2, R(3,1)**2, & R(2,1)*R(3,1), R(1,1)*R(3,1), R(1,1)*R(2,1), & @@ -409,24 +399,24 @@ pure function rotStiffness(self,C,active) result(cRot) end function rotStiffness -!--------------------------------------------------------------------------------------------------- -!> @brief Misorientation. -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- +!> @brief Calculate misorientation. +!-------------------------------------------------------------------------------------------------- pure elemental function misorientation(self,other) type(tRotation) :: misorientation class(tRotation), intent(in) :: self, other - misorientation%q = multiply_quaternion(other%q, conjugate_quaternion(self%q)) + misorientation%q = multiplyQuaternion(other%q, conjugateQuaternion(self%q)) end function misorientation -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University !> @brief Convert unit quaternion to rotation matrix. -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- pure function qu2om(qu) result(om) real(pReal), intent(in), dimension(4) :: qu @@ -454,10 +444,10 @@ pure function qu2om(qu) result(om) end function qu2om -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University -!> @brief Convert unit quaternion to Euler angles. -!--------------------------------------------------------------------------------------------------- +!> @brief Convert unit quaternion to Bunge Euler angles. +!-------------------------------------------------------------------------------------------------- pure function qu2eu(qu) result(eu) real(pReal), intent(in), dimension(4) :: qu @@ -478,16 +468,16 @@ pure function qu2eu(qu) result(eu) eu = [atan2((-P*qu(1)*qu(3)+qu(2)*qu(4))*chi, (-P*qu(1)*qu(2)-qu(3)*qu(4))*chi ), & atan2( 2.0_pReal*chi, q03-q12 ), & atan2(( P*qu(1)*qu(3)+qu(2)*qu(4))*chi, (-P*qu(1)*qu(2)+qu(3)*qu(4))*chi )] - endif degenerated + end if degenerated where(sign(1.0_pReal,eu)<0.0_pReal) eu = mod(eu+TAU,[TAU,PI,TAU]) end function qu2eu -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University -!> @brief convert unit quaternion to axis angle pair -!--------------------------------------------------------------------------------------------------- +!> @brief Convert unit quaternion to axis-angle pair. +!-------------------------------------------------------------------------------------------------- pure function qu2ax(qu) result(ax) real(pReal), intent(in), dimension(4) :: qu @@ -495,6 +485,7 @@ pure function qu2ax(qu) result(ax) real(pReal) :: omega, s + if (dEq0(sum(qu(2:4)**2))) then ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] ! axis = [001] elseif (dNeq0(qu(1))) then @@ -508,76 +499,11 @@ pure function qu2ax(qu) result(ax) end function qu2ax -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert unit quaternion to Rodrigues vector -!--------------------------------------------------------------------------------------------------- -pure function qu2ro(qu) result(ro) - - real(pReal), intent(in), dimension(4) :: qu - real(pReal), dimension(4) :: ro - - real(pReal) :: s - real(pReal), parameter :: thr = 1.0e-8_pReal - - if (abs(qu(1)) < thr) then - ro = [qu(2), qu(3), qu(4), IEEE_value(1.0_pReal,IEEE_positive_inf)] - else - s = norm2(qu(2:4)) - if (s < thr) then - ro = [0.0_pReal, 0.0_pReal, P, 0.0_pReal] - else - ro = [qu(2)/s,qu(3)/s,qu(4)/s, tan(acos(math_clip(qu(1),-1.0_pReal,1.0_pReal)))] - endif - - end if - -end function qu2ro - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert unit quaternion to homochoric -!--------------------------------------------------------------------------------------------------- -pure function qu2ho(qu) result(ho) - - real(pReal), intent(in), dimension(4) :: qu - real(pReal), dimension(3) :: ho - - real(pReal) :: omega, f - - omega = 2.0 * acos(math_clip(qu(1),-1.0_pReal,1.0_pReal)) - - if (dEq0(omega,tol=1.e-5_pReal)) then - ho = [ 0.0_pReal, 0.0_pReal, 0.0_pReal ] - else - ho = qu(2:4) - f = 0.75_pReal * ( omega - sin(omega) ) - ho = ho/norm2(ho)* f**(1.0_pReal/3.0_pReal) - end if - -end function qu2ho - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert unit quaternion to cubochoric -!--------------------------------------------------------------------------------------------------- -pure function qu2cu(qu) result(cu) - - real(pReal), intent(in), dimension(4) :: qu - real(pReal), dimension(3) :: cu - - cu = ho2cu(qu2ho(qu)) - -end function qu2cu - - -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @brief convert rotation matrix to unit quaternion +!> @brief Convert rotation matrix to unit quaternion. !> @details the original formulation (direct conversion) had (numerical?) issues -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- pure function om2qu(om) result(qu) real(pReal), intent(in), dimension(3,3) :: om @@ -586,6 +512,7 @@ pure function om2qu(om) result(qu) real(pReal) :: trace,s trace = math_trace33(om) + if(trace > 0.0_pReal) then s = 0.5_pReal / sqrt(trace+1.0_pReal) qu = [0.25_pReal/s, (om(3,2)-om(2,3))*s,(om(1,3)-om(3,1))*s,(om(2,1)-om(1,2))*s] @@ -599,8 +526,8 @@ pure function om2qu(om) result(qu) else s = 2.0_pReal * sqrt( 1.0_pReal + om(3,3) - om(1,1) - om(2,2) ) qu = [ (om(2,1) - om(1,2)) /s,(om(1,3) + om(3,1)) / s,(om(2,3) + om(3,2)) / s,0.25_pReal * s] - endif - endif + end if + end if if(sign(1.0_pReal,qu(1))<0.0_pReal) qu =-1.0_pReal * qu qu(2:4) = merge(qu(2:4),qu(2:4)*P,dEq0(qu(2:4))) qu = qu/norm2(qu) @@ -608,17 +535,18 @@ pure function om2qu(om) result(qu) end function om2qu -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University -!> @brief convert orientation matrix to Euler angles +!> @brief Convert orientation matrix to Bunge Euler angles. !> @details Two step check for special cases to avoid invalid operations (not needed for python) -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- pure function om2eu(om) result(eu) real(pReal), intent(in), dimension(3,3) :: om real(pReal), dimension(3) :: eu real(pReal) :: zeta + if (dNeq(abs(om(3,3)),1.0_pReal,1.e-8_pReal)) then zeta = 1.0_pReal/sqrt(math_clip(1.0_pReal-om(3,3)**2,1e-64_pReal,1.0_pReal)) eu = [atan2(om(3,1)*zeta,-om(3,2)*zeta), & @@ -633,10 +561,10 @@ pure function om2eu(om) result(eu) end function om2eu -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University -!> @brief convert orientation matrix to axis angle pair -!--------------------------------------------------------------------------------------------------- +!> @brief Convert orientation matrix to axis-angle pair. +!-------------------------------------------------------------------------------------------------- function om2ax(om) result(ax) real(pReal), intent(in), dimension(3,3) :: om @@ -648,6 +576,7 @@ function om2ax(om) result(ax) real(pReal), dimension(3,3) :: VR, devNull, om_ integer :: ierr, i + om_ = om ! first get the rotation angle @@ -664,57 +593,15 @@ function om2ax(om) result(ax) ax(1:3) = VR(1:3,i) where ( dNeq0([om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)])) & ax(1:3) = sign(ax(1:3),-P *[om(2,3)-om(3,2), om(3,1)-om(1,3), om(1,2)-om(2,1)]) - endif + end if end function om2ax -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University -!> @brief convert rotation matrix to Rodrigues vector -!--------------------------------------------------------------------------------------------------- -pure function om2ro(om) result(ro) - - real(pReal), intent(in), dimension(3,3) :: om - real(pReal), dimension(4) :: ro - - ro = eu2ro(om2eu(om)) - -end function om2ro - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert rotation matrix to homochoric -!--------------------------------------------------------------------------------------------------- -function om2ho(om) result(ho) - - real(pReal), intent(in), dimension(3,3) :: om - real(pReal), dimension(3) :: ho - - ho = ax2ho(om2ax(om)) - -end function om2ho - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert rotation matrix to cubochoric -!--------------------------------------------------------------------------------------------------- -function om2cu(om) result(cu) - - real(pReal), intent(in), dimension(3,3) :: om - real(pReal), dimension(3) :: cu - - cu = ho2cu(om2ho(om)) - -end function om2cu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief Euler angles to unit quaternion -!--------------------------------------------------------------------------------------------------- +!> @brief Convert Bunge Euler angles to unit quaternion. +!-------------------------------------------------------------------------------------------------- pure function eu2qu(eu) result(qu) real(pReal), intent(in), dimension(3) :: eu @@ -722,6 +609,7 @@ pure function eu2qu(eu) result(qu) real(pReal), dimension(3) :: ee real(pReal) :: cPhi, sPhi + ee = 0.5_pReal*eu cPhi = cos(ee(2)) @@ -736,10 +624,10 @@ pure function eu2qu(eu) result(qu) end function eu2qu -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University -!> @brief Euler angles to orientation matrix -!--------------------------------------------------------------------------------------------------- +!> @brief Convert Euler angles to orientation matrix. +!-------------------------------------------------------------------------------------------------- pure function eu2om(eu) result(om) real(pReal), intent(in), dimension(3) :: eu @@ -747,6 +635,7 @@ pure function eu2om(eu) result(om) real(pReal), dimension(3) :: c, s + c = cos(eu) s = sin(eu) @@ -765,10 +654,10 @@ pure function eu2om(eu) result(om) end function eu2om -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University -!> @brief convert euler to axis angle -!--------------------------------------------------------------------------------------------------- +!> @brief Convert Bunge Euler angles to axis-angle pair. +!-------------------------------------------------------------------------------------------------- pure function eu2ax(eu) result(ax) real(pReal), intent(in), dimension(3) :: eu @@ -776,6 +665,7 @@ pure function eu2ax(eu) result(ax) real(pReal) :: t, delta, tau, alpha, sigma + t = tan(eu(2)*0.5_pReal) sigma = 0.5_pReal*(eu(1)+eu(3)) delta = 0.5_pReal*(eu(1)-eu(3)) @@ -794,59 +684,10 @@ pure function eu2ax(eu) result(ax) end function eu2ax -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University -!> @brief Euler angles to Rodrigues vector -!--------------------------------------------------------------------------------------------------- -pure function eu2ro(eu) result(ro) - - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(4) :: ro - - ro = eu2ax(eu) - if (ro(4) >= PI) then - ro(4) = IEEE_value(ro(4),IEEE_positive_inf) - elseif(dEq0(ro(4))) then - ro = [ 0.0_pReal, 0.0_pReal, P, 0.0_pReal ] - else - ro(4) = tan(ro(4)*0.5_pReal) - end if - -end function eu2ro - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert Euler angles to homochoric -!--------------------------------------------------------------------------------------------------- -pure function eu2ho(eu) result(ho) - - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(3) :: ho - - ho = ax2ho(eu2ax(eu)) - -end function eu2ho - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert Euler angles to cubochoric -!--------------------------------------------------------------------------------------------------- -function eu2cu(eu) result(cu) - - real(pReal), intent(in), dimension(3) :: eu - real(pReal), dimension(3) :: cu - - cu = ho2cu(eu2ho(eu)) - -end function eu2cu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert axis angle pair to quaternion -!--------------------------------------------------------------------------------------------------- +!> @brief Convert axis-angle pair to unit quaternion. +!-------------------------------------------------------------------------------------------------- pure function ax2qu(ax) result(qu) real(pReal), intent(in), dimension(4) :: ax @@ -866,10 +707,10 @@ pure function ax2qu(ax) result(qu) end function ax2qu -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University -!> @brief convert axis angle pair to orientation matrix -!--------------------------------------------------------------------------------------------------- +!> @brief Convert axis-angle pair to orientation matrix. +!-------------------------------------------------------------------------------------------------- pure function ax2om(ax) result(om) real(pReal), intent(in), dimension(4) :: ax @@ -877,6 +718,7 @@ pure function ax2om(ax) result(om) real(pReal) :: q, c, s, omc + c = cos(ax(4)) s = sin(ax(4)) omc = 1.0_pReal-c @@ -902,509 +744,50 @@ pure function ax2om(ax) result(om) end function ax2om -!--------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University -!> @brief convert axis angle pair to Euler angles -!--------------------------------------------------------------------------------------------------- +!> @brief Convert axis-angle pair to Bunge Euler angles. +!-------------------------------------------------------------------------------------------------- pure function ax2eu(ax) result(eu) real(pReal), intent(in), dimension(4) :: ax real(pReal), dimension(3) :: eu + eu = om2eu(ax2om(ax)) end function ax2eu -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert axis angle pair to Rodrigues vector -!--------------------------------------------------------------------------------------------------- -pure function ax2ro(ax) result(ro) - - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(4) :: ro - - real(pReal), parameter :: thr = 1.0e-7_pReal - - if (dEq0(ax(4))) then - ro = [ 0.0_pReal, 0.0_pReal, P, 0.0_pReal ] - else - ro(1:3) = ax(1:3) - ! we need to deal with the 180 degree case - ro(4) = merge(IEEE_value(ro(4),IEEE_positive_inf),tan(ax(4)*0.5_pReal),abs(ax(4)-PI) < thr) - end if - -end function ax2ro - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert axis angle pair to homochoric -!--------------------------------------------------------------------------------------------------- -pure function ax2ho(ax) result(ho) - - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(3) :: ho - - real(pReal) :: f - - f = 0.75_pReal * ( ax(4) - sin(ax(4)) ) - f = f**(1.0_pReal/3.0_pReal) - ho = ax(1:3) * f - -end function ax2ho - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert axis angle pair to cubochoric -!--------------------------------------------------------------------------------------------------- -function ax2cu(ax) result(cu) - - real(pReal), intent(in), dimension(4) :: ax - real(pReal), dimension(3) :: cu - - cu = ho2cu(ax2ho(ax)) - -end function ax2cu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert Rodrigues vector to unit quaternion -!--------------------------------------------------------------------------------------------------- -pure function ro2qu(ro) result(qu) - - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(4) :: qu - - qu = ax2qu(ro2ax(ro)) - -end function ro2qu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert Rodrigues vector to rotation matrix -!--------------------------------------------------------------------------------------------------- -pure function ro2om(ro) result(om) - - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(3,3) :: om - - om = ax2om(ro2ax(ro)) - -end function ro2om - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert Rodrigues vector to Euler angles -!--------------------------------------------------------------------------------------------------- -pure function ro2eu(ro) result(eu) - - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(3) :: eu - - eu = om2eu(ro2om(ro)) - -end function ro2eu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert Rodrigues vector to axis angle pair -!--------------------------------------------------------------------------------------------------- -pure function ro2ax(ro) result(ax) - - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(4) :: ax - - real(pReal) :: ta, angle - - ta = ro(4) - - if (.not. IEEE_is_finite(ta)) then - ax = [ ro(1), ro(2), ro(3), PI ] - elseif (dEq0(ta)) then - ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] - else - angle = 2.0_pReal*atan(ta) - ta = 1.0_pReal/norm2(ro(1:3)) - ax = [ ro(1)/ta, ro(2)/ta, ro(3)/ta, angle ] - end if - -end function ro2ax - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert Rodrigues vector to homochoric -!--------------------------------------------------------------------------------------------------- -pure function ro2ho(ro) result(ho) - - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(3) :: ho - - real(pReal) :: f - - if (dEq0(norm2(ro(1:3)))) then - ho = [ 0.0_pReal, 0.0_pReal, 0.0_pReal ] - else - f = merge(2.0_pReal*atan(ro(4)) - sin(2.0_pReal*atan(ro(4))),PI, IEEE_is_finite(ro(4))) - ho = ro(1:3) * (0.75_pReal*f)**(1.0_pReal/3.0_pReal) - end if - -end function ro2ho - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert Rodrigues vector to cubochoric -!--------------------------------------------------------------------------------------------------- -pure function ro2cu(ro) result(cu) - - real(pReal), intent(in), dimension(4) :: ro - real(pReal), dimension(3) :: cu - - cu = ho2cu(ro2ho(ro)) - -end function ro2cu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert homochoric to unit quaternion -!--------------------------------------------------------------------------------------------------- -pure function ho2qu(ho) result(qu) - - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(4) :: qu - - qu = ax2qu(ho2ax(ho)) - -end function ho2qu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert homochoric to rotation matrix -!--------------------------------------------------------------------------------------------------- -pure function ho2om(ho) result(om) - - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(3,3) :: om - - om = ax2om(ho2ax(ho)) - -end function ho2om - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert homochoric to Euler angles -!--------------------------------------------------------------------------------------------------- -pure function ho2eu(ho) result(eu) - - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(3) :: eu - - eu = ax2eu(ho2ax(ho)) - -end function ho2eu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert homochoric to axis angle pair -!--------------------------------------------------------------------------------------------------- -pure function ho2ax(ho) result(ax) - - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(4) :: ax - - integer :: i - real(pReal) :: hmag_squared, s, hm - real(pReal), parameter, dimension(16) :: & - tfit = [ 1.0000000000018852_pReal, -0.5000000002194847_pReal, & - -0.024999992127593126_pReal, -0.003928701544781374_pReal, & - -0.0008152701535450438_pReal, -0.0002009500426119712_pReal, & - -0.00002397986776071756_pReal, -0.00008202868926605841_pReal, & - +0.00012448715042090092_pReal, -0.0001749114214822577_pReal, & - +0.0001703481934140054_pReal, -0.00012062065004116828_pReal, & - +0.000059719705868660826_pReal, -0.00001980756723965647_pReal, & - +0.000003953714684212874_pReal, -0.00000036555001439719544_pReal ] - - ! normalize h and store the magnitude - hmag_squared = sum(ho**2) - if (dEq0(hmag_squared)) then - ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] - else - hm = hmag_squared - - ! convert the magnitude to the rotation angle - s = tfit(1) + tfit(2) * hmag_squared - do i=3,16 - hm = hm*hmag_squared - s = s + tfit(i) * hm - enddo - ax = [ho/sqrt(hmag_squared), 2.0_pReal*acos(s)] - end if - -end function ho2ax - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert homochoric to Rodrigues vector -!--------------------------------------------------------------------------------------------------- -pure function ho2ro(ho) result(ro) - - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(4) :: ro - - ro = ax2ro(ho2ax(ho)) - -end function ho2ro - - -!-------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @brief convert homochoric to cubochoric -!-------------------------------------------------------------------------- -pure function ho2cu(ho) result(cu) - - real(pReal), intent(in), dimension(3) :: ho - real(pReal), dimension(3) :: cu, xyz1, xyz3 - real(pReal), dimension(2) :: Tinv, xyz2 - real(pReal) :: rs, qxy, q2, sq2, q, tt - integer, dimension(3,2) :: p - - rs = norm2(ho) - if (rs > R1+1.e-6_pReal) then - cu = IEEE_value(cu,IEEE_positive_inf) - return - endif - - center: if (all(dEq0(ho))) then - cu = 0.0_pReal - else center - p = GetPyramidOrder(ho) - xyz3 = ho(p(:,1)) - - ! inverse M_3 - xyz2 = xyz3(1:2) * sqrt( 2.0*rs/(rs+abs(xyz3(3))) ) - - ! inverse M_2 - qxy = sum(xyz2**2) - - special: if (dEq0(qxy)) then - Tinv = 0.0_pReal - else special - q2 = qxy + maxval(abs(xyz2))**2 - sq2 = sqrt(q2) - q = (BETA/R2/R1) * sqrt(q2*qxy/(q2-maxval(abs(xyz2))*sq2)) - tt = (minval(abs(xyz2))**2+maxval(abs(xyz2))*sq2)/R2/qxy - Tinv = q * sign(1.0_pReal,xyz2) * merge([ 1.0_pReal, acos(math_clip(tt,-1.0_pReal,1.0_pReal))/PI12], & - [ acos(math_clip(tt,-1.0_pReal,1.0_pReal))/PI12, 1.0_pReal], & - abs(xyz2(2)) <= abs(xyz2(1))) - endif special - - ! inverse M_1 - xyz1 = [ Tinv(1), Tinv(2), sign(1.0_pReal,xyz3(3)) * rs / PREF ]/SC - - ! reverse the coordinates back to order according to the original pyramid number - cu = xyz1(p(:,2)) - - endif center - -end function ho2cu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert cubochoric to unit quaternion -!--------------------------------------------------------------------------------------------------- -pure function cu2qu(cu) result(qu) - - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(4) :: qu - - qu = ho2qu(cu2ho(cu)) - -end function cu2qu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert cubochoric to rotation matrix -!--------------------------------------------------------------------------------------------------- -pure function cu2om(cu) result(om) - - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(3,3) :: om - - om = ho2om(cu2ho(cu)) - -end function cu2om - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert cubochoric to Euler angles -!--------------------------------------------------------------------------------------------------- -pure function cu2eu(cu) result(eu) - - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(3) :: eu - - eu = ho2eu(cu2ho(cu)) - -end function cu2eu - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert cubochoric to axis angle pair -!--------------------------------------------------------------------------------------------------- -function cu2ax(cu) result(ax) - - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(4) :: ax - - ax = ho2ax(cu2ho(cu)) - -end function cu2ax - - -!--------------------------------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @brief convert cubochoric to Rodrigues vector -!--------------------------------------------------------------------------------------------------- -pure function cu2ro(cu) result(ro) - - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(4) :: ro - - ro = ho2ro(cu2ho(cu)) - -end function cu2ro - - -!-------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @brief map from 3D cubic grid to 3D ball -!-------------------------------------------------------------------------- -pure function cu2ho(cu) result(ho) - - real(pReal), intent(in), dimension(3) :: cu - real(pReal), dimension(3) :: ho, LamXYZ, XYZ - real(pReal), dimension(2) :: T - real(pReal) :: c, s, q - real(pReal), parameter :: eps = 1.0e-8_pReal - integer, dimension(3,2) :: p - integer, dimension(2) :: order - - if (maxval(abs(cu)) > AP/2.0+eps) then - ho = IEEE_value(cu,IEEE_positive_inf) - return - end if - - ! transform to the sphere grid via the curved square, and intercept the zero point - center: if (all(dEq0(cu))) then - ho = 0.0_pReal - else center - ! get pyramide and scale by grid parameter ratio - p = GetPyramidOrder(cu) - XYZ = cu(p(:,1)) * SC - - ! intercept all the points along the z-axis - special: if (all(dEq0(XYZ(1:2)))) then - LamXYZ = [ 0.0_pReal, 0.0_pReal, PREF * XYZ(3) ] - else special - order = merge( [2,1], [1,2], abs(XYZ(2)) <= abs(XYZ(1))) ! order of absolute values of XYZ - q = PI12 * XYZ(order(1))/XYZ(order(2)) ! smaller by larger - c = cos(q) - s = sin(q) - q = PREK * XYZ(order(2))/ sqrt(R2-c) - T = [ (R2*c - 1.0), R2 * s] * q - - ! transform to sphere grid (inverse Lambert) - ! [note that there is no need to worry about dividing by zero, since XYZ(3) can not become zero] - c = sum(T**2) - s = c * PI/(24.0*XYZ(3)**2) - c = c * sqrt(PI/24.0_pReal) / XYZ(3) - q = sqrt( 1.0 - s ) - LamXYZ = [ T(order(2)) * q, T(order(1)) * q, PREF * XYZ(3) - c ] - end if special - - ! reverse the coordinates back to order according to the original pyramid number - ho = LamXYZ(p(:,2)) - - end if center - -end function cu2ho - - -!-------------------------------------------------------------------------- -!> @author Marc De Graef, Carnegie Mellon University -!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @brief Determine to which pyramid a point in a cubic grid belongs. -!-------------------------------------------------------------------------- -pure function GetPyramidOrder(xyz) - - real(pReal),intent(in),dimension(3) :: xyz - integer, dimension(3,2) :: GetPyramidOrder - - if (((abs(xyz(1)) <= xyz(3)).and.(abs(xyz(2)) <= xyz(3))) .or. & - ((abs(xyz(1)) <= -xyz(3)).and.(abs(xyz(2)) <= -xyz(3)))) then - GetPyramidOrder = reshape([[1,2,3],[1,2,3]],[3,2]) - else if (((abs(xyz(3)) <= xyz(1)).and.(abs(xyz(2)) <= xyz(1))) .or. & - ((abs(xyz(3)) <= -xyz(1)).and.(abs(xyz(2)) <= -xyz(1)))) then - GetPyramidOrder = reshape([[2,3,1],[3,1,2]],[3,2]) - else if (((abs(xyz(1)) <= xyz(2)).and.(abs(xyz(3)) <= xyz(2))) .or. & - ((abs(xyz(1)) <= -xyz(2)).and.(abs(xyz(3)) <= -xyz(2)))) then - GetPyramidOrder = reshape([[3,1,2],[2,3,1]],[3,2]) - else - GetPyramidOrder = -1 ! should be impossible, but might simplify debugging - end if - -end function GetPyramidOrder - - !-------------------------------------------------------------------------------------------------- !> @brief Multiply two quaternions. !-------------------------------------------------------------------------------------------------- -pure function multiply_quaternion(qu1,qu2) +pure function multiplyQuaternion(qu1,qu2) real(pReal), dimension(4), intent(in) :: qu1, qu2 - real(pReal), dimension(4) :: multiply_quaternion + real(pReal), dimension(4) :: multiplyQuaternion - multiply_quaternion(1) = qu1(1)*qu2(1) - qu1(2)*qu2(2) - qu1(3)*qu2(3) - qu1(4)*qu2(4) - multiply_quaternion(2) = qu1(1)*qu2(2) + qu1(2)*qu2(1) + P * (qu1(3)*qu2(4) - qu1(4)*qu2(3)) - multiply_quaternion(3) = qu1(1)*qu2(3) + qu1(3)*qu2(1) + P * (qu1(4)*qu2(2) - qu1(2)*qu2(4)) - multiply_quaternion(4) = qu1(1)*qu2(4) + qu1(4)*qu2(1) + P * (qu1(2)*qu2(3) - qu1(3)*qu2(2)) + multiplyQuaternion(1) = qu1(1)*qu2(1) - qu1(2)*qu2(2) - qu1(3)*qu2(3) - qu1(4)*qu2(4) + multiplyQuaternion(2) = qu1(1)*qu2(2) + qu1(2)*qu2(1) + P * (qu1(3)*qu2(4) - qu1(4)*qu2(3)) + multiplyQuaternion(3) = qu1(1)*qu2(3) + qu1(3)*qu2(1) + P * (qu1(4)*qu2(2) - qu1(2)*qu2(4)) + multiplyQuaternion(4) = qu1(1)*qu2(4) + qu1(4)*qu2(1) + P * (qu1(2)*qu2(3) - qu1(3)*qu2(2)) -end function multiply_quaternion +end function multiplyQuaternion !-------------------------------------------------------------------------------------------------- !> @brief Calculate conjugate complex of a quaternion. !-------------------------------------------------------------------------------------------------- -pure function conjugate_quaternion(qu) +pure function conjugateQuaternion(qu) real(pReal), dimension(4), intent(in) :: qu - real(pReal), dimension(4) :: conjugate_quaternion + real(pReal), dimension(4) :: conjugateQuaternion - conjugate_quaternion = [qu(1), -qu(2), -qu(3), -qu(4)] + conjugateQuaternion = [qu(1), -qu(2), -qu(3), -qu(4)] - -end function conjugate_quaternion +end function conjugateQuaternion !-------------------------------------------------------------------------------------------------- @@ -1413,29 +796,27 @@ end function conjugate_quaternion subroutine selfTest() type(tRotation) :: R - real(pReal), dimension(4) :: qu, ax, ro - real(pReal), dimension(3) :: x, eu, ho, v3 + real(pReal), dimension(4) :: qu + real(pReal), dimension(3) :: x, eu, v3 real(pReal), dimension(3,3) :: om, t33 real(pReal), dimension(3,3,3,3) :: t3333 real(pReal), dimension(6,6) :: C - real :: A,B + real(pReal) :: A,B integer :: i do i = 1, 20 if(i==1) then - qu = om2qu(math_I3) + qu = [1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal] elseif(i==2) then - qu = eu2qu([0.0_pReal,0.0_pReal,0.0_pReal]) + qu = [1.0_pReal,-0.0_pReal,-0.0_pReal,-0.0_pReal] elseif(i==3) then - qu = eu2qu([TAU,PI,TAU]) + qu = [0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal] elseif(i==4) then qu = [0.0_pReal,0.0_pReal,1.0_pReal,0.0_pReal] elseif(i==5) then - qu = ro2qu([1.0_pReal,0.0_pReal,0.0_pReal,IEEE_value(1.0_pReal, IEEE_positive_inf)]) - elseif(i==6) then - qu = ax2qu([1.0_pReal,0.0_pReal,0.0_pReal,0.0_pReal]) + qu = [0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal] else call random_number(x) A = sqrt(x(3)) @@ -1445,40 +826,19 @@ subroutine selfTest() cos(TAU*x(2))*B,& sin(TAU*x(1))*A] if(qu(1)<0.0_pReal) qu = qu * (-1.0_pReal) - endif + end if - if(.not. quaternion_equal(om2qu(qu2om(qu)),qu)) error stop 'om2qu/qu2om' - if(.not. quaternion_equal(eu2qu(qu2eu(qu)),qu)) error stop 'eu2qu/qu2eu' - if(.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) error stop 'ax2qu/qu2ax' - if(.not. quaternion_equal(ro2qu(qu2ro(qu)),qu)) error stop 'ro2qu/qu2ro' - if(.not. quaternion_equal(ho2qu(qu2ho(qu)),qu)) error stop 'ho2qu/qu2ho' - if(.not. quaternion_equal(cu2qu(qu2cu(qu)),qu)) error stop 'cu2qu/qu2cu' + if(.not. quaternion_equal(om2qu(qu2om(qu)),qu)) error stop 'om2qu2om' + if(.not. quaternion_equal(eu2qu(qu2eu(qu)),qu)) error stop 'eu2qu2eu' + if(.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) error stop 'ax2qu2ax' om = qu2om(qu) - if(.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) error stop 'eu2om/om2eu' - if(.not. quaternion_equal(om2qu(ax2om(om2ax(om))),qu)) error stop 'ax2om/om2ax' - if(.not. quaternion_equal(om2qu(ro2om(om2ro(om))),qu)) error stop 'ro2om/om2ro' - if(.not. quaternion_equal(om2qu(ho2om(om2ho(om))),qu)) error stop 'ho2om/om2ho' - if(.not. quaternion_equal(om2qu(cu2om(om2cu(om))),qu)) error stop 'cu2om/om2cu' + if(.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) error stop 'eu2om2eu' + if(.not. quaternion_equal(om2qu(ax2om(om2ax(om))),qu)) error stop 'ax2om2ax' eu = qu2eu(qu) - if(.not. quaternion_equal(eu2qu(ax2eu(eu2ax(eu))),qu)) error stop 'ax2eu/eu2ax' - if(.not. quaternion_equal(eu2qu(ro2eu(eu2ro(eu))),qu)) error stop 'ro2eu/eu2ro' - if(.not. quaternion_equal(eu2qu(ho2eu(eu2ho(eu))),qu)) error stop 'ho2eu/eu2ho' - if(.not. quaternion_equal(eu2qu(cu2eu(eu2cu(eu))),qu)) error stop 'cu2eu/eu2cu' - - ax = qu2ax(qu) - if(.not. quaternion_equal(ax2qu(ro2ax(ax2ro(ax))),qu)) error stop 'ro2ax/ax2ro' - if(.not. quaternion_equal(ax2qu(ho2ax(ax2ho(ax))),qu)) error stop 'ho2ax/ax2ho' - if(.not. quaternion_equal(ax2qu(cu2ax(ax2cu(ax))),qu)) error stop 'cu2ax/ax2cu' - - ro = qu2ro(qu) - if(.not. quaternion_equal(ro2qu(ho2ro(ro2ho(ro))),qu)) error stop 'ho2ro/ro2ho' - if(.not. quaternion_equal(ro2qu(cu2ro(ro2cu(ro))),qu)) error stop 'cu2ro/ro2cu' - - ho = qu2ho(qu) - if(.not. quaternion_equal(ho2qu(cu2ho(ho2cu(ho))),qu)) error stop 'cu2ho/ho2cu' + if(.not. quaternion_equal(eu2qu(ax2eu(eu2ax(eu))),qu)) error stop 'ax2eu2ax' call R%fromMatrix(om) diff --git a/src/signals.f90 b/src/signals.f90 index 7db101f94..3f0397d3d 100644 --- a/src/signals.f90 +++ b/src/signals.f90 @@ -6,7 +6,7 @@ module signals use prec use system_routines - implicit none + implicit none(type,external) private logical, volatile, public, protected :: & diff --git a/src/system_routines.f90 b/src/system_routines.f90 index 2af1e12a9..3ce6ba6ce 100644 --- a/src/system_routines.f90 +++ b/src/system_routines.f90 @@ -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