diff --git a/.gitignore b/.gitignore index 2a118ef29..c34f2f0b7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,8 +1,5 @@ *.pyc -*.mod -*.o *.hdf5 -*.exe *.bak *~ bin diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fa9cab906..d82c7c8ac 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -390,13 +390,6 @@ Phenopowerlaw_singleSlip: - master - release -TextureComponents: - stage: grid - script: TextureComponents/test.py - except: - - master - - release - ################################################################################################### Marc_compileIfort2018_1: @@ -452,8 +445,6 @@ J2_plasticBehavior: grid_all_example: stage: example script: grid_all_example/test.py - only: - - development ################################################################################################### SpectralRuntime: @@ -515,7 +506,7 @@ Processing: - rm abq_addUserOutput.py marc_addUserOutput.py - $DAMASKROOT/PRIVATE/documenting/scriptHelpToWiki.py --debug *.py - cd $DAMASKROOT/processing/post - - rm marc_to_vtk.py vtk2ang.py + - rm marc_to_vtk.py vtk2ang.py DAD*.py - $DAMASKROOT/PRIVATE/documenting/scriptHelpToWiki.py --debug *.py except: - master diff --git a/CMakeLists.txt b/CMakeLists.txt index 8be07198a..6c9bbea04 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -105,12 +105,13 @@ set (CMAKE_C_COMPILER "${PETSC_MPICC}") # Now start to care about DAMASK # DAMASK solver defines project to build -if (DAMASK_SOLVER STREQUAL "GRID") - project (DAMASK_grid Fortran C) +string(TOLOWER ${DAMASK_SOLVER} DAMASK_SOLVER) +if (DAMASK_SOLVER STREQUAL "grid") + project (damask-grid Fortran C) add_definitions (-DGrid) message ("Building Grid Solver\n") -elseif (DAMASK_SOLVER STREQUAL "FEM") - project (DAMASK_FEM Fortran C) +elseif (DAMASK_SOLVER STREQUAL "fem" OR DAMASK_SOLVER STREQUAL "mesh") + project (damask-mesh Fortran C) add_definitions (-DFEM) message ("Building FEM Solver\n") else () @@ -138,14 +139,14 @@ elseif (CMAKE_BUILD_TYPE STREQUAL "PERFORMANCE") endif () # $OPTIMIZATION takes precedence over $BUILD_TYPE defaults -if (OPTIMIZATION STREQUAL "") +if (OPTIMIZATION STREQUAL "" OR NOT DEFINED OPTIMIZATION) set (OPTIMIZATION "${OPTI}") else () set (OPTIMIZATION "${OPTIMIZATION}") endif () # $OPENMP takes precedence over $BUILD_TYPE defaults -if (OPENMP STREQUAL "") +if (OPENMP STREQUAL "" OR NOT DEFINED OPENMP) set (OPENMP "${PARALLEL}") else () set(OPENMP "${OPENMP}") @@ -156,22 +157,6 @@ if (CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") set (BUILDCMD_POST "${BUILDCMD_POST} -fsyntax-only") endif () -# Parse DAMASK_BIN from CONFIG file -file (READ "CONFIG" CONFIGFILE) -string (REGEX REPLACE ";" "\\\\;" CONFIGFILE "${CONFIGFILE}") -string (REGEX REPLACE "\n" ";" CONFIGFILE "${CONFIGFILE}") -foreach (item ${CONFIGFILE}) - string (REGEX MATCH ".+DAMASK_BIN.+" item ${item}) - if (item) - string (REGEX REPLACE "set" "" item "${item}") - string (REGEX REPLACE "=" " " item "${item}") - string (REGEX REPLACE "\\\${DAMASK_ROOT}" "${PROJECT_SOURCE_DIR}" item "${item}") - string (REPLACE "DAMASK_BIN" ";" STRING_LIST ${item}) - list (GET STRING_LIST 1 item) - string (STRIP "${item}" CMAKE_INSTALL_PREFIX) - endif () -endforeach(item ${CONFIGFILE}) - # Parse DAMASK version from VERSION file find_program (CAT_EXECUTABLE NAMES cat) execute_process (COMMAND ${CAT_EXECUTABLE} ${PROJECT_SOURCE_DIR}/VERSION @@ -184,286 +169,14 @@ add_definitions (-DDAMASKVERSION="${DAMASK_V}") add_definitions (-DPETSc) set (DAMASK_INCLUDE_FLAGS "${DAMASK_INCLUDE_FLAGS} ${PETSC_INCLUDES}") +list(APPEND CMAKE_MODULE_PATH ${PROJECT_SOURCE_DIR}/cmake) -################################################################################################### -# Intel Compiler -################################################################################################### if (CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") - - if (OPENMP) - set (OPENMP_FLAGS "-qopenmp -parallel") - endif () - - if (OPTIMIZATION STREQUAL "OFF") - set (OPTIMIZATION_FLAGS "-O0 -no-ip") - elseif (OPTIMIZATION STREQUAL "DEFENSIVE") - set (OPTIMIZATION_FLAGS "-O2") - elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") - set (OPTIMIZATION_FLAGS "-ipo -O3 -no-prec-div -fp-model fast=2 -xHost") - # -fast = -ipo, -O3, -no-prec-div, -static, -fp-model fast=2, and -xHost" - endif () - - # -assume std_mod_proc_name (included in -standard-semantics) causes problems if other modules - # (PETSc, HDF5) are not compiled with this option (https://software.intel.com/en-us/forums/intel-fortran-compiler-for-linux-and-mac-os-x/topic/62172) - set (STANDARD_CHECK "-stand f15 -standard-semantics -assume nostd_mod_proc_name") - set (LINKER_FLAGS "${LINKER_FLAGS} -shared-intel") - # Link against shared Intel libraries instead of static ones - -#------------------------------------------------------------------------------------------------ -# Fine tuning compilation options - set (COMPILE_FLAGS "${COMPILE_FLAGS} -fpp") - # preprocessor - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -ftz") - # flush underflow to zero, automatically set if -O[1,2,3] - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -diag-disable") - # disables warnings ... - set (COMPILE_FLAGS "${COMPILE_FLAGS} 5268") - # ... the text exceeds right hand column allowed on the line (we have only comments there) - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -warn") - # enables warnings ... - set (COMPILE_FLAGS "${COMPILE_FLAGS} declarations") - # ... any undeclared names (alternative name: -implicitnone) - set (COMPILE_FLAGS "${COMPILE_FLAGS},general") - # ... warning messages and informational messages are issued by the compiler - set (COMPILE_FLAGS "${COMPILE_FLAGS},usage") - # ... questionable programming practices - set (COMPILE_FLAGS "${COMPILE_FLAGS},interfaces") - # ... checks the interfaces of all SUBROUTINEs called and FUNCTIONs invoked in your compilation against an external set of interface blocks - set (COMPILE_FLAGS "${COMPILE_FLAGS},ignore_loc") - # ... %LOC is stripped from an actual argument - set (COMPILE_FLAGS "${COMPILE_FLAGS},alignments") - # ... data that is not naturally aligned - set (COMPILE_FLAGS "${COMPILE_FLAGS},unused") - # ... declared variables that are never used - - # Additional options - # -warn: enables warnings, where - # truncated_source: Determines whether warnings occur when source exceeds the maximum column width in fixed-format files. - # (too many warnings because we have comments beyond character 132) - # uncalled: Determines whether warnings occur when a statement function is never called - # all: - # -name as_is: case sensitive Fortran! - -#------------------------------------------------------------------------------------------------ -# Runtime debugging - set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") - # Generate symbolic debugging information in the object file - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -traceback") - # Generate extra information in the object file to provide source file traceback information when a severe error occurs at run time - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -gen-interfaces") - # Generate an interface block for each routine. http://software.intel.com/en-us/blogs/2012/01/05/doctor-fortran-gets-explicit-again/ - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fp-stack-check") - # Generate extra code after every function call to ensure that the floating-point (FP) stack is in the expected state - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fp-model strict") - # Trap uninitalized variables - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -check" ) - # Checks at runtime ... - set (DEBUG_FLAGS "${DEBUG_FLAGS} bounds") - # ... if an array index is too small (<1) or too large! - set (DEBUG_FLAGS "${DEBUG_FLAGS},format") - # ... for the data type of an item being formatted for output. - set (DEBUG_FLAGS "${DEBUG_FLAGS},output_conversion") - # ... for the fit of data items within a designated format descriptor field. - set (DEBUG_FLAGS "${DEBUG_FLAGS},pointers") - # ... for certain disassociated or uninitialized pointers or unallocated allocatable objects. - set (DEBUG_FLAGS "${DEBUG_FLAGS},uninit") - # ... for uninitialized variables. - set (DEBUG_FLAGS "${DEBUG_FLAGS} -ftrapuv") - # ... initializes stack local variables to an unusual value to aid error detection - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fpe-all=0") - # ... capture all floating-point exceptions, sets -ftz automatically - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -warn") - # enables warnings ... - set (DEBUG_FLAGS "${DEBUG_FLAGS} errors") - # ... warnings are changed to errors - set (DEBUG_FLAGS "${DEBUG_FLAGS},stderrors") - # ... warnings about Fortran standard violations are changed to errors - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -debug-parameters all") - # generate debug information for parameters - - # Additional options - # -heap-arrays: Should not be done for OpenMP, but set "ulimit -s unlimited" on shell. Probably it helps also to unlimit other limits - # -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) - - -################################################################################################### -# GNU Compiler -################################################################################################### + include(Compiler-Intel) elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") - - if (OPENMP) - set (OPENMP_FLAGS "-fopenmp") - endif () - - if (OPTIMIZATION STREQUAL "OFF") - set (OPTIMIZATION_FLAGS "-O0" ) - elseif (OPTIMIZATION STREQUAL "DEFENSIVE") - set (OPTIMIZATION_FLAGS "-O2") - elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") - set (OPTIMIZATION_FLAGS "-O3 -ffast-math -funroll-loops -ftree-vectorize") - endif () - - set (STANDARD_CHECK "-std=f2008ts -pedantic-errors" ) - set (LINKER_FLAGS "${LINKER_FLAGS} -Wl") - # options parsed directly to the linker - set (LINKER_FLAGS "${LINKER_FLAGS},-undefined,dynamic_lookup" ) - # ensure to link against dynamic libraries - -#------------------------------------------------------------------------------------------------ -# Fine tuning compilation options - set (COMPILE_FLAGS "${COMPILE_FLAGS} -xf95-cpp-input") - # preprocessor - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -ffree-line-length-132") - # restrict line length to the standard 132 characters (lattice.f90 require more characters) - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -fimplicit-none") - # assume "implicit none" even if not present in source - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -fmodule-private") - # assume "private" even if not present in source - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wall") - # sets the following Fortran options: - # -Waliasing: warn about possible aliasing of dummy arguments. Specifically, it warns if the same actual argument is associated with a dummy argument with "INTENT(IN)" and a dummy argument with "INTENT(OUT)" in a call with an explicit interface. - # -Wampersand: checks if a character expression is continued proberly by an ampersand at the end of the line and at the beginning of the new line - # -Warray-bounds: checks if array reference is out of bounds at compile time. use -fcheck-bounds to also check during runtime - # -Wconversion: warn about implicit conversions between different type - # -Wsurprising: warn when "suspicious" code constructs are encountered. While technically legal these usually indicate that an error has been made. - # -Wc-binding-type: - # -Wintrinsics-std: only standard intrisics are available, e.g. "call flush(6)" will cause an error - # -Wno-tabs: do not allow tabs in source - # -Wintrinsic-shadow: warn if a user-defined procedure or module procedure has the same name as an intrinsic - # -Wline-truncation: - # -Wtarget-lifetime: - # -Wreal-q-constant: warn about real-literal-constants with 'q' exponent-letter - # -Wunused: a number of unused-xxx warnings - # and sets the general (non-Fortran options) options: - # -Waddress - # -Warray-bounds (only with -O2) - # -Wc++11-compat - # -Wchar-subscripts - # -Wcomment - # -Wformat - # -Wmaybe-uninitialized - # -Wnonnull - # -Wparentheses - # -Wpointer-sign - # -Wreorder - # -Wreturn-type - # -Wsequence-point - # -Wstrict-aliasing - # -Wstrict-overflow=1 - # -Wswitch - # -Wtrigraphs - # -Wuninitialized - # -Wunknown-pragmas - # -Wunused-function - # -Wunused-label - # -Wunused-value - # -Wunused-variable - # -Wvolatile-register-var - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wextra") - # sets the following Fortran options: - # -Wunuses-parameter: - # -Wcompare-reals: - # and sets the general (non-Fortran options) options: - # -Wclobbered - # -Wempty-body - # -Wignored-qualifiers - # -Wmissing-field-initializers - # -Woverride-init - # -Wsign-compare - # -Wtype-limits - # -Wuninitialized - # -Wunused-but-set-parameter (only with -Wunused or -Wall) - # -Wno-globals - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wcharacter-truncation") - # warn if character expressions (strings) are truncated - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wunderflow") - # produce a warning when numerical constant expressions are encountered, which yield an UNDERFLOW during compilation - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wsuggest-attribute=pure") - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wsuggest-attribute=noreturn") - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wconversion-extra") - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wimplicit-procedure") - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wno-unused-parameter") - set (COMPILE_FLAGS "${COMPILE_FLAGS} -ffpe-summary=all") - # print summary of floating point exeptions (invalid,zero,overflow,underflow,inexact,denormal) - - # Additional options - # -Warray-temporarieswarnings: because we have many temporary arrays (performance issue?): - # -Wimplicit-interface: no interfaces for lapack/MPI routines - # -Wunsafe-loop-optimizations: warn if the loop cannot be optimized due to nontrivial assumptions. - -#------------------------------------------------------------------------------------------------ -# Runtime debugging - set (DEBUG_FLAGS "${DEBUG_FLAGS} -ffpe-trap=invalid,zero,overflow") - # stop execution if floating point exception is detected (NaN is silent) - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") - # Generate symbolic debugging information in the object file - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fbacktrace") - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fdump-core") - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fcheck=all") - # checks for (array-temps,bounds,do,mem,pointer,recursion) - - # Additional options - # -ffpe-trap=precision,denormal,underflow -#------------------------------------------------------------------------------------------------ -# 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 - - -################################################################################################### -# PGI Compiler -################################################################################################### + include(Compiler-GNU) elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "PGI") - - if (OPTIMIZATION STREQUAL "OFF") - set (OPTIMIZATION_FLAGS "-O0" ) - elseif (OPTIMIZATION STREQUAL "DEFENSIVE") - set (OPTIMIZATION_FLAGS "-O2") - elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") - set (OPTIMIZATION_FLAGS "-O3") - endif () - - -#------------------------------------------------------------------------------------------------ -# Fine tuning compilation options - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Mpreprocess") - # preprocessor - - set (STANDARD_CHECK "-Mallocatable=03") - -#------------------------------------------------------------------------------------------------ -# Runtime debugging - set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") - # Includes debugging information in the object module; sets the optimization level to zero unless a -⁠O option is present on the command line + include(Compiler-PGI) else () message (FATAL_ERROR "Compiler type (CMAKE_Fortran_COMPILER_ID) not recognized") endif () @@ -486,18 +199,3 @@ message ("Fortran Linker Command:\n${CMAKE_Fortran_LINK_EXECUTABLE}\n") # location of code add_subdirectory (src) - -# INSTALL BUILT BINARIES -if (CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") - exec_program (mktemp OUTPUT_VARIABLE nothing) - exec_program (mktemp ARGS -d OUTPUT_VARIABLE black_hole) - install (PROGRAMS ${nothing} DESTINATION ${black_hole}) -else () - if (PROJECT_NAME STREQUAL "DAMASK_grid") - install (PROGRAMS ${PROJECT_BINARY_DIR}/src/DAMASK_spectral - DESTINATION ${CMAKE_INSTALL_PREFIX}) - elseif (PROJECT_NAME STREQUAL "DAMASK_FEM") - install (PROGRAMS ${PROJECT_BINARY_DIR}/src/DAMASK_FEM - DESTINATION ${CMAKE_INSTALL_PREFIX}) - endif () -endif () diff --git a/CONFIG b/CONFIG index 31a9c34c8..6d5226c89 100644 --- a/CONFIG +++ b/CONFIG @@ -1,8 +1,6 @@ # "set"-syntax needed only for tcsh (but works with bash and zsh) # DAMASK_ROOT will be expanded -set DAMASK_BIN = ${DAMASK_ROOT}/bin - set DAMASK_NUM_THREADS = 4 set MSC_ROOT = /opt/msc diff --git a/Makefile b/Makefile index 53ae30c1c..b24e3d36b 100644 --- a/Makefile +++ b/Makefile @@ -2,30 +2,31 @@ SHELL = /bin/sh ######################################################################################## # Makefile for the installation of DAMASK ######################################################################################## +DAMASK_ROOT = $(shell python -c "import os,sys; print(os.path.normpath(os.path.realpath(os.path.expanduser('$(pwd)'))))") .PHONY: all -all: grid FEM processing +all: grid mesh processing .PHONY: grid grid: build/grid - @(cd build/grid;make -j4 --no-print-directory -ws all install;) - + @(cd build/grid;make -j4 all install;) .PHONY: spectral -spectral: build/grid - @(cd build/grid;make -j4 --no-print-directory -ws all install;) +spectral: grid +.PHONY: mesh +mesh: build/mesh + @(cd build/mesh; make -j4 all install;) .PHONY: FEM -FEM: build/FEM - @(cd build/FEM; make -j4 --no-print-directory -ws all install;) +FEM: mesh .PHONY: build/grid build/grid: @mkdir -p build/grid - @(cd build/grid; cmake -Wno-dev -DDAMASK_SOLVER=GRID -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) + @(cd build/grid; cmake -Wno-dev -DDAMASK_SOLVER=GRID -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT} -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) -.PHONY: build/FEM -build/FEM: - @mkdir -p build/FEM - @(cd build/FEM; cmake -Wno-dev -DDAMASK_SOLVER=FEM -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) +.PHONY: build/mesh +build/mesh: + @mkdir -p build/mesh + @(cd build/mesh; cmake -Wno-dev -DDAMASK_SOLVER=FEM -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT} -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) .PHONY: clean clean: diff --git a/PRIVATE b/PRIVATE index f6171a748..212ac3b32 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit f6171a748e51b994db27c2cc74cc0168b7aea93f +Subproject commit 212ac3b326f3a15926d71109fec0173d95931b6b diff --git a/VERSION b/VERSION index b1cf69273..9096149dc 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.3-36-gbe387ab8 +v2.0.3-198-g1c762860 diff --git a/cmake/Compiler-GNU.cmake b/cmake/Compiler-GNU.cmake new file mode 100644 index 000000000..008c0c90e --- /dev/null +++ b/cmake/Compiler-GNU.cmake @@ -0,0 +1,130 @@ +################################################################################################### +# GNU Compiler +################################################################################################### + + if (OPENMP) + set (OPENMP_FLAGS "-fopenmp") + endif () + + if (OPTIMIZATION STREQUAL "OFF") + set (OPTIMIZATION_FLAGS "-O0" ) + elseif (OPTIMIZATION STREQUAL "DEFENSIVE") + set (OPTIMIZATION_FLAGS "-O2") + elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") + set (OPTIMIZATION_FLAGS "-O3 -ffast-math -funroll-loops -ftree-vectorize") + endif () + + set (STANDARD_CHECK "-std=f2008ts -pedantic-errors" ) + set (LINKER_FLAGS "${LINKER_FLAGS} -Wl") + # options parsed directly to the linker + set (LINKER_FLAGS "${LINKER_FLAGS},-undefined,dynamic_lookup" ) + # ensure to link against dynamic libraries + +#------------------------------------------------------------------------------------------------ +# Fine tuning compilation options + set (COMPILE_FLAGS "${COMPILE_FLAGS} -xf95-cpp-input") + # preprocessor + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -ffree-line-length-132") + # restrict line length to the standard 132 characters (lattice.f90 require more characters) + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -fimplicit-none") + # assume "implicit none" even if not present in source + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wall") + # sets the following Fortran options: + # -Waliasing: warn about possible aliasing of dummy arguments. Specifically, it warns if the same actual argument is associated with a dummy argument with "INTENT(IN)" and a dummy argument with "INTENT(OUT)" in a call with an explicit interface. + # -Wampersand: checks if a character expression is continued proberly by an ampersand at the end of the line and at the beginning of the new line + # -Warray-bounds: checks if array reference is out of bounds at compile time. use -fcheck-bounds to also check during runtime + # -Wconversion: warn about implicit conversions between different type + # -Wsurprising: warn when "suspicious" code constructs are encountered. While technically legal these usually indicate that an error has been made. + # -Wc-binding-type: + # -Wintrinsics-std: only standard intrisics are available, e.g. "call flush(6)" will cause an error + # -Wno-tabs: do not allow tabs in source + # -Wintrinsic-shadow: warn if a user-defined procedure or module procedure has the same name as an intrinsic + # -Wline-truncation: + # -Wtarget-lifetime: + # -Wreal-q-constant: warn about real-literal-constants with 'q' exponent-letter + # -Wunused: a number of unused-xxx warnings + # and sets the general (non-Fortran options) options: + # -Waddress + # -Warray-bounds (only with -O2) + # -Wc++11-compat + # -Wchar-subscripts + # -Wcomment + # -Wformat + # -Wmaybe-uninitialized + # -Wnonnull + # -Wparentheses + # -Wpointer-sign + # -Wreorder + # -Wreturn-type + # -Wsequence-point + # -Wstrict-aliasing + # -Wstrict-overflow=1 + # -Wswitch + # -Wtrigraphs + # -Wuninitialized + # -Wunknown-pragmas + # -Wunused-function + # -Wunused-label + # -Wunused-value + # -Wunused-variable + # -Wvolatile-register-var + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wextra") + # sets the following Fortran options: + # -Wunuses-parameter: + # -Wcompare-reals: + # and sets the general (non-Fortran options) options: + # -Wclobbered + # -Wempty-body + # -Wignored-qualifiers + # -Wmissing-field-initializers + # -Woverride-init + # -Wsign-compare + # -Wtype-limits + # -Wuninitialized + # -Wunused-but-set-parameter (only with -Wunused or -Wall) + # -Wno-globals + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wcharacter-truncation") + # warn if character expressions (strings) are truncated + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wunderflow") + # produce a warning when numerical constant expressions are encountered, which yield an UNDERFLOW during compilation + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wsuggest-attribute=pure") + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wsuggest-attribute=noreturn") + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wconversion-extra") + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wimplicit-procedure") + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wno-unused-parameter") + set (COMPILE_FLAGS "${COMPILE_FLAGS} -ffpe-summary=all") + # print summary of floating point exeptions (invalid,zero,overflow,underflow,inexact,denormal) + + # Additional options + # -Warray-temporarieswarnings: because we have many temporary arrays (performance issue?): + # -Wimplicit-interface: no interfaces for lapack/MPI routines + # -Wunsafe-loop-optimizations: warn if the loop cannot be optimized due to nontrivial assumptions. + +#------------------------------------------------------------------------------------------------ +# Runtime debugging + set (DEBUG_FLAGS "${DEBUG_FLAGS} -ffpe-trap=invalid,zero,overflow") + # stop execution if floating point exception is detected (NaN is silent) + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") + # Generate symbolic debugging information in the object file + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fbacktrace") + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fdump-core") + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fcheck=all") + # checks for (array-temps,bounds,do,mem,pointer,recursion) + + # Additional options + # -ffpe-trap=precision,denormal,underflow +#------------------------------------------------------------------------------------------------ +# 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 new file mode 100644 index 000000000..998f60326 --- /dev/null +++ b/cmake/Compiler-Intel.cmake @@ -0,0 +1,114 @@ +################################################################################################### +# Intel Compiler +################################################################################################### + if (OPENMP) + set (OPENMP_FLAGS "-qopenmp -parallel") + endif () + + if (OPTIMIZATION STREQUAL "OFF") + set (OPTIMIZATION_FLAGS "-O0 -no-ip") + elseif (OPTIMIZATION STREQUAL "DEFENSIVE") + set (OPTIMIZATION_FLAGS "-O2") + elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") + set (OPTIMIZATION_FLAGS "-ipo -O3 -no-prec-div -fp-model fast=2 -xHost") + # -fast = -ipo, -O3, -no-prec-div, -static, -fp-model fast=2, and -xHost" + endif () + + # -assume std_mod_proc_name (included in -standard-semantics) causes problems if other modules + # (PETSc, HDF5) are not compiled with this option (https://software.intel.com/en-us/forums/intel-fortran-compiler-for-linux-and-mac-os-x/topic/62172) + set (STANDARD_CHECK "-stand f15 -standard-semantics -assume nostd_mod_proc_name") + set (LINKER_FLAGS "${LINKER_FLAGS} -shared-intel") + # Link against shared Intel libraries instead of static ones + +#------------------------------------------------------------------------------------------------ +# Fine tuning compilation options + set (COMPILE_FLAGS "${COMPILE_FLAGS} -fpp") + # preprocessor + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -ftz") + # flush underflow to zero, automatically set if -O[1,2,3] + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -diag-disable") + # disables warnings ... + set (COMPILE_FLAGS "${COMPILE_FLAGS} 5268") + # ... the text exceeds right hand column allowed on the line (we have only comments there) + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -warn") + # enables warnings ... + set (COMPILE_FLAGS "${COMPILE_FLAGS} declarations") + # ... any undeclared names (alternative name: -implicitnone) + set (COMPILE_FLAGS "${COMPILE_FLAGS},general") + # ... warning messages and informational messages are issued by the compiler + set (COMPILE_FLAGS "${COMPILE_FLAGS},usage") + # ... questionable programming practices + set (COMPILE_FLAGS "${COMPILE_FLAGS},interfaces") + # ... checks the interfaces of all SUBROUTINEs called and FUNCTIONs invoked in your compilation against an external set of interface blocks + set (COMPILE_FLAGS "${COMPILE_FLAGS},ignore_loc") + # ... %LOC is stripped from an actual argument + set (COMPILE_FLAGS "${COMPILE_FLAGS},alignments") + # ... data that is not naturally aligned + set (COMPILE_FLAGS "${COMPILE_FLAGS},unused") + # ... declared variables that are never used + + # Additional options + # -warn: enables warnings, where + # truncated_source: Determines whether warnings occur when source exceeds the maximum column width in fixed-format files. + # (too many warnings because we have comments beyond character 132) + # uncalled: Determines whether warnings occur when a statement function is never called + # all: + # -name as_is: case sensitive Fortran! + +#------------------------------------------------------------------------------------------------ +# Runtime debugging + set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") + # Generate symbolic debugging information in the object file + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -traceback") + # Generate extra information in the object file to provide source file traceback information when a severe error occurs at run time + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -gen-interfaces") + # Generate an interface block for each routine. http://software.intel.com/en-us/blogs/2012/01/05/doctor-fortran-gets-explicit-again/ + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fp-stack-check") + # Generate extra code after every function call to ensure that the floating-point (FP) stack is in the expected state + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fp-model strict") + # Trap uninitalized variables + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -check" ) + # Checks at runtime ... + set (DEBUG_FLAGS "${DEBUG_FLAGS} bounds") + # ... if an array index is too small (<1) or too large! + set (DEBUG_FLAGS "${DEBUG_FLAGS},format") + # ... for the data type of an item being formatted for output. + set (DEBUG_FLAGS "${DEBUG_FLAGS},output_conversion") + # ... for the fit of data items within a designated format descriptor field. + set (DEBUG_FLAGS "${DEBUG_FLAGS},pointers") + # ... for certain disassociated or uninitialized pointers or unallocated allocatable objects. + set (DEBUG_FLAGS "${DEBUG_FLAGS},uninit") + # ... for uninitialized variables. + set (DEBUG_FLAGS "${DEBUG_FLAGS} -ftrapuv") + # ... initializes stack local variables to an unusual value to aid error detection + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fpe-all=0") + # ... capture all floating-point exceptions, sets -ftz automatically + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -warn") + # enables warnings ... + set (DEBUG_FLAGS "${DEBUG_FLAGS} errors") + # ... warnings are changed to errors + set (DEBUG_FLAGS "${DEBUG_FLAGS},stderrors") + # ... warnings about Fortran standard violations are changed to errors + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -debug-parameters all") + # generate debug information for parameters + + # Additional options + # -heap-arrays: Should not be done for OpenMP, but set "ulimit -s unlimited" on shell. Probably it helps also to unlimit other limits + # -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-PGI.cmake b/cmake/Compiler-PGI.cmake new file mode 100644 index 000000000..bca76f648 --- /dev/null +++ b/cmake/Compiler-PGI.cmake @@ -0,0 +1,25 @@ +################################################################################################### +# PGI Compiler +################################################################################################### +elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "PGI") + + if (OPTIMIZATION STREQUAL "OFF") + set (OPTIMIZATION_FLAGS "-O0" ) + elseif (OPTIMIZATION STREQUAL "DEFENSIVE") + set (OPTIMIZATION_FLAGS "-O2") + elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") + set (OPTIMIZATION_FLAGS "-O3") + endif () + + +#------------------------------------------------------------------------------------------------ +# Fine tuning compilation options + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Mpreprocess") + # preprocessor + + set (STANDARD_CHECK "-Mallocatable=03") + +#------------------------------------------------------------------------------------------------ +# Runtime debugging + set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") + # Includes debugging information in the object module; sets the optimization level to zero unless a -⁠O option is present on the command line diff --git a/env/DAMASK.csh b/env/DAMASK.csh index 1819dd305..d223d885a 100644 --- a/env/DAMASK.csh +++ b/env/DAMASK.csh @@ -13,9 +13,7 @@ set BRANCH = `git branch 2>/dev/null| grep -E '^\* ')` cd - >/dev/null # if DAMASK_BIN is present -if ( $?DAMASK_BIN) then - set path = ($DAMASK_BIN $path) -endif +set path = ($DAMASK_ROOT/bin $path) set SOLVER=`which DAMASK_spectral` set PROCESSING=`which postResults` diff --git a/env/DAMASK.sh b/env/DAMASK.sh index fa2c8db25..1b4bea86a 100644 --- a/env/DAMASK.sh +++ b/env/DAMASK.sh @@ -33,8 +33,7 @@ unset -f set # add BRANCH if DAMASK_ROOT is a git repository cd $DAMASK_ROOT >/dev/null; BRANCH=$(git branch 2>/dev/null| grep -E '^\* '); cd - >/dev/null -# add DAMASK_BIN if present -[ "x$DAMASK_BIN" != "x" ] && PATH=$DAMASK_BIN:$PATH +PATH=${DAMASK_ROOT}/bin:$PATH SOLVER=$(type -p DAMASK_spectral || true 2>/dev/null) [ "x$SOLVER" == "x" ] && SOLVER=$(blink 'Not found!') diff --git a/env/DAMASK.zsh b/env/DAMASK.zsh index 61b9c89f9..5449007f9 100644 --- a/env/DAMASK.zsh +++ b/env/DAMASK.zsh @@ -25,7 +25,7 @@ unset -f set cd $DAMASK_ROOT >/dev/null; BRANCH=$(git branch 2>/dev/null| grep -E '^\* '); cd - >/dev/null # add DAMASK_BIN if present -[[ "x$DAMASK_BIN" != "x" ]] && PATH=$DAMASK_BIN:$PATH +PATH=${DAMASK_ROOT}/bin:$PATH SOLVER=$(which DAMASK_spectral || true 2>/dev/null) [[ "x$SOLVER" == "x" ]] && SOLVER=$(blink 'Not found!') diff --git a/examples/SpectralMethod/Polycrystal/material.config b/examples/SpectralMethod/Polycrystal/material.config index 39e7f1952..71d7e07d7 100644 --- a/examples/SpectralMethod/Polycrystal/material.config +++ b/examples/SpectralMethod/Polycrystal/material.config @@ -30,11 +30,20 @@ plasticity phenopowerlaw (output) resistance_slip (output) shearrate_slip (output) resolvedstress_slip -(output) totalshear +(output) accumulatedshear_slip (output) resistance_twin (output) shearrate_twin (output) resolvedstress_twin -(output) totalvolfrac +(output) accumulatedshear_twin + +# only for HDF5 out +(output) orientation # quaternion +(output) f # deformation gradient tensor; synonyms: "defgrad" +(output) fe # elastic deformation gradient tensor +(output) fp # plastic deformation gradient tensor +(output) p # first Piola-Kichhoff stress tensor; synonyms: "firstpiola", "1stpiola" +(output) lp # plastic velocity gradient tensor + lattice_structure fcc Nslip 12 # per family diff --git a/installation/mods_Abaqus/abaqus_v6.env b/installation/mods_Abaqus/abaqus_v6.env index 0811d0f65..83cc2ed33 100644 --- a/installation/mods_Abaqus/abaqus_v6.env +++ b/installation/mods_Abaqus/abaqus_v6.env @@ -16,7 +16,7 @@ if False: # use hdf5 compiler wrapper in $PATH fortCmd = os.popen('h5fc -shlib -show').read().replace('\n','') # complicated way needed to pass in DAMASKVERSION string link_sl += fortCmd.split()[1:] - fortCmd +=" -DDAMASKHDF5" + fortCmd +=" -DDAMASK_HDF5" else: # Use the version in $PATH fortCmd = "ifort" diff --git a/installation/mods_Abaqus/abaqus_v6_debug.env b/installation/mods_Abaqus/abaqus_v6_debug.env index 943f40bfa..943d0d10e 100644 --- a/installation/mods_Abaqus/abaqus_v6_debug.env +++ b/installation/mods_Abaqus/abaqus_v6_debug.env @@ -16,7 +16,7 @@ if False: # use hdf5 compiler wrapper in $PATH fortCmd = os.popen('h5fc -shlib -show').read().replace('\n','') # complicated way needed to pass in DAMASKVERSION string link_sl += fortCmd.split()[1:] - fortCmd +=" -DDAMASKHDF5" + fortCmd +=" -DDAMASK_HDF5" else: # Use the version in $PATH fortCmd = "ifort" diff --git a/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 index 661d3aaca..538434ad0 100644 --- a/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 @@ -102,7 +102,7 @@ fi if test "$DAMASK_HDF5" = "ON";then H5FC="$(h5fc -shlib -show)" HDF5_LIB=${H5FC//ifort/} - FCOMP="$H5FC -DDAMASKHDF5" + FCOMP="$H5FC -DDAMASK_HDF5" echo $FCOMP else FCOMP=ifort diff --git a/installation/mods_MarcMentat/2018/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2018/Marc_tools/include_linux64 index 270184af2..d3151ac6c 100644 --- a/installation/mods_MarcMentat/2018/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2018/Marc_tools/include_linux64 @@ -63,7 +63,6 @@ else INTEGER_PATH=/$MARC_INTEGER_SIZE fi -FCOMP=ifort INTELPATH="/opt/intel/compilers_and_libraries_2017/linux" # find the root directory of the compiler installation: @@ -99,6 +98,16 @@ else FCOMPROOT= fi +# DAMASK uses the HDF5 compiler wrapper around the Intel compiler +if test "$DAMASK_HDF5" = "ON";then + H5FC="$(h5fc -shlib -show)" + HDF5_LIB=${H5FC//ifort/} + FCOMP="$H5FC -DDAMASK_HDF5" + echo $FCOMP +else + FCOMP=ifort +fi + # AEM if test "$MARCDLLOUTDIR" = ""; then DLLOUTDIR="$MARC_LIB" @@ -535,6 +544,7 @@ else DAMASKVERSION="'N/A'" fi + # DAMASK compiler calls: additional flags are in line 2 OpenMP flags in line 3 DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2018 -DDAMASKVERSION=$DAMASKVERSION \ @@ -737,7 +747,7 @@ SECLIBS="-L$MARC_LIB -llapi" SOLVERLIBS="${BCSSOLVERLIBS} ${VKISOLVERLIBS} ${CASISOLVERLIBS} ${MF2SOLVERLIBS} \ $MKLLIB -L$MARC_MKL -liomp5 \ - $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/kdtree2.a " + $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/kdtree2.a $HDF5_LIB " SOLVERLIBS_DLL=${SOLVERLIBS} if test "$AEM_DLL" -eq 1 diff --git a/installation/patch/README.md b/installation/patch/README.md index dd8232758..0b8251510 100644 --- a/installation/patch/README.md +++ b/installation/patch/README.md @@ -12,7 +12,10 @@ patch -p1 < installation/patch/nameOfPatch ## Available patches * **disable_HDF5** disables all HDF5 output. - HDF5 output is an experimental feature. Also, some routines not present in HDF5 1.8.x are remove to allow compilation of DAMASK with HDF5 < 1.10.x + HDF5 output is an experimental feature. Also, some routines not present in HDF5 1.8.x are removed to allow compilation of DAMASK with HDF5 < 1.10.x + + * **disable_old_output** disables all non-HDF5 output. + Saves some memory when using only HDF5 output ## Create patch commit your changes diff --git a/installation/patch/disable_old_output b/installation/patch/disable_old_output new file mode 100644 index 000000000..732dfc83e --- /dev/null +++ b/installation/patch/disable_old_output @@ -0,0 +1,178 @@ +From 6dbd904a4cfc28add3c39bb2a4ec9e2dbb2442b6 Mon Sep 17 00:00:00 2001 +From: Martin Diehl +Date: Thu, 18 Apr 2019 18:25:32 +0200 +Subject: [PATCH] to create patch + +--- + src/DAMASK_grid.f90 | 81 +----------------------------------------- + src/homogenization.f90 | 2 ++ + 2 files changed, 3 insertions(+), 80 deletions(-) + +diff --git a/src/DAMASK_grid.f90 b/src/DAMASK_grid.f90 +index f2f52bb2..a7543f4d 100644 +--- a/src/DAMASK_grid.f90 ++++ b/src/DAMASK_grid.f90 +@@ -18,7 +18,6 @@ program DAMASK_spectral + use DAMASK_interface, only: & + DAMASK_interface_init, & + loadCaseFile, & +- geometryFile, & + getSolverJobName, & + interface_restartInc + use IO, only: & +@@ -49,14 +48,9 @@ program DAMASK_spectral + restartInc + use numerics, only: & + worldrank, & +- worldsize, & + stagItMax, & + maxCutBack, & + continueCalculation +- use homogenization, only: & +- materialpoint_sizeResults, & +- materialpoint_results, & +- materialpoint_postResults + use material, only: & + thermal_type, & + damage_type, & +@@ -131,12 +125,6 @@ program DAMASK_spectral + type(tLoadCase), allocatable, dimension(:) :: loadCases !< array of all load cases + type(tLoadCase) :: newLoadCase + type(tSolutionState), allocatable, dimension(:) :: solres +- integer(MPI_OFFSET_KIND) :: fileOffset +- integer(MPI_OFFSET_KIND), dimension(:), allocatable :: outputSize +- integer(pInt), parameter :: maxByteOut = 2147483647-4096 !< limit of one file output write https://trac.mpich.org/projects/mpich/ticket/1742 +- integer(pInt), parameter :: maxRealOut = maxByteOut/pReal +- integer(pLongInt), dimension(2) :: outputIndex +- PetscErrorCode :: ierr + procedure(grid_mech_spectral_basic_init), pointer :: & + mech_init + procedure(grid_mech_spectral_basic_forward), pointer :: & +@@ -384,22 +372,6 @@ program DAMASK_spectral + ! write header of output file + if (worldrank == 0) then + writeHeader: if (interface_restartInc < 1_pInt) then +- open(newunit=fileUnit,file=trim(getSolverJobName())//& +- '.spectralOut',form='UNFORMATTED',status='REPLACE') +- write(fileUnit) 'load:', trim(loadCaseFile) ! ... and write header +- write(fileUnit) 'workingdir:', 'n/a' +- write(fileUnit) 'geometry:', trim(geometryFile) +- write(fileUnit) 'grid:', grid +- write(fileUnit) 'size:', geomSize +- write(fileUnit) 'materialpoint_sizeResults:', materialpoint_sizeResults +- write(fileUnit) 'loadcases:', size(loadCases) +- write(fileUnit) 'frequencies:', loadCases%outputfrequency ! one entry per LoadCase +- write(fileUnit) 'times:', loadCases%time ! one entry per LoadCase +- write(fileUnit) 'logscales:', loadCases%logscale +- write(fileUnit) 'increments:', loadCases%incs ! one entry per LoadCase +- write(fileUnit) 'startingIncrement:', restartInc ! start with writing out the previous inc +- write(fileUnit) 'eoh' +- close(fileUnit) ! end of header + open(newunit=statUnit,file=trim(getSolverJobName())//& + '.sta',form='FORMATTED',status='REPLACE') + write(statUnit,'(a)') 'Increment Time CutbackLevel Converged IterationsNeeded' ! statistics file +@@ -412,39 +384,6 @@ program DAMASK_spectral + endif writeHeader + endif + +-!-------------------------------------------------------------------------------------------------- +-! prepare MPI parallel out (including opening of file) +- allocate(outputSize(worldsize), source = 0_MPI_OFFSET_KIND) +- outputSize(worldrank+1) = size(materialpoint_results,kind=MPI_OFFSET_KIND)*int(pReal,MPI_OFFSET_KIND) +- call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process +- if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_allreduce') +- call MPI_file_open(PETSC_COMM_WORLD, trim(getSolverJobName())//'.spectralOut', & +- MPI_MODE_WRONLY + MPI_MODE_APPEND, & +- MPI_INFO_NULL, & +- fileUnit, & +- ierr) +- if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_file_open') +- call MPI_file_get_position(fileUnit,fileOffset,ierr) ! get offset from header +- if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_file_get_position') +- fileOffset = fileOffset + sum(outputSize(1:worldrank)) ! offset of my process in file (header + processes before me) +- call MPI_file_seek (fileUnit,fileOffset,MPI_SEEK_SET,ierr) +- if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_file_seek') +- +- writeUndeformed: if (interface_restartInc < 1_pInt) then +- write(6,'(1/,a)') ' ... writing initial configuration to file ........................' +- call CPFEM_results(0_pInt,0.0_pReal) +- do i = 1, size(materialpoint_results,3)/(maxByteOut/(materialpoint_sizeResults*pReal))+1 ! slice the output of my process in chunks not exceeding the limit for one output +- outputIndex = int([(i-1_pInt)*((maxRealOut)/materialpoint_sizeResults)+1_pInt, & ! QUESTION: why not starting i at 0 instead of murky 1? +- min(i*((maxRealOut)/materialpoint_sizeResults),size(materialpoint_results,3))],pLongInt) +- call MPI_file_write(fileUnit,reshape(materialpoint_results(:,:,outputIndex(1):outputIndex(2)), & +- [(outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)]), & +- int((outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)), & +- MPI_DOUBLE, MPI_STATUS_IGNORE, ierr) +- if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_file_write') +- enddo +- fileOffset = fileOffset + sum(outputSize) ! forward to current file position +- endif writeUndeformed +- + + loadCaseLooping: do currentLoadCase = 1_pInt, size(loadCases) + time0 = time ! load case start time +@@ -574,7 +513,6 @@ program DAMASK_spectral + write(6,'(/,a)') ' cutting back ' + else ! no more options to continue + call IO_warning(850_pInt) +- call MPI_file_close(fileUnit,ierr) + close(statUnit) + call quit(-1_pInt*(lastRestartWritten+1_pInt)) ! quit and provide information about last restart inc written + endif +@@ -593,24 +531,8 @@ program DAMASK_spectral + ' increment ', totalIncsCounter, ' NOT converged' + endif; flush(6) + +- if (mod(inc,loadCases(currentLoadCase)%outputFrequency) == 0_pInt) then ! at output frequency +- write(6,'(1/,a)') ' ... writing results to file ......................................' +- flush(6) +- call materialpoint_postResults() +- call MPI_file_seek (fileUnit,fileOffset,MPI_SEEK_SET,ierr) +- if (ierr /= 0_pInt) call IO_error(894_pInt, ext_msg='MPI_file_seek') +- do i=1, size(materialpoint_results,3)/(maxByteOut/(materialpoint_sizeResults*pReal))+1 ! slice the output of my process in chunks not exceeding the limit for one output +- outputIndex=int([(i-1_pInt)*((maxRealOut)/materialpoint_sizeResults)+1_pInt, & +- min(i*((maxRealOut)/materialpoint_sizeResults),size(materialpoint_results,3))],pLongInt) +- call MPI_file_write(fileUnit,reshape(materialpoint_results(:,:,outputIndex(1):outputIndex(2)),& +- [(outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)]), & +- int((outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)),& +- MPI_DOUBLE, MPI_STATUS_IGNORE, ierr) +- if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='MPI_file_write') +- enddo +- fileOffset = fileOffset + sum(outputSize) ! forward to current file position ++ if (mod(inc,loadCases(currentLoadCase)%outputFrequency) == 0_pInt) & ! at output frequency + call CPFEM_results(totalIncsCounter,time) +- endif + if ( loadCases(currentLoadCase)%restartFrequency > 0_pInt & ! writing of restart info requested ... + .and. mod(inc,loadCases(currentLoadCase)%restartFrequency) == 0_pInt) then ! ... and at frequency of writing restart information + restartWrite = .true. ! set restart parameter for FEsolving +@@ -633,7 +555,6 @@ program DAMASK_spectral + real(convergedCounter, pReal)/& + real(notConvergedCounter + convergedCounter,pReal)*100.0_pReal, ' %) increments converged!' + flush(6) +- call MPI_file_close(fileUnit,ierr) + close(statUnit) + + if (notConvergedCounter > 0_pInt) call quit(2_pInt) ! error if some are not converged +diff --git a/src/homogenization.f90 b/src/homogenization.f90 +index 06da6ab2..0743d545 100644 +--- a/src/homogenization.f90 ++++ b/src/homogenization.f90 +@@ -269,6 +269,7 @@ subroutine homogenization_init + + homogenization_maxNgrains * (1 + crystallite_maxSizePostResults & ! crystallite size & crystallite results + + 1 + constitutive_plasticity_maxSizePostResults & ! constitutive size & constitutive results + + constitutive_source_maxSizePostResults) ++ materialpoint_sizeResults = 0 + allocate(materialpoint_results(materialpoint_sizeResults,theMesh%elem%nIPs,theMesh%nElems)) + + write(6,'(/,a)') ' <<<+- homogenization init -+>>>' +@@ -682,6 +683,7 @@ subroutine materialpoint_postResults + i, & !< integration point number + e !< element number + ++ return + !$OMP PARALLEL DO PRIVATE(myNgrains,myCrystallite,thePos,theSize) + elementLooping: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNgrains = homogenization_Ngrains(mesh_element(3,e)) +-- +2.21.0 + diff --git a/installation/symlink_Processing.py b/installation/symlink_Processing.py index 60f8d3639..90497c0eb 100755 --- a/installation/symlink_Processing.py +++ b/installation/symlink_Processing.py @@ -7,7 +7,7 @@ import damask damaskEnv = damask.Environment() baseDir = damaskEnv.relPath('processing/') -binDir = damaskEnv.options['DAMASK_BIN'] +binDir = damaskEnv.relPath('bin/') if not os.path.isdir(binDir): os.mkdir(binDir) diff --git a/processing/post/DADF5_vtk_cells.py b/processing/post/DADF5_vtk_cells.py new file mode 100755 index 000000000..3bbf9fd45 --- /dev/null +++ b/processing/post/DADF5_vtk_cells.py @@ -0,0 +1,92 @@ +#!/usr/bin/env python3 +# -*- coding: UTF-8 no BOM -*- + +import os,vtk +import numpy as np +import argparse +import damask +from vtk.util import numpy_support + +scriptName = os.path.splitext(os.path.basename(__file__))[0] +scriptID = ' '.join([scriptName,damask.version]) + +# -------------------------------------------------------------------- +# MAIN +# -------------------------------------------------------------------- +parser = argparse.ArgumentParser() + +#ToDo: We need to decide on a way of handling arguments of variable lentght +#https://stackoverflow.com/questions/15459997/passing-integer-lists-to-python + +#parser.add_argument('--version', action='version', version='%(prog)s {}'.format(scriptID)) +parser.add_argument('filenames', nargs='+', + help='DADF5 files') + +options = parser.parse_args() + +options.labels = ['Fe','Fp','xi_sl'] + +# --- loop over input files ------------------------------------------------------------------------ + +for filename in options.filenames: + results = damask.DADF5(filename) + + if results.structured: # for grid solvers use rectilinear grid + rGrid = vtk.vtkRectilinearGrid() + coordArray = [vtk.vtkDoubleArray(), + vtk.vtkDoubleArray(), + vtk.vtkDoubleArray(), + ] + + rGrid.SetDimensions(*(results.grid+1)) + for dim in [0,1,2]: + for c in np.linspace(0,results.size[dim],1+results.grid[dim]): + coordArray[dim].InsertNextValue(c) + + rGrid.SetXCoordinates(coordArray[0]) + rGrid.SetYCoordinates(coordArray[1]) + rGrid.SetZCoordinates(coordArray[2]) + + + for i,inc in enumerate(results.increments): + print('Output step {}/{}'.format(i+1,len(results.increments))) + vtk_data = [] + results.active['increments'] = [inc] + for label in options.labels: + for o in results.c_output_types: + results.active['c_output_types'] = [o] + if o != 'generic': + for c in results.constituents: + results.active['constituents'] = [c] + x = results.get_dataset_location(label) + if len(x) == 0: + continue + array = results.read_dataset(x,0) + shape = [array.shape[0],np.product(array.shape[1:])] + vtk_data.append(numpy_support.numpy_to_vtk(num_array=array.reshape(shape),deep=True,array_type= vtk.VTK_DOUBLE)) + vtk_data[-1].SetName('1_'+x[0].split('/',1)[1]) + rGrid.GetCellData().AddArray(vtk_data[-1]) + else: + results.active['constituents'] = results.constituents + x = results.get_dataset_location(label) + if len(x) == 0: + continue + array = results.read_dataset(x,0) + shape = [array.shape[0],np.product(array.shape[1:])] + vtk_data.append(numpy_support.numpy_to_vtk(num_array=array.reshape(shape),deep=True,array_type= vtk.VTK_DOUBLE)) + vtk_data[-1].SetName('1_'+x[0].split('/')[1]+'/generic/'+label) + rGrid.GetCellData().AddArray(vtk_data[-1]) + + if results.structured: + writer = vtk.vtkXMLRectilinearGridWriter() + + writer.SetCompressorTypeToZLib() + writer.SetDataModeToBinary() + writer.SetFileName(os.path.join(os.path.split(filename)[0], + os.path.splitext(os.path.split(filename)[1])[0] + + '_inc{:04d}'.format(i) + # ToDo: adjust to length of increments + '.' + writer.GetDefaultFileExtension())) + if results.structured: + writer.SetInputData(rGrid) + + writer.Write() diff --git a/processing/post/addDisplacement.py b/processing/post/addDisplacement.py index aa12ba2b1..53311ce9e 100755 --- a/processing/post/addDisplacement.py +++ b/processing/post/addDisplacement.py @@ -40,9 +40,10 @@ def displacementAvgFFT(F,grid,size,nodal=False,transformed=False): np.linspace(0,size[0],1+grid[0]), indexing = 'ij') else: - x, y, z = np.meshgrid(np.linspace(0,size[2],grid[2],endpoint=False), - np.linspace(0,size[1],grid[1],endpoint=False), - np.linspace(0,size[0],grid[0],endpoint=False), + delta = size/grid*0.5 + x, y, z = np.meshgrid(np.linspace(delta[2],size[2]-delta[2],grid[2]), + np.linspace(delta[1],size[1]-delta[1],grid[1]), + np.linspace(delta[0],size[0]-delta[0],grid[0]), indexing = 'ij') origCoords = np.concatenate((z[:,:,:,None],y[:,:,:,None],x[:,:,:,None]),axis = 3) diff --git a/python/.gitignore b/python/.gitignore new file mode 100644 index 000000000..bd729dc2c --- /dev/null +++ b/python/.gitignore @@ -0,0 +1,2 @@ +dist +damask.egg-info diff --git a/python/MANIFEST.in b/python/MANIFEST.in new file mode 100644 index 000000000..bb6d21f36 --- /dev/null +++ b/python/MANIFEST.in @@ -0,0 +1 @@ +include damask/VERSION diff --git a/python/damask/.gitignore b/python/damask/.gitignore deleted file mode 100644 index 1b8936623..000000000 --- a/python/damask/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -core.so -corientation.so -*.pyx diff --git a/python/damask/LICENSE b/python/damask/LICENSE new file mode 120000 index 000000000..30cff7403 --- /dev/null +++ b/python/damask/LICENSE @@ -0,0 +1 @@ +../../LICENSE \ No newline at end of file diff --git a/python/damask/README b/python/damask/README new file mode 120000 index 000000000..3830a4118 --- /dev/null +++ b/python/damask/README @@ -0,0 +1 @@ +../../README \ No newline at end of file diff --git a/python/damask/VERSION b/python/damask/VERSION new file mode 120000 index 000000000..558194c5a --- /dev/null +++ b/python/damask/VERSION @@ -0,0 +1 @@ +../../VERSION \ No newline at end of file diff --git a/python/damask/__init__.py b/python/damask/__init__.py index d7ed4a9f9..684ab48b5 100644 --- a/python/damask/__init__.py +++ b/python/damask/__init__.py @@ -3,8 +3,8 @@ """Main aggregator""" import os -with open(os.path.join(os.path.dirname(__file__),'../../VERSION')) as f: - version = f.readline()[:-1] +with open(os.path.join(os.path.dirname(__file__),'VERSION')) as f: + version = f.readline()[1:-1] name = 'damask' @@ -14,6 +14,7 @@ from .asciitable import ASCIItable # noqa from .config import Material # noqa from .colormaps import Colormap, Color # noqa from .orientation import Symmetry, Lattice, Rotation, Orientation # noqa +from .dadf5 import DADF5 # noqa #from .block import Block # only one class from .result import Result # noqa diff --git a/python/damask/dadf5.py b/python/damask/dadf5.py new file mode 100644 index 000000000..4214f4922 --- /dev/null +++ b/python/damask/dadf5.py @@ -0,0 +1,112 @@ +# -*- coding: UTF-8 no BOM -*- +import h5py +import re +import numpy as np + +# ------------------------------------------------------------------ +class DADF5(): + """Read and write to DADF5 files""" + +# ------------------------------------------------------------------ + def __init__(self, + filename, + mode = 'r', + ): + + if mode not in ['a','r']: + print('Invalid file access mode') + with h5py.File(filename,mode): + pass + + with h5py.File(filename,'r') as f: + + if f.attrs['DADF5-major'] != 0 or f.attrs['DADF5-minor'] != 1: + raise TypeError('Unsupported DADF5 version {} '.format(f.attrs['DADF5-version'])) + + self.structured = 'grid' in f['mapping'].attrs.keys() + + if self.structured: + self.grid = f['mapping'].attrs['grid'] + self.size = f['mapping'].attrs['size'] + + r=re.compile('inc[0-9]+') + self.increments = [{'inc': int(u[3:]), + 'time': round(f[u].attrs['time/s'],12), + } for u in f.keys() if r.match(u)] + + self.constituents = np.unique(f['mapping/cellResults/constituent']['Name']).tolist() # ToDo: I am not to happy with the name + self.constituents = [c.decode() for c in self.constituents] + + self.materialpoints = np.unique(f['mapping/cellResults/materialpoint']['Name']).tolist() # ToDo: I am not to happy with the name + self.materialpoints = [m.decode() for m in self.materialpoints] + + self.Nconstituents = [i for i in range(np.shape(f['mapping/cellResults/constituent'])[1])] + self.Nmaterialpoints = np.shape(f['mapping/cellResults/constituent'])[0] + + self.c_output_types = [] + for c in self.constituents: + for o in f['inc{:05}/constituent/{}'.format(self.increments[0]['inc'],c)].keys(): + self.c_output_types.append(o) + self.c_output_types = list(set(self.c_output_types)) # make unique + + self.active= {'increments': self.increments, + 'constituents': self.constituents, + 'materialpoints': self.materialpoints, + 'constituent': self.Nconstituents, + 'c_output_types': self.c_output_types} + + self.filename = filename + self.mode = mode + + def list_data(self): + """Shows information on all datasets in the file""" + with h5py.File(self.filename,'r') as f: + group_inc = 'inc{:05}'.format(self.active['increments'][0]['inc']) + for c in self.active['constituents']: + print('\n'+c) + group_constituent = group_inc+'/constituent/'+c + for t in self.active['c_output_types']: + print(' {}'.format(t)) + group_output_types = group_constituent+'/'+t + try: + for x in f[group_output_types].keys(): + print(' {} ({})'.format(x,f[group_output_types+'/'+x].attrs['Description'].decode())) + except: + pass + + + def get_dataset_location(self,label): + """Returns the location of all active datasets with given label""" + path = [] + with h5py.File(self.filename,'r') as f: + for i in self.active['increments']: + group_inc = 'inc{:05}'.format(i['inc']) + for c in self.active['constituents']: + group_constituent = group_inc+'/constituent/'+c + for t in self.active['c_output_types']: + try: + f[group_constituent+'/'+t+'/'+label] + path.append(group_constituent+'/'+t+'/'+label) + except: + pass + return path + + + def read_dataset(self,path,c): + """ + Dataset for all points/cells + + If more than one path is given, the dataset is composed of the individual contributions + """ + with h5py.File(self.filename,'r') as f: + shape = (self.Nmaterialpoints,) + np.shape(f[path[0]])[1:] + dataset = np.full(shape,np.nan) + for pa in path: + label = pa.split('/')[2] + p = np.where(f['mapping/cellResults/constituent'][:,c]['Name'] == str.encode(label))[0] + u = (f['mapping/cellResults/constituent'][p,c]['Position']) + dataset[p,:] = f[pa][u,:] + + return dataset + + diff --git a/python/damask/environment.py b/python/damask/environment.py index 17786ab28..21eb24694 100644 --- a/python/damask/environment.py +++ b/python/damask/environment.py @@ -1,6 +1,6 @@ # -*- coding: UTF-8 no BOM -*- -import os,subprocess,shlex,re +import os,re class Environment(): __slots__ = [ \ @@ -26,24 +26,3 @@ class Environment(): if len(items) == 2: self.options[items[0].upper()] = \ re.sub('\$\{*DAMASK_ROOT\}*',self.rootDir(),os.path.expandvars(items[1])) # expand all shell variables and DAMASK_ROOT - - def isAvailable(self,software,Nneeded =-1): - licensesNeeded = {'abaqus' :5, - 'standard':5 - } - if Nneeded == -1: Nneeded = licensesNeeded[software] - try: - cmd = """ ssh mulicense2 "/lm-status | grep 'Users of %s: ' | cut -d' ' -f7,13" """%software - process = subprocess.Popen(shlex.split(cmd),stdout = subprocess.PIPE,stderr = subprocess.PIPE) - licenses = list(map(int, process.stdout.readline().split())) - try: - if licenses[0]-licenses[1] >= Nneeded: - return 0 - else: - print('%s missing licenses for %s'%(licenses[1] + Nneeded - licenses[0],software)) - return licenses[1] + Nneeded - licenses[0] - except IndexError: - print('Could not retrieve license information for %s'%software) - return 127 - except: - return 126 diff --git a/python/damask/orientation.py b/python/damask/orientation.py index 00550d986..51b6f849f 100644 --- a/python/damask/orientation.py +++ b/python/damask/orientation.py @@ -626,8 +626,8 @@ class Lattice: # Kurdjomov--Sachs orientation relationship for fcc <-> bcc transformation - # from S. Morito et al./Journal of Alloys and Compounds 5775 (2013) S587-S592 - # also see K. Kitahara et al./Acta Materialia 54 (2006) 1279-1288 + # from S. Morito et al. Journal of Alloys and Compounds 577 (2013) 587-S592 + # also see K. Kitahara et al. Acta Materialia 54 (2006) 1279-1288 KS = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 1, 1, 1],[ 0, 1, 1]], @@ -681,7 +681,7 @@ class Lattice: [[ 1, 0, 1],[ -1, 1, -1]]],dtype='float')} # Greninger--Troiano orientation relationship for fcc <-> bcc transformation - # from Y. He et al./Journal of Applied Crystallography (2006). 39, 72-81 + # from Y. He et al. Journal of Applied Crystallography 39 (2006) 72-81 GT = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 1, 1, 1],[ 1, 0, 1]], @@ -735,7 +735,7 @@ class Lattice: [[-17,-12, 5],[-17, 7, 17]]],dtype='float')} # Greninger--Troiano' orientation relationship for fcc <-> bcc transformation - # from Y. He et al./Journal of Applied Crystallography (2006). 39, 72-81 + # from Y. He et al. Journal of Applied Crystallography 39 (2006) 72-81 GTprime = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 7, 17, 17],[ 12, 5, 17]], @@ -789,7 +789,7 @@ class Lattice: [[ 1, 1, 0],[ 1, 1, -1]]],dtype='float')} # Nishiyama--Wassermann orientation relationship for fcc <-> bcc transformation - # from H. Kitahara et al./Materials Characterization 54 (2005) 378-386 + # from H. Kitahara et al. Materials Characterization 54 (2005) 378-386 NW = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 1, 1, 1],[ 0, 1, 1]], @@ -819,7 +819,7 @@ class Lattice: [[ -1, -1, -2],[ 0, -1, 1]]],dtype='float')} # Pitsch orientation relationship for fcc <-> bcc transformation - # from Y. He et al./Acta Materialia 53 (2005) 1179-1190 + # from Y. He et al. Acta Materialia 53 (2005) 1179-1190 Pitsch = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 0, 1, 0],[ -1, 0, 1]], diff --git a/python/setup.py b/python/setup.py new file mode 100644 index 000000000..515401c59 --- /dev/null +++ b/python/setup.py @@ -0,0 +1,28 @@ +import setuptools +import os + +with open(os.path.join(os.path.dirname(__file__),'damask/VERSION')) as f: + version = f.readline()[1:-1] + +setuptools.setup( + name="damask", + version=version, + author="The DAMASK team", + author_email="damask@mpie.de", + description="DAMASK library", + long_description="Python library for pre and post processing of DAMASK simulations", + url="https://damask.mpie.de", + packages=setuptools.find_packages(), + include_package_data=True, + install_requires = [ + "scipy", + "h5py", + "vtk" + ], + license = 'GPL3', + classifiers = [ + "Programming Language :: Python :: 3", + "License :: OSI Approved :: GPL3", + "Operating System :: OS Independent", + ], +) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 274069226..b2eee5561 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -4,43 +4,37 @@ if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") SET_SOURCE_FILES_PROPERTIES("lattice.f90" PROPERTIES COMPILE_FLAGS "-ffree-line-length-240") endif() -file(GLOB_RECURSE sources *.f90 *.c) +file(GLOB damask-sources *.f90 *.c) # probably we should have subfolders for abaqus and MSC.Marc -list(FILTER sources EXCLUDE REGEX ".*CPFEM\\.f90") -list(FILTER sources EXCLUDE REGEX ".*DAMASK_marc.*\\.f90") -list(FILTER sources EXCLUDE REGEX ".*mesh_marc.*\\.f90") -list(FILTER sources EXCLUDE REGEX ".*mesh_abaqus.*\\.f90") -list(FILTER sources EXCLUDE REGEX ".*commercialFEM_fileList.*\\.f90") +list(FILTER damask-sources EXCLUDE REGEX ".*CPFEM.f90") +list(FILTER damask-sources EXCLUDE REGEX ".*DAMASK_marc.*.f90") +list(FILTER damask-sources EXCLUDE REGEX ".*mesh_marc.*.f90") +list(FILTER damask-sources EXCLUDE REGEX ".*mesh_abaqus.*.f90") +list(FILTER damask-sources EXCLUDE REGEX ".*commercialFEM_fileList.*.f90") -if (PROJECT_NAME STREQUAL "DAMASK_grid") +if (PROJECT_NAME STREQUAL "damask-grid") - # probably we should have subfolders for FEM and spectral - list(FILTER sources EXCLUDE REGEX ".*DAMASK_FEM.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*FEM_utilities.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*FEM_zoo.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*mesh_FEM.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*FEM_mech.*\\.f90") + list(FILTER damask-sources EXCLUDE REGEX ".*mesh_FEM.*.f90") + file(GLOB grid-sources grid/*.f90) if(NOT CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") - add_executable(DAMASK_spectral ${sources}) + add_executable(DAMASK_spectral ${damask-sources} ${grid-sources}) + install (TARGETS DAMASK_spectral RUNTIME DESTINATION bin) else() - add_library(DAMASK_spectral OBJECT ${sources}) + add_library(DAMASK_spectral OBJECT ${damask-sources} ${grid-sources}) + exec_program (mktemp OUTPUT_VARIABLE nothing) + exec_program (mktemp ARGS -d OUTPUT_VARIABLE black_hole) + install (PROGRAMS ${nothing} DESTINATION ${black_hole}) endif() -elseif (PROJECT_NAME STREQUAL "DAMASK_FEM") +elseif (PROJECT_NAME STREQUAL "damask-mesh") - # probably we should have subfolders for FEM and spectral - list(FILTER sources EXCLUDE REGEX ".*DAMASK_grid.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*grid_mech_FEM.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*grid_mech_spectral_basic.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*grid_mech_spectral_polarisation.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*grid_damage_spectral.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*grid_thermal_spectral.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*spectral_utilities.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*mesh_grid.*\\.f90") + list(FILTER damask-sources EXCLUDE REGEX ".*mesh_grid.*.f90") + file(GLOB mesh-sources mesh/*.f90) - add_executable(DAMASK_FEM ${sources}) + add_executable(DAMASK_FEM ${damask-sources} ${mesh-sources}) + install (TARGETS DAMASK_FEM RUNTIME DESTINATION bin) endif() diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index d34a79bf7..d2eaa7979 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -72,6 +72,12 @@ subroutine CPFEM_initAll(el,ip) mesh_init use material, only: & material_init +#ifdef DAMASK_HDF5 + use HDF5_utilities, only: & + HDF5_utilities_init + use results, only: & + results_init +#endif use lattice, only: & lattice_init use constitutive, only: & @@ -100,6 +106,10 @@ subroutine CPFEM_initAll(el,ip) call FE_init call mesh_init(ip, el) call lattice_init +#ifdef DAMASK_HDF5 + call HDF5_utilities_init + call results_init +#endif call material_init call constitutive_init call crystallite_init diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 13d7f06c4..0ecea2b44 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -72,9 +72,9 @@ subroutine CPFEM_initAll() call FE_init call mesh_init call lattice_init - call material_init call HDF5_utilities_init call results_init + call material_init call constitutive_init call crystallite_init call homogenization_init @@ -257,7 +257,7 @@ subroutine CPFEM_age() write(6,'(a)') '<< CPFEM >> writing restart variables of last converged step to hdf5 file' write(rankStr,'(a1,i0)')'_',worldrank - fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','a') call HDF5_write(fileHandle,material_phase, 'recordedPhase') call HDF5_write(fileHandle,crystallite_F0, 'convergedF') @@ -300,6 +300,8 @@ subroutine CPFEM_results(inc,time) use HDF5_utilities use constitutive, only: & constitutive_results + use crystallite, only: & + crystallite_results implicit none integer(pInt), intent(in) :: inc @@ -307,7 +309,8 @@ subroutine CPFEM_results(inc,time) call results_openJobFile call results_addIncrement(inc,time) - call constitutive_results() + call constitutive_results + call crystallite_results call results_removeLink('current') ! ToDo: put this into closeJobFile call results_closeJobFile diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index a81aaee0e..731b44f06 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -5,11 +5,11 @@ !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !-------------------------------------------------------------------------------------------------- module HDF5_utilities - use prec - use IO - use HDF5 + use prec + use IO + use HDF5 #ifdef PETSc - use PETSC + use PETSC #endif implicit none @@ -19,76 +19,83 @@ module HDF5_utilities !> @brief reads pInt or pReal data of defined shape from file ! ToDo: order of arguments wrong !> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- - interface HDF5_read - module procedure HDF5_read_pReal1 - module procedure HDF5_read_pReal2 - module procedure HDF5_read_pReal3 - module procedure HDF5_read_pReal4 - module procedure HDF5_read_pReal5 - module procedure HDF5_read_pReal6 - module procedure HDF5_read_pReal7 - - module procedure HDF5_read_pInt1 - module procedure HDF5_read_pInt2 - module procedure HDF5_read_pInt3 - module procedure HDF5_read_pInt4 - module procedure HDF5_read_pInt5 - module procedure HDF5_read_pInt6 - module procedure HDF5_read_pInt7 - - end interface HDF5_read + interface HDF5_read + module procedure HDF5_read_real1 + module procedure HDF5_read_real2 + module procedure HDF5_read_real3 + module procedure HDF5_read_real4 + module procedure HDF5_read_real5 + module procedure HDF5_read_real6 + module procedure HDF5_read_real7 + + module procedure HDF5_read_int1 + module procedure HDF5_read_int2 + module procedure HDF5_read_int3 + module procedure HDF5_read_int4 + module procedure HDF5_read_int5 + module procedure HDF5_read_int6 + module procedure HDF5_read_int7 + + end interface HDF5_read !-------------------------------------------------------------------------------------------------- !> @brief writes pInt or pReal data of defined shape to file ! ToDo: order of arguments wrong !> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- - interface HDF5_write - module procedure HDF5_write_pReal1 - module procedure HDF5_write_pReal2 - module procedure HDF5_write_pReal3 - module procedure HDF5_write_pReal4 - module procedure HDF5_write_pReal5 - module procedure HDF5_write_pReal6 - module procedure HDF5_write_pReal7 - - module procedure HDF5_write_pInt1 - module procedure HDF5_write_pInt2 - module procedure HDF5_write_pInt3 - module procedure HDF5_write_pInt4 - module procedure HDF5_write_pInt5 - module procedure HDF5_write_pInt6 - module procedure HDF5_write_pInt7 - - end interface HDF5_write + interface HDF5_write + module procedure HDF5_write_real1 + module procedure HDF5_write_real2 + module procedure HDF5_write_real3 + module procedure HDF5_write_real4 + module procedure HDF5_write_real5 + module procedure HDF5_write_real6 + module procedure HDF5_write_real7 + + module procedure HDF5_write_int1 + module procedure HDF5_write_int2 + module procedure HDF5_write_int3 + module procedure HDF5_write_int4 + module procedure HDF5_write_int5 + module procedure HDF5_write_int6 + module procedure HDF5_write_int7 + + module procedure HDF5_write_rotation + + end interface HDF5_write !-------------------------------------------------------------------------------------------------- !> @brief attached attributes of type char,pInt or pReal to a file/dataset/group !-------------------------------------------------------------------------------------------------- - interface HDF5_addAttribute - module procedure HDF5_addAttribute_str - module procedure HDF5_addAttribute_pInt - module procedure HDF5_addAttribute_pReal - end interface HDF5_addAttribute + interface HDF5_addAttribute + module procedure HDF5_addAttribute_str + module procedure HDF5_addAttribute_int + module procedure HDF5_addAttribute_real + module procedure HDF5_addAttribute_int_array + module procedure HDF5_addAttribute_real_array + end interface HDF5_addAttribute !-------------------------------------------------------------------------------------------------- - public :: & - HDF5_utilities_init, & - HDF5_openFile, & - HDF5_closeFile, & - HDF5_addAttribute, & - HDF5_closeGroup ,& - HDF5_openGroup, & - HDF5_addGroup, & - HDF5_read, & - HDF5_write, & - HDF5_setLink, & - HDF5_objectExists + public :: & + HDF5_utilities_init, & + HDF5_openFile, & + HDF5_closeFile, & + HDF5_addAttribute, & + HDF5_closeGroup ,& + HDF5_openGroup, & + HDF5_addGroup, & + HDF5_read, & + HDF5_write, & + HDF5_setLink, & + HDF5_objectExists contains + +!-------------------------------------------------------------------------------------------------- +!> @brief open libary and do sanity checks +!-------------------------------------------------------------------------------------------------- subroutine HDF5_utilities_init - implicit none integer :: hdferr integer(SIZE_T) :: typeSize @@ -117,46 +124,45 @@ end subroutine HDF5_utilities_init !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_openFile(fileName,mode,parallel) ! ToDo: simply "open" is enough - implicit none - character(len=*), intent(in) :: fileName - character, intent(in), optional :: mode - logical, intent(in), optional :: parallel - - character :: m - integer(HID_T) :: plist_id - integer :: hdferr - - if (present(mode)) then - m = mode - else - m = 'r' - endif - - call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pcreate_f') + character(len=*), intent(in) :: fileName + character, intent(in), optional :: mode + logical, intent(in), optional :: parallel + + character :: m + integer(HID_T) :: plist_id + integer :: hdferr + + if (present(mode)) then + m = mode + else + m = 'r' + endif + + call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pcreate_f') #ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pset_fapl_mpio_f') - endif; endif + if (present(parallel)) then; if (parallel) then + call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pset_fapl_mpio_f') + endif; endif #endif - if (m == 'w') then - call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f (w)') - elseif(m == 'a') then - call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)') - elseif(m == 'r') then - call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)') - else - call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode: '//trim(m)) - endif - - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pclose_f') + if (m == 'w') then + call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f (w)') + elseif(m == 'a') then + call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)') + elseif(m == 'r') then + call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)') + else + call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode: '//trim(m)) + endif + + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pclose_f') end function HDF5_openFile @@ -166,13 +172,12 @@ end function HDF5_openFile !-------------------------------------------------------------------------------------------------- subroutine HDF5_closeFile(fileHandle) - implicit none - integer(HID_T), intent(in) :: fileHandle - - integer :: hdferr - - call h5fclose_f(fileHandle,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeFile: h5fclose_f') + integer(HID_T), intent(in) :: fileHandle + + integer :: hdferr + + call h5fclose_f(fileHandle,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeFile: h5fclose_f') end subroutine HDF5_closeFile @@ -182,29 +187,30 @@ end subroutine HDF5_closeFile !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_addGroup(fileHandle,groupName) - implicit none - integer(HID_T), intent(in) :: fileHandle - character(len=*), intent(in) :: groupName + integer(HID_T), intent(in) :: fileHandle + character(len=*), intent(in) :: groupName + + integer :: hdferr + integer(HID_T) :: aplist_id - integer :: hdferr - integer(HID_T) :: aplist_id +!------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pcreate_f ('//trim(groupName)//')') - !------------------------------------------------------------------------------------------------- - ! creating a property list for data access properties - call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pcreate_f ('//trim(groupName)//')') - - !------------------------------------------------------------------------------------------------- - ! setting I/O mode to collective +!------------------------------------------------------------------------------------------------- +! setting I/O mode to collective #ifdef PETSc - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') #endif - !------------------------------------------------------------------------------------------------- - ! Create group - call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') +!------------------------------------------------------------------------------------------------- +! Create group + call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') + + call h5pclose_f(aplist_id,hdferr) end function HDF5_addGroup @@ -214,32 +220,33 @@ end function HDF5_addGroup !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_openGroup(fileHandle,groupName) - implicit none - integer(HID_T), intent(in) :: fileHandle - character(len=*), intent(in) :: groupName - - - integer :: hdferr - integer(HID_T) :: aplist_id - logical :: is_collective + integer(HID_T), intent(in) :: fileHandle + character(len=*), intent(in) :: groupName + + + integer :: hdferr + integer(HID_T) :: aplist_id + logical :: is_collective !------------------------------------------------------------------------------------------------- ! creating a property list for data access properties - call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pcreate_f ('//trim(groupName)//')') + call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pcreate_f ('//trim(groupName)//')') !------------------------------------------------------------------------------------------------- ! setting I/O mode to collective #ifdef PETSc - call h5pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') + call h5pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') #endif !------------------------------------------------------------------------------------------------- ! opening the group - call h5gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') + call h5gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') + + call h5pclose_f(aplist_id,hdferr) end function HDF5_openGroup @@ -249,12 +256,11 @@ end function HDF5_openGroup !-------------------------------------------------------------------------------------------------- subroutine HDF5_closeGroup(group_id) - implicit none - integer(HID_T), intent(in) :: group_id - integer :: hdferr - - call h5gclose_f(group_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(group_id,pInt)) + integer(HID_T), intent(in) :: group_id + integer :: hdferr + + call h5gclose_f(group_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(group_id,pInt)) end subroutine HDF5_closeGroup @@ -264,25 +270,25 @@ end subroutine HDF5_closeGroup !-------------------------------------------------------------------------------------------------- logical function HDF5_objectExists(loc_id,path) - implicit none - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in), optional :: path - integer :: hdferr - character(len=256) :: p + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in), optional :: path + + integer :: hdferr + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif - if (present(path)) then - p = trim(path) - else - p = '.' - endif - - call h5lexists_f(loc_id, p, HDF5_objectExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') - - if(HDF5_objectExists) then - call h5oexists_by_name_f(loc_id, p, HDF5_objectExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') - endif + call h5lexists_f(loc_id, p, HDF5_objectExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') + + if(HDF5_objectExists) then + call h5oexists_by_name_f(loc_id, p, HDF5_objectExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') + endif end function HDF5_objectExists @@ -292,43 +298,43 @@ end function HDF5_objectExists !-------------------------------------------------------------------------------------------------- subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path) - implicit none - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in) :: attrLabel, attrValue - character(len=*), intent(in), optional :: path - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - logical :: attrExists - character(len=256) :: p + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel, attrValue + character(len=*), intent(in), optional :: path + + integer :: hdferr + integer(HID_T) :: attr_id, space_id, type_id + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif - if (present(path)) then - p = trim(path) - else - p = '.' - endif - - call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5screate_f') - call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tcopy_f') - call h5tset_size_f(type_id, int(len(trim(attrValue)),HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tset_size_f') - call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aexists_by_name_f') - if (attrExists) then - call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5adelete_by_name_f') - endif - call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5acreate_f') - call h5awrite_f(attr_id, type_id, trim(attrValue), int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5awrite_f') - call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aclose_f') - call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tclose_f') - call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5sclose_f') + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5screate_f') + call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tcopy_f') + call h5tset_size_f(type_id, int(len(trim(attrValue)),HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tset_size_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5acreate_f') + call h5awrite_f(attr_id, type_id, trim(attrValue), int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aclose_f') + call h5tclose_f(type_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5sclose_f') end subroutine HDF5_addAttribute_str @@ -336,117 +342,191 @@ end subroutine HDF5_addAttribute_str !-------------------------------------------------------------------------------------------------- !> @brief adds a integer attribute to the path given relative to the location !-------------------------------------------------------------------------------------------------- -subroutine HDF5_addAttribute_pInt(loc_id,attrLabel,attrValue,path) +subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path) - implicit none - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in) :: attrLabel - integer(pInt), intent(in) :: attrValue - character(len=*), intent(in), optional :: path - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - logical :: attrExists - character(len=256) :: p + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel + integer(pInt), intent(in) :: attrValue + character(len=*), intent(in), optional :: path + + integer :: hdferr + integer(HID_T) :: attr_id, space_id + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif - if (present(path)) then - p = trim(path) - else - p = '.' - endif + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5screate_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5acreate_f') + call h5awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5sclose_f') - call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5screate_f') - call h5tcopy_f(H5T_NATIVE_INTEGER, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tcopy_f') - call h5tset_size_f(type_id, 1_HSIZE_T, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tset_size_f') - call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5aexists_by_name_f') - if (attrExists) then - call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5adelete_by_name_f') - endif - call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5acreate_f') - call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5awrite_f') - call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5aclose_f') - call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tclose_f') - call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5sclose_f') - -end subroutine HDF5_addAttribute_pInt +end subroutine HDF5_addAttribute_int !-------------------------------------------------------------------------------------------------- !> @brief adds a integer attribute to the path given relative to the location !-------------------------------------------------------------------------------------------------- -subroutine HDF5_addAttribute_pReal(loc_id,attrLabel,attrValue,path) +subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path) - implicit none - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in) :: attrLabel - real(pReal), intent(in) :: attrValue - character(len=*), intent(in), optional :: path - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - logical :: attrExists - character(len=256) :: p + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel + real(pReal), intent(in) :: attrValue + character(len=*), intent(in), optional :: path + + integer :: hdferr + integer(HID_T) :: attr_id, space_id + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif - if (present(path)) then - p = trim(path) - else - p = '.' - endif + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5screate_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5acreate_f') + call h5awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5sclose_f') - call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5screate_f') - call h5tcopy_f(H5T_NATIVE_DOUBLE, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tcopy_f') - call h5tset_size_f(type_id, 8_HSIZE_T, hdferr) ! ToDo - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tset_size_f') - call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5aexists_by_name_f') - if (attrExists) then - call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5adelete_by_name_f') - endif - call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5acreate_f') - call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5awrite_f') - call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5aclose_f') - call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tclose_f') - call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5sclose_f') +end subroutine HDF5_addAttribute_real -end subroutine HDF5_addAttribute_pReal + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a integer attribute to the path given relative to the location +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addAttribute_int_array(loc_id,attrLabel,attrValue,path) + + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel + integer(pInt), intent(in), dimension(:) :: attrValue + character(len=*), intent(in), optional :: path + + integer :: hdferr + integer(HID_T) :: attr_id, space_id + integer(HSIZE_T),dimension(1) :: array_size + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif + + array_size = size(attrValue,kind=HSIZE_T) + + call h5screate_simple_f(1, array_size, space_id, hdferr, array_size) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5screate_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5acreate_f') + call h5awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, array_size, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5sclose_f') + +end subroutine HDF5_addAttribute_int_array + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a real attribute to the path given relative to the location +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addAttribute_real_array(loc_id,attrLabel,attrValue,path) + + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel + real(pReal), intent(in), dimension(:) :: attrValue + character(len=*), intent(in), optional :: path + + integer :: hdferr + integer(HID_T) :: attr_id, space_id + integer(HSIZE_T),dimension(1) :: array_size + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif + + array_size = size(attrValue,kind=HSIZE_T) + + call h5screate_simple_f(1, array_size, space_id, hdferr, array_size) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5screate_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5acreate_f') + call h5awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, array_size, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5sclose_f') + +end subroutine HDF5_addAttribute_real_array !-------------------------------------------------------------------------------------------------- !> @brief set link to object in results file !-------------------------------------------------------------------------------------------------- subroutine HDF5_setLink(loc_id,target_name,link_name) - use hdf5 - implicit none - character(len=*), intent(in) :: target_name, link_name + character(len=*), intent(in) :: target_name, link_name integer(HID_T), intent(in) :: loc_id - integer :: hdferr - logical :: linkExists - - call h5lexists_f(loc_id, link_name,linkExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link_name)//')') - if (linkExists) then - call h5ldelete_f(loc_id,link_name, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link_name)//')') - endif - call h5lcreate_soft_f(target_name, loc_id, link_name, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(target_name)//' '//trim(link_name)//')') + integer :: hdferr + logical :: linkExists + + call h5lexists_f(loc_id, link_name,linkExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link_name)//')') + if (linkExists) then + call h5ldelete_f(loc_id,link_name, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link_name)//')') + endif + call h5lcreate_soft_f(target_name, loc_id, link_name, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(target_name)//' '//trim(link_name)//')') end subroutine HDF5_setLink @@ -454,1140 +534,1218 @@ end subroutine HDF5_setLink !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_real1(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & ! ToDo: Fortran 2018 size(shape(A)) = rank(A) - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr - -!--------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - -!--------------------------------------------------------------------------------------------------- -! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif - - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pReal1 - -!-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 2 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) - - implicit none - real(pReal), intent(inout), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr - -!--------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - -!--------------------------------------------------------------------------------------------------- -! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif - - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pReal2 - -!-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 2 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) - - implicit none - real(pReal), intent(inout), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr - -!--------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - -!--------------------------------------------------------------------------------------------------- -! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + real(pReal), intent(inout), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dread_f') + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & ! ToDo: Fortran 2018 size(shape(A)) = rank(A) + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) +!--------------------------------------------------------------------------------------------------- +! determine shape of dataset + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -end subroutine HDF5_read_pReal3 +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real1: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + +end subroutine HDF5_read_real1 + +!-------------------------------------------------------------------------------------------------- +!> @brief read dataset of type pReal with 2 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_real2(loc_id,dataset,datasetName,parallel) + + real(pReal), intent(inout), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr + +!--------------------------------------------------------------------------------------------------- +! determine shape of dataset + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real2: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + +end subroutine HDF5_read_real2 + +!-------------------------------------------------------------------------------------------------- +!> @brief read dataset of type pReal with 2 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_real3(loc_id,dataset,datasetName,parallel) + + real(pReal), intent(inout), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr + +!--------------------------------------------------------------------------------------------------- +! determine shape of dataset + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real3: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + +end subroutine HDF5_read_real3 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_real4(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real4: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pReal4 +end subroutine HDF5_read_real4 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_real5(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real5: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pReal5 +end subroutine HDF5_read_real5 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_real6(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dread_f') + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real6: h5dread_f') - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) -end subroutine HDF5_read_pReal6 +end subroutine HDF5_read_real6 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_real7(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real7: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pReal7 +end subroutine HDF5_read_real7 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 1 dimension !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int1(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + integer, intent(inout), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dread_f') + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int1: h5dread_f') - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) -end subroutine HDF5_read_pInt1 +end subroutine HDF5_read_int1 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int2(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif - - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dread_f') + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int2: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) -end subroutine HDF5_read_pInt2 +end subroutine HDF5_read_int2 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int3(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int3: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pInt3 +end subroutine HDF5_read_int3 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt withh 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int4(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + integer, intent(inout), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int4: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pInt4 +end subroutine HDF5_read_int4 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int5(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + integer, intent(inout), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int5: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) -end subroutine HDF5_read_pInt5 +end subroutine HDF5_read_int5 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int6(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int6: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pInt6 +end subroutine HDF5_read_int6 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int7(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) - integer :: hdferr + integer, intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int7: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pInt7 +end subroutine HDF5_read_int7 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real1(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape,loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape,loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real1: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pReal1 +end subroutine HDF5_write_real1 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real2(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real2: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pReal2 +end subroutine HDF5_write_real2 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real3(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real3: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pReal3 +end subroutine HDF5_write_real3 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real4(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif + + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real4: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif - - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dread_f') - - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - -end subroutine HDF5_write_pReal4 +end subroutine HDF5_write_real4 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real5(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif + + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real5: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif - - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dread_f') - - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - -end subroutine HDF5_write_pReal5 +end subroutine HDF5_write_real5 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real6(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real6: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - -end subroutine HDF5_write_pReal6 +end subroutine HDF5_write_real6 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real7(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real7: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - -end subroutine HDF5_write_pReal7 +end subroutine HDF5_write_real7 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 1 dimension !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int1(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int1: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - -end subroutine HDF5_write_pInt1 +end subroutine HDF5_write_int1 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int2(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int2: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt2 +end subroutine HDF5_write_int2 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int3(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int3: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) - -end subroutine HDF5_write_pInt3 +end subroutine HDF5_write_int3 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int4(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int4: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt4 +end subroutine HDF5_write_int4 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int5(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int5: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt5 +end subroutine HDF5_write_int5 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int6(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dread_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int6: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt6 +end subroutine HDF5_write_int6 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int7(loc_id,dataset,datasetName,parallel) - implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif + + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int7: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + +end subroutine HDF5_write_int7 + + +!-------------------------------------------------------------------------------------------------- +!> @brief writes a scalar orientation dataset +! ToDo: It might be possible to write the dataset as a whole +! ToDo: We could optionally write out other representations (axis angle, euler, ...) +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_rotation(loc_id,dataset,datasetName,parallel) + use rotations, only: & + rotation + + type(rotation), intent(in), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer :: hdferr + real(pReal), dimension(4,size(dataset)) :: dataset_asArray + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id,dtype_id,w_id,x_id,y_id,z_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer(SIZE_T) :: type_size_real + integer :: i + + do i = 1, size(dataset) + dataset_asArray(1:4,i) = dataset(i)%asQuaternion() + enddo + +!--------------------------------------------------------------------------------------------------- +! determine shape of dataset + myShape = int(shape(dataset),HSIZE_T) + +!--------------------------------------------------------------------------------------------------- +! compound type: name of each quaternion component + call h5tget_size_f(H5T_NATIVE_DOUBLE, type_size_real, hdferr) + + call h5tcreate_f(H5T_COMPOUND_F, type_size_real*4_SIZE_T, dtype_id, hdferr) + call h5tinsert_f(dtype_id, "w", type_size_real*0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tinsert_f(dtype_id, "x", type_size_real*1_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tinsert_f(dtype_id, "y", type_size_real*2_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tinsert_f(dtype_id, "z", type_size_real*3_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,dtype_id,parallel) + else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + myStart, totalShape, loc_id,myShape,datasetName,dtype_id,.false.) + endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dread_f') + call h5pset_preserve_f(plist_id, .TRUE., hdferr) + + if (product(totalShape) /= 0) then + call h5tcreate_f(H5T_COMPOUND_F, type_size_real, x_id, hdferr) + call h5tinsert_f(x_id, "x", 0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tcreate_f(H5T_COMPOUND_F, type_size_real, w_id, hdferr) + call h5tinsert_f(w_id, "w", 0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tcreate_f(H5T_COMPOUND_F, type_size_real, y_id, hdferr) + call h5tinsert_f(y_id, "y", 0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tcreate_f(H5T_COMPOUND_F, type_size_real, z_id, hdferr) + call h5tinsert_f(z_id, "z", 0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + + call h5dwrite_f(dset_id, w_id,dataset_asArray(1,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + call h5dwrite_f(dset_id, x_id,dataset_asArray(2,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + call h5dwrite_f(dset_id, y_id,dataset_asArray(3,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + call h5dwrite_f(dset_id, z_id,dataset_asArray(4,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_rotation: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt7 +end subroutine HDF5_write_rotation !-------------------------------------------------------------------------------------------------- @@ -1600,7 +1758,6 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ worldrank, & worldsize - implicit none integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in) :: parallel @@ -1670,12 +1827,13 @@ end subroutine initialize_read !-------------------------------------------------------------------------------------------------- subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - implicit none integer(HID_T), intent(in) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer :: hdferr call h5pclose_f(plist_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: plist_id') + call h5pclose_f(aplist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: aplist_id') call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: h5dclose_f') call h5sclose_f(filespace_id, hdferr) @@ -1690,68 +1848,68 @@ end subroutine finalize_read !> @brief initialize HDF5 handles, determines global shape and start for parallel write !-------------------------------------------------------------------------------------------------- subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,datatype,parallel) + myStart, totalShape, & + loc_id,myShape,datasetName,datatype,parallel) use numerics, only: & worldrank, & worldsize - implicit none integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in) :: parallel - integer(HID_T), intent(in) :: datatype + logical, intent(in) :: parallel + integer(HID_T), intent(in) :: datatype integer(HSIZE_T), intent(in), dimension(:) :: & - localShape - integer(HSIZE_T), intent(out), dimension(size(localShape,1)):: & + myShape + integer(HSIZE_T), intent(out), dimension(size(myShape,1)):: & myStart, & - globalShape !< shape of the dataset (all processes) + totalShape !< shape of the dataset (all processes) integer(HID_T), intent(out) :: dset_id, filespace_id, memspace_id, plist_id - integer(pInt), dimension(worldsize) :: & + integer, dimension(worldsize) :: & writeSize !< contribution of all processes integer :: ierr integer :: hdferr !------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties +! creating a property list for transfer properties (is collective when reading in parallel) call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5pcreate_f') - -!-------------------------------------------------------------------------------------------------- - writeSize = 0_pInt - writeSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) - #ifdef PETSc if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5pset_dxpl_mpio_f') + endif +#endif + +!-------------------------------------------------------------------------------------------------- +! determine the global data layout among all processes + writeSize = 0_pInt + writeSize(worldrank+1) = int(myShape(ubound(myShape,1)),pInt) +#ifdef PETSc +if (parallel) then call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='initialize_write: MPI_allreduce') endif #endif - myStart = int(0,HSIZE_T) myStart(ubound(myStart)) = int(sum(writeSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(writeSize),HSIZE_T)] + totalShape = [myShape(1:ubound(myShape,1)-1),int(sum(writeSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) and in file (global shape) - call h5screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) + call h5screate_simple_f(size(myShape), myShape, memspace_id, hdferr, myShape) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dopen_f') - call h5screate_simple_f(size(globalShape), globalShape, filespace_id, hdferr, globalShape) + call h5screate_simple_f(size(totalShape), totalShape, filespace_id, hdferr, totalShape) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dget_space_f') !-------------------------------------------------------------------------------------------------- -! create dataset +! create dataset in the file and select a hyperslab from it (the portion of the current process) call h5dcreate_f(loc_id, trim(datasetName), datatype, filespace_id, dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dcreate_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, myShape, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5sselect_hyperslab_f') + end subroutine initialize_write @@ -1760,7 +1918,6 @@ end subroutine initialize_write !-------------------------------------------------------------------------------------------------- subroutine finalize_write(plist_id, dset_id, filespace_id, memspace_id) - implicit none integer(HID_T), intent(in) :: dset_id, filespace_id, memspace_id, plist_id integer :: hdferr diff --git a/src/IO.f90 b/src/IO.f90 index 33c4a778d..074e2b0f4 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -708,6 +708,8 @@ subroutine IO_error(error_ID,el,ip,g,instance,ext_msg) msg = 'too many systems requested' case (146_pInt) msg = 'number of values does not match' + case (147_pInt) + msg = 'not supported anymore' !-------------------------------------------------------------------------------------------------- ! material error messages and related messages in mesh diff --git a/src/MarcInclude/concom2016 b/src/MarcInclude/concom2016 deleted file mode 100644 index e26774bfc..000000000 --- a/src/MarcInclude/concom2016 +++ /dev/null @@ -1,417 +0,0 @@ -! common block definition file taken from respective MSC.Marc release and reformated to free format -!*********************************************************************** -! -! File: concom.cmn -! -! MSC.Marc include file -! -integer(pInt) & - iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,& - ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,& - ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,& - ipoist, irpflo, ismall, ismalt, isoil, ispect, ispnow, istore, iswep, ithcrp,& - itherm, iupblg, iupdat, jacflg, jel, jparks, largst, lfond, loadup, loaduq,& - lodcor, lovl, lsub, magnet, ncycle, newtnt, newton, noshr, linear, ivscpl,& - icrpim, iradrt, ipshft, itshr, iangin, iupmdr, iconjf, jincfl, jpermg, jhour,& - isolvr, jritz, jtable, jshell, jdoubl, jform, jcentr, imini, kautth, iautof,& - ibukty, iassum, icnstd, icnstt, kmakmas, imethvp, iradrte, iradrtp, iupdate, iupdatp,& - ncycnt, marmen , idynme, ihavca, ispf, kmini, imixex, largtt, kdoela, iautofg,& - ipshftp, idntrc, ipore, jtablm, jtablc, isnecma, itrnspo, imsdif, jtrnspo, mcnear,& - imech, imecht, ielcmat, ielectt, magnett, imsdift, noplas, jtabls, jactch, jtablth,& - kgmsto , jpzo, ifricsh, iremkin, iremfor, ishearp, jspf, machining, jlshell, icompsol,& - iupblgfo, jcondir, nstcrp, nactive, ipassref, nstspnt, ibeart, icheckmpc, noline, icuring,& - ishrink, ioffsflg, isetoff, ioffsetm,iharmt, inc_incdat, iautspc, ibrake, icbush, istream_input,& - iprsinp, ivlsinp, ifirst_time,ipin_m, jgnstr_glb, imarc_return,iqvcinp, nqvceid, istpnx, imicro1,& - iaxisymm, jbreakglue,iglstif, jfastasm,iwear, iwearcf, imixmeth, ielcmadyn, idinout, igena_meth,& - magf_meth, non_assumed, iredoboudry, ioffsz0,icomplt, mesh_dual, iactrp, mgnewton, iusedens,igsigd0,& - iaem, icosim, inodels, nlharm, iampini, iphasetr -dimension :: ideva(60) -integer(pInt) num_concom -parameter(num_concom=245) -common/marc_concom/& - iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,& - ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,& - ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,& - ipoist, irpflo, ismall, ismalt, isoil, ispect, ispnow, istore, iswep, ithcrp,& - itherm, iupblg, iupdat, jacflg, jel, jparks, largst, lfond, loadup, loaduq,& - lodcor, lovl, lsub, magnet, ncycle, newtnt, newton, noshr, linear, ivscpl,& - icrpim, iradrt, ipshft, itshr, iangin, iupmdr, iconjf, jincfl, jpermg, jhour,& - isolvr, jritz, jtable, jshell, jdoubl, jform, jcentr, imini, kautth, iautof,& - ibukty, iassum, icnstd, icnstt, kmakmas, imethvp, iradrte, iradrtp, iupdate, iupdatp,& - ncycnt, marmen, idynme, ihavca, ispf, kmini, imixex, largtt, kdoela, iautofg,& - ipshftp, idntrc, ipore, jtablm, jtablc, isnecma, itrnspo, imsdif, jtrnspo, mcnear,& - imech, imecht, ielcmat, ielectt, magnett, imsdift, noplas, jtabls, jactch, jtablth,& - kgmsto , jpzo, ifricsh, iremkin, iremfor, ishearp, jspf, machining, jlshell, icompsol,& - iupblgfo, jcondir, nstcrp, nactive, ipassref, nstspnt, ibeart, icheckmpc, noline, icuring,& - ishrink, ioffsflg, isetoff, ioffsetm,iharmt, inc_incdat, iautspc, ibrake, icbush , istream_input,& - iprsinp, ivlsinp, ifirst_time,ipin_m, jgnstr_glb, imarc_return,iqvcinp, nqvceid, istpnx, imicro1,& - iaxisymm, jbreakglue,iglstif, jfastasm,iwear, iwearcf, imixmeth, ielcmadyn, idinout,igena_meth,& - magf_meth, non_assumed, iredoboudry, ioffsz0,icomplt, mesh_dual, iactrp, mgnewton, iusedens,igsigd0,& - iaem, icosim, inodels, nlharm, iampini, iphasetr -! -! comments of variables: -! -! iacous Control flag for acoustic analysis. Input data. -! iacous=1 modal acoustic analysis. -! iacous=2 harmonic acoustic-structural analysis. -! iasmbl Control flag to indicate that operator matrix should be -! recalculated. -! iautth Control flag for AUTO THERM option. -! ibear Control flag for bearing analysis. Input data. -! icompl Control variable to indicate that a complex analysis is -! being performed. Either a Harmonic analysis with damping, -! or a harmonic electro-magnetic analysis. Input data. -! iconj Flag for EBE conjugate gradient solver (=solver 1, retired) -! Also used for VKI iterative solver. -! icreep Control flag for creep analysis. Input data. -! ideva(60) - debug print out flag -! 1 print element stiffness matrices, mass matrix -! 2 output matrices used in tying -! 3 force the solution of a nonpositive definite matrix -! 4 print info of connections to each node -! 5 info of gap convergence, internal heat generated, contact -! touching and separation -! 6 nodal value array during rezoning -! 7 tying info in CONRAD GAP option, fluid element numbers in -! CHANNEL option -! 8 output incremental displacements in local coord. system -! 9 latent heat output -! 10 stress-strain in local coord. system -! 11 additional info on interlaminar stress -! 12 output right hand side and solution vector -! 13 info of CPU resources used and memory available on NT -! 14 info of mesh adaption process, 2D outline information -! info of penetration checking for remeshing -! save .fem files after afmesh3d meshing -! 15 surface energy balance flag -! 16 print info regarding pyrolysis -! 17 print info of "streamline topology" -! 18 print mesh data changes after remeshing -! 19 print material flow stress data read in from *.mat file -! if unit flag is on, print out flow stress after conversion -! 20 print information on table input -! 21 print out information regarding kinematic boundary conditions -! 22 print out information regarding dist loads, point loads, film -! and foundations -! 23 print out information about automatic domain decomposition -! 24 print out iteration information in SuperForm status report file -! 25 print out information for ablation -! 26 print out information for films - Table input -! 27 print out the tying forces -! 28 print out for CASI solver, convection, -! 29 DDM single file debug printout -! 30 print out cavity debug info -! 31 print out welding related info -! 32 prints categorized DDM memory usage -! 33 print out the cutting info regarding machining feature -! 34 print out the list of quantities which can be defined via a table -! and for each quantity the supported independent variables -! 35 print out detailed coupling region info -! 36 print out solver debug info level 1 (Least Detailed) -! 37 print out solver debug info level 1 (Medium Detailed) -! 38 print out solver debug info level 1 (Very Detailed) -! 39 print detailed memory allocation info -! 40 print out marc-adams debug info -! 41 output rezone mapping post file for debugging -! 42 output post file after calling oprofos() for debugging -! 43 debug printout for vcct -! 44 debug printout for progressive failure -! 45 print out automatically generated midside node coordinates (arecrd) -! 46 print out message about routine and location, where the ibort is raised (ibort_inc) -! 47 print out summary message of element variables on a -! group-basis after all the automatic changes have been -! made (em_ellibp) -! 48 Automatically generate check results based on max and min vals. -! These vals are stored in the checkr file, which is inserted -! into the *dat file by the generate_check_results script from /marc/tools -! 49 Automatically generate check results based on the real calculated values -! at the sppecified check result locations. -! These vals are stored in the checkr file, which is inserted -! into the *dat file by the update_check_results script from /marc/tools -! 50 generate a file containing the resistance or capacity matrix; -! this file can be used to compare results with a reference file -! 51 print out detailed information for segment-to-segment contact -! 52 print out detailed relative displacement information -! for uniaxial sliding contact -! 53 print out detailed sliding direction information for -! uniaxial sliding contact -! 54 print out detailed information for edges attached to a curve -! 55 print information related to viscoelasticity calculations -! 56 print out detailed information for element coloring for multithreading -! 57 print out extra overheads due to multi-threading. -! These overhead includes (i) time and (ii) memory. -! The memory report will be summed over all the children. -! -! -! 58 debug output for ELSTO usage -! -! idyn Control flag for dynamics. Input data. -! 1 = eigenvalue extraction and / or modal superposition -! 2 = Newmark Beta and Single Step Houbolt (ssh with idynme=1) -! 3 = Houbolt -! 4 = Central difference -! 5 = Newer central difference -! idynt Copy of idyn at begining of increment -! ielas Control flag for ELASTIC analysis. Input data. -! Set by user or automatically turned on by Fourier option. -! Implies that each load case is treated separately. -! In Adaptive meshing analysis , forces re-analysis until -! convergence obtained. -! Also seriously misused to indicate no convergence. -! = 1 elastic option with fourier analysis -! = 2 elastic option without fourier analysis -! =-1 no convergence in recycles or max # increments reached -! Set to 1 if ELASTIC or SUBSTRUC parameter cards are used, -! or if fourier option is used. -! Then set to 2 if not fourier analysis. -! ielcma Control flag for electromagnetic analysis. Input data. -! ielcma = 1 Harmonic formulation -! ielcma = 2 Transient formulation -! ielect Control flag for electrostatic option. Input data. -! iform Control flag indicating that contact will be performed. -! ifour Control flag for Fourier analysis. -! 0 = Odd and even terms. -! 1 = symmetric (cosine) terms -! 2 = antisymmetric (sine) terms. -! iharm Control flag to indicate that a harmonic analysis will -! be performed. May change between passes. -! ihcps Control flag for coupled thermal - stress analysis. -! iheat Control flag for heat transfer analysis. Input data. -! iheatt Permanent control flag for heat transfer analysis. -! Note in coupled analysis iheatt will remain as one, -! but iheat will be zero in stress pass. -! ihresp Control flag to indicate to perform a harmonic subincrement. -! ijoule Control flag for Joule heating. -! ilem Control flag to determin which vector is to be transformed. -! Control flag to see where one is: -! ilem = 1 - elem.f -! ilem = 2 - initst.f -! ilem = 3 - pressr.f -! ilem = 3 - fstif.f -! ilem = 4 - jflux.f -! ilem = 4 - strass.f -! ilem = 5 - mass.f -! ilem = 5 - osolty.f -! ilnmom Control flag for soil - pore pressure calculation. Input data. -! ilnmom = 0 - perform only pore pressure calculation. -! = 1 - couples pore pressure - displacement analysis -! iloren Control flag for DeLorenzi J-Integral evaluation. Input data. -! inc Increment number. -! incext Control flag indicating that currently working on a -! subincrement. -! Could be due to harmonics , damping component (bearing), -! stiffness component (bearing), auto therm creep or -! old viscoplaticity -! incsub Sub-increment number. -! ipass Control flag for which part of coupled analysis. -! ipass = -1 - reset to base values -! ipass = 0 - do nothing -! ipass = 1 - stress part -! ipass = 2 - heat transfer part -! iplres Flag indicating that either second matrix is stored. -! dynamic analysis - mass matrix -! heat transfer - specific heat matrix -! buckle - initial stress stiffness -! ipois Control flag indicating Poisson type analysis -! ipois = 1 for heat transfer -! = 1 for heat transfer part of coupled -! = 1 for bearing -! = 1 for electrostatic -! = 1 for magnetostatic -! ipoist Permanent copy of ipois. In coupled analysis , ipois = 0 -! in stress portion, yet ipoist will still =1. -! irpflo global flag for rigid plastic flow analysis -! = 1 eularian formulation -! = 2 regular formulation; rigid material present in the analysis - -! ismall control flag to indicate small displacement analysis. input data. -! ismall = 0 - large disp included. -! ismall = 1 - small displacement. -! the flag is changing between passes. -! ismalt permanent copy of ismall . in heat transfer portion of -! coupled analysis ismall =0 , but ismalt remains the same. -! isoil control flag indicating that soil / pore pressure -! calculation . input data. -! ispect control flag for response spectrum calculation. input data. -! ispnow control flag to indicate to perform a spectrum response -! calculation now. -! istore store stresses flag. -! istore = 0 in elem.f and if first pass of creep -! convergence checking in ogetst.f -! or harmonic analysis or thruc.f if not -! converged. -! iswep control flag for eigenvalue analysis. -! iswep=1 - go do extraction process -! ithcrp control flag for auto therm creep option. input data. -! itherm control flag for either temperature dependent material -! properties and/or thermal loads. -! iupblg control flag for follower force option. input data. -! iupdat control flag for update lagrange option for current element. -! jacflg control flag for lanczos iteration method. input data. -! jel control flag indicating that total load applied in -! increment, ignore previous solution. -! jel = 1 in increment 0 -! = 1 if elastic or fourier -! = 1 in subincrements with elastic and adaptive -! jparks control flag for j integral by parks method. input data. -! largst control flag for finite strain plasticity. input data. -! lfond control variable that indicates if doing elastic -! foundation or film calculation. influences whether -! this is volumetric or surface integration. -! loadup control flag that indicates that nonlinearity occurred -! during previous increment. -! loaduq control flag that indicates that nonlinearity occurred. -! lodcor control flag for switching on the residual load correction. -! notice in input stage lodcor=0 means no loadcor, -! after omarc lodcor=1 means no loadcor -! lovl control flag for determining which "overlay" is to -! be called from ellib. -! lovl = 1 omarc -! = 2 oaread -! = 3 opress -! = 4 oasemb -! = 5 osolty -! = 6 ogetst -! = 7 oscinc -! = 8 odynam -! = 9 opmesh -! = 10 omesh2 -! = 11 osetz -! = 12 oass -! = 13 oincdt -! = 14 oasmas -! = 15 ofluas -! = 16 ofluso -! = 17 oshtra -! = 18 ocass -! = 19 osoltc -! = 20 orezon -! = 21 otest -! = 22 oeigen -! lsub control variable to determine which part of element -! assembly function is being done. -! lsub = 1 - no longer used -! = 2 - beta* -! = 3 - cons* -! = 4 - ldef* -! = 5 - posw* -! = 6 - theta* -! = 7 - tmarx* -! = 8 - geom* -! magnet control flag for magnetostatic analysis. input data. -! ncycle cycle number. accumulated in osolty.f -! note first time through oasemb.f , ncycle = 0. -! newtnt control flag for permanent copy of newton. -! newton iteration type. input data. -! newton : = 1 full newton raphson -! 2 modified newton raphson -! 3 newton raphson with strain correct. -! 4 direct substitution -! 5 direct substitution followed by n.r. -! 6 direct substitution with line search -! 7 full newton raphson with secant initial stress -! 8 secant method -! 9 full newton raphson with line search -! noshr control flag for calculation interlaminar shears for -! elements 22,45, and 75. input data. -!ees -! -! jactch = 1 or 2 if elements are activated or deactivated -! = 3 if elements are adaptively remeshed or rezoned -! = 0 normally / reset to 0 when assembly is done -! ifricsh = 0 call to fricsh in otest not needed -! = 1 call to fricsh (nodal friction) in otest needed -! iremkin = 0 remove deactivated kinematic boundary conditions -! immediately - only in new input format (this is default) -! = 1 remove deactivated kinematic boundary conditions -! gradually - only in new input format -! iremfor = 0 remove force boundary conditions immediately - -! only in new input format (this is default) -! = 1 remove force boundary conditions gradually - -! only in new input format (this is default) -! ishearp set to 1 if shear panel elements are present in the model -! -! jspf = 0 not in spf loadcase -! > 0 in spf loadcase (jspf=1 during first increment) -! machining = 1 if the metal cutting feature is used, for memory allocation purpose -! = 0 (default) if no metal cutting feature required -! -! jlshell = 1 if there is a shell element in the mesh -! icompsol = 1 if there is a composite solid element in the mesh -! iupblgfo = 1 if follower force for point loads -! jcondir = 1 if contact priority option is used -! nstcrp = 0 (default) steady state creep flag (undocumented feature. -! if not 0, turns off special ncycle = 0 code in radial.f) -! nactive = number of active passes, if =1 then it's not a coupled analysis -! ipassref = reference ipass, if not in a multiphysics pass ipass=ipassref -! icheckmpc = value of mpc-check parameter option -! noline = set to 1 in osolty if no line seacrh should be done in ogetst -! icuring = set to 1 if the curing is included for the heat transfer analysis. -! ishrink = set to 1 if shrinkage strain is included for mechancial analysis. -! ioffsflg = 1 for small displacement beam/shell offsets -! = 2 for large displacement beam/shell offsets -! isetoff = 0 - do not apply beam/shell offsets -! = 1 - apply beam/shell offsets -! ioffsetm = min. value of offset flag -! iharmt = 1 global flag if a coupled analysis contains an harmonic pass -! inc_incdat = flag to record increment number of a new loadcase in incdat.f -! iautspc = flag for AutoSPC option -! ibrake = brake squeal in this increment -! icbush = set to 1 if cbush elements present in model -! istream_input = set to 1 for streaming input calling Marc as library -! iprsinp = set to 1 if pressure input, introduced so other variables -! such as h could be a function of pressure -! ivlsinp = set to 1 if velocity input, introduced so other variables -! such as h could be a function of velocity -! ipin_m = # of beam element with PIN flag -! jgnstr_glb = global control over pre or fast integrated composite shells -! imarc_return = Marc return flag for streaming input control -! iqvcimp = if non-zero, then the number of QVECT boundary conditions -! nqvceid = number of QVECT boundary conditions, where emisivity/absorbtion id entered -! istpnx = 1 if to stop at end of increment -! imicro1 = 1 if micro1 interface is used -! iaxisymm = set to 1 if axisymmetric analysis -! jbreakglue = set to 1 if breaking glued option is used -! iglstif = 1 if ddm and global stiffness matrix formed (sgi solver 6 or solver9) -! jfastasm = 1 do fast assembly using SuperForm code -! iwear = set to 1 if wear model, set to 2 if wear model and coordinates updated -! iwearcf = set to 1 to store nodal coefficient of friction for wear calculation -! imixmeth = set=1 then use nonlinear mixture material - allocate memory -! ielcmadyn = flag for magnetodynamics -! 0 - electromagnetics using newmark beta -! 1 - transient magnetics using backward euler -! idinout = flag to control if inside out elements should be deactivated -! igena_meth = 0 - generalized alpha parameters depend on whether or not contact -! is flagged (dynamic,7) -! 10 - generalized alpha parameters are optimized for a contact -! analysis (dynamic,8) -! 11 - generalized alpha parameters are optimized for an analysis -! without contact (dynamic,8) -! magf_meth = - Method to compute force in magnetostatic - structural -! = 1 - Virtual work method based on finite difference for the force computation -! = 2 - Maxwell stress tensor -! = 3 - Virtual work method based on local derivative for the force computation -! non_assumed = 1 no assumed strain formulation (forced) -! iredoboudry set to 1 if contact boundary needs to be recalculated -! ioffsz0 = 1 if composite are used with reference position.ne.0 -! icomplt = 1 global flag if a coupled analysis contains an complex pass -! mesh_dual = 1 two independent meshes are used in magnetodynamic/thermal/structural -! one for magnetodynamic and the other for the remaining passes -! iactrp = 1 in an analysis with global remeshing, include inactive -! rigid bodies on post file -! mgnewton = 1 Use full Newton Raphson iteration for magnetostatic pass -! -! iusedens > 0 if mass density is used in the analysis (dynamics, mass dependent loading) -! igsigd0 = 1 set varselem(igsigd) to zero in next oasemb -! iaem = 1 if marc is called from aem (0 - off - default) -! icosim = 1 if marc is used in co-simulation software (ADAMS-MARC) -! inodels = 1 nodal integration elements 239/240/241 present -! nlharm = 0 harmonic subincrements are linear -! = 1 harmonic subincrements are nonlinear -! iampini = 0 amplitude of previous harmonic subinc is initial estimate (default) -! = 1 zero amplitude is initial estimate -! iphasetr = 1 phase transformation material model is used -! -!*********************************************************************** -!$omp threadprivate(/marc_concom/) -!! diff --git a/src/MarcInclude/concom2017 b/src/MarcInclude/concom2017 deleted file mode 100644 index 08cc3b59b..000000000 --- a/src/MarcInclude/concom2017 +++ /dev/null @@ -1,424 +0,0 @@ -! common block definition file taken from respective MSC.Marc release and reformated to free format -!*********************************************************************** -! -! File: concom.cmn -! -! MSC.Marc include file -! -integer(pInt) & - iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,& - ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,& - ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,& - ipoist, irpflo, ismall, ismalt, isoil, ispect, ispnow, istore, iswep, ithcrp,& - itherm, iupblg, iupdat, jacflg, jel, jparks, largst, lfond, loadup, loaduq,& - lodcor, lovl, lsub, magnet, ncycle, newtnt, newton, noshr, linear, ivscpl,& - icrpim, iradrt, ipshft, itshr, iangin, iupmdr, iconjf, jincfl, jpermg, jhour,& - isolvr, jritz, jtable, jshell, jdoubl, jform, jcentr, imini, kautth, iautof,& - ibukty, iassum, icnstd, icnstt, kmakmas, imethvp, iradrte, iradrtp, iupdate, iupdatp,& - ncycnt, marmen , idynme, ihavca, ispf, kmini, imixex, largtt, kdoela, iautofg,& - ipshftp, idntrc, ipore, jtablm, jtablc, isnecma, itrnspo, imsdif, jtrnspo, mcnear,& - imech, imecht, ielcmat, ielectt, magnett, imsdift, noplas, jtabls, jactch, jtablth,& - kgmsto , jpzo, ifricsh, iremkin, iremfor, ishearp, jspf, machining, jlshell, icompsol,& - iupblgfo, jcondir, nstcrp, nactive, ipassref, nstspnt, ibeart, icheckmpc, noline, icuring,& - ishrink, ioffsflg, isetoff, ioffsetm,iharmt, inc_incdat, iautspc, ibrake, icbush, istream_input,& - iprsinp, ivlsinp, ifirst_time,ipin_m, jgnstr_glb, imarc_return,iqvcinp, nqvceid, istpnx, imicro1,& - iaxisymm, jbreakglue,iglstif, jfastasm,iwear, iwearcf, imixmeth, ielcmadyn, idinout, igena_meth,& - magf_meth, non_assumed, iredoboudry, ioffsz0,icomplt, mesh_dual, iactrp, mgnewton, iusedens,igsigd0,& - iaem, icosim, inodels, nlharm, iampini, iphasetr, inonlcl, inonlct, iforminp,ispecerror -dimension :: ideva(60) -integer(pInt) num_concom -parameter(num_concom=249) -common/marc_concom/& - iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,& - ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,& - ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,& - ipoist, irpflo, ismall, ismalt, isoil, ispect, ispnow, istore, iswep, ithcrp,& - itherm, iupblg, iupdat, jacflg, jel, jparks, largst, lfond, loadup, loaduq,& - lodcor, lovl, lsub, magnet, ncycle, newtnt, newton, noshr, linear, ivscpl,& - icrpim, iradrt, ipshft, itshr, iangin, iupmdr, iconjf, jincfl, jpermg, jhour,& - isolvr, jritz, jtable, jshell, jdoubl, jform, jcentr, imini, kautth, iautof,& - ibukty, iassum, icnstd, icnstt, kmakmas, imethvp, iradrte, iradrtp, iupdate, iupdatp,& - ncycnt, marmen, idynme, ihavca, ispf, kmini, imixex, largtt, kdoela, iautofg,& - ipshftp, idntrc, ipore, jtablm, jtablc, isnecma, itrnspo, imsdif, jtrnspo, mcnear,& - imech, imecht, ielcmat, ielectt, magnett, imsdift, noplas, jtabls, jactch, jtablth,& - kgmsto , jpzo, ifricsh, iremkin, iremfor, ishearp, jspf, machining, jlshell, icompsol,& - iupblgfo, jcondir, nstcrp, nactive, ipassref, nstspnt, ibeart, icheckmpc, noline, icuring,& - ishrink, ioffsflg, isetoff, ioffsetm,iharmt, inc_incdat, iautspc, ibrake, icbush, istream_input,& - iprsinp, ivlsinp, ifirst_time,ipin_m, jgnstr_glb, imarc_return,iqvcinp, nqvceid, istpnx, imicro1,& - iaxisymm, jbreakglue,iglstif, jfastasm,iwear, iwearcf, imixmeth, ielcmadyn, idinout, igena_meth,& - magf_meth, non_assumed, iredoboudry, ioffsz0,icomplt, mesh_dual, iactrp, mgnewton, iusedens,igsigd0,& - iaem, icosim, inodels, nlharm, iampini, iphasetr, inonlcl, inonlct, iforminp,ispecerror -! -! comments of variables: -! -! iacous Control flag for acoustic analysis. Input data. -! iacous=1 modal acoustic analysis. -! iacous=2 harmonic acoustic-structural analysis. -! iasmbl Control flag to indicate that operator matrix should be -! recalculated. -! iautth Control flag for AUTO THERM option. -! ibear Control flag for bearing analysis. Input data. -! icompl Control variable to indicate that a complex analysis is -! being performed. Either a Harmonic analysis with damping, -! or a harmonic electro-magnetic analysis. Input data. -! iconj Flag for EBE conjugate gradient solver (=solver 1, retired) -! Also used for VKI iterative solver. -! icreep Control flag for creep analysis. Input data. -! ideva(60) - debug print out flag -! 1 print element stiffness matrices, mass matrix -! 2 output matrices used in tying -! 3 force the solution of a nonpositive definite matrix -! 4 print info of connections to each node -! 5 info of gap convergence, internal heat generated, contact -! touching and separation -! 6 nodal value array during rezoning -! 7 tying info in CONRAD GAP option, fluid element numbers in -! CHANNEL option -! 8 output incremental displacements in local coord. system -! 9 latent heat output -! 10 stress-strain in local coord. system -! 11 additional info on interlaminar stress -! 12 output right hand side and solution vector -! 13 info of CPU resources used and memory available on NT -! 14 info of mesh adaption process, 2D outline information -! info of penetration checking for remeshing -! save .fem files after afmesh3d meshing -! 15 surface energy balance flag -! 16 print info regarding pyrolysis -! 17 print info of "streamline topology" -! 18 print mesh data changes after remeshing -! 19 print material flow stress data read in from *.mat file -! if unit flag is on, print out flow stress after conversion -! 20 print information on table input -! 21 print out information regarding kinematic boundary conditions -! 22 print out information regarding dist loads, point loads, film -! and foundations -! 23 print out information about automatic domain decomposition -! 24 print out iteration information in SuperForm status report file -! 25 print out information for ablation -! 26 print out information for films - Table input -! 27 print out the tying forces -! 28 print out for CASI solver, convection, -! 29 DDM single file debug printout -! 30 print out cavity debug info -! 31 print out welding related info -! 32 prints categorized DDM memory usage -! 33 print out the cutting info regarding machining feature -! 34 print out the list of quantities which can be defined via a table -! and for each quantity the supported independent variables -! 35 print out detailed coupling region info -! 36 print out solver debug info level 1 (Least Detailed) -! 37 print out solver debug info level 1 (Medium Detailed) -! 38 print out solver debug info level 1 (Very Detailed) -! 39 print detailed memory allocation info -! 40 print out marc-adams debug info -! 41 output rezone mapping post file for debugging -! 42 output post file after calling oprofos() for debugging -! 43 debug printout for vcct -! 44 debug printout for progressive failure -! 45 print out automatically generated midside node coordinates (arecrd) -! 46 print out message about routine and location, where the ibort is raised (ibort_inc) -! 47 print out summary message of element variables on a -! group-basis after all the automatic changes have been -! made (em_ellibp) -! 48 Automatically generate check results based on max and min vals. -! These vals are stored in the checkr file, which is inserted -! into the *dat file by the generate_check_results script from /marc/tools -! 49 Automatically generate check results based on the real calculated values -! at the sppecified check result locations. -! These vals are stored in the checkr file, which is inserted -! into the *dat file by the update_check_results script from /marc/tools -! 50 generate a file containing the resistance or capacity matrix; -! this file can be used to compare results with a reference file -! 51 print out detailed information for segment-to-segment contact -! 52 print out detailed relative displacement information -! for uniaxial sliding contact -! 53 print out detailed sliding direction information for -! uniaxial sliding contact -! 54 print out detailed information for edges attached to a curve -! 55 print information related to viscoelasticity calculations -! 56 print out detailed information for element coloring for multithreading -! 57 print out extra overheads due to multi-threading. -! These overhead includes (i) time and (ii) memory. -! The memory report will be summed over all the children. -! -! -! 58 debug output for ELSTO usage -! -! idyn Control flag for dynamics. Input data. -! 1 = eigenvalue extraction and / or modal superposition -! 2 = Newmark Beta and Single Step Houbolt (ssh with idynme=1) -! 3 = Houbolt -! 4 = Central difference -! 5 = Newer central difference -! idynt Copy of idyn at begining of increment -! ielas Control flag for ELASTIC analysis. Input data. -! Set by user or automatically turned on by Fourier option. -! Implies that each load case is treated separately. -! In Adaptive meshing analysis , forces re-analysis until -! convergence obtained. -! Also seriously misused to indicate no convergence. -! = 1 elastic option with fourier analysis -! = 2 elastic option without fourier analysis -! =-1 no convergence in recycles or max # increments reached -! Set to 1 if ELASTIC or SUBSTRUC parameter cards are used, -! or if fourier option is used. -! Then set to 2 if not fourier analysis. -! ielcma Control flag for electromagnetic analysis. Input data. -! ielcma = 1 Harmonic formulation -! ielcma = 2 Transient formulation -! ielect Control flag for electrostatic option. Input data. -! iform Control flag indicating that contact will be performed. -! ifour Control flag for Fourier analysis. -! 0 = Odd and even terms. -! 1 = symmetric (cosine) terms -! 2 = antisymmetric (sine) terms. -! iharm Control flag to indicate that a harmonic analysis will -! be performed. May change between passes. -! ihcps Control flag for coupled thermal - stress analysis. -! iheat Control flag for heat transfer analysis. Input data. -! iheatt Permanent control flag for heat transfer analysis. -! Note in coupled analysis iheatt will remain as one, -! but iheat will be zero in stress pass. -! ihresp Control flag to indicate to perform a harmonic subincrement. -! ijoule Control flag for Joule heating. -! ilem Control flag to determin which vector is to be transformed. -! Control flag to see where one is: -! ilem = 1 - elem.f -! ilem = 2 - initst.f -! ilem = 3 - pressr.f -! ilem = 3 - fstif.f -! ilem = 4 - jflux.f -! ilem = 4 - strass.f -! ilem = 5 - mass.f -! ilem = 5 - osolty.f -! ilnmom Control flag for soil - pore pressure calculation. Input data. -! ilnmom = 0 - perform only pore pressure calculation. -! = 1 - couples pore pressure - displacement analysis -! iloren Control flag for DeLorenzi J-Integral evaluation. Input data. -! inc Increment number. -! incext Control flag indicating that currently working on a -! subincrement. -! Could be due to harmonics , damping component (bearing), -! stiffness component (bearing), auto therm creep or -! old viscoplaticity -! incsub Sub-increment number. -! ipass Control flag for which part of coupled analysis. -! ipass = -1 - reset to base values -! ipass = 0 - do nothing -! ipass = 1 - stress part -! ipass = 2 - heat transfer part -! iplres Flag indicating that either second matrix is stored. -! dynamic analysis - mass matrix -! heat transfer - specific heat matrix -! buckle - initial stress stiffness -! ipois Control flag indicating Poisson type analysis -! ipois = 1 for heat transfer -! = 1 for heat transfer part of coupled -! = 1 for bearing -! = 1 for electrostatic -! = 1 for magnetostatic -! ipoist Permanent copy of ipois. In coupled analysis , ipois = 0 -! in stress portion, yet ipoist will still =1. -! irpflo global flag for rigid plastic flow analysis -! = 1 eularian formulation -! = 2 regular formulation; rigid material present in the analysis - -! ismall control flag to indicate small displacement analysis. input data. -! ismall = 0 - large disp included. -! ismall = 1 - small displacement. -! the flag is changing between passes. -! ismalt permanent copy of ismall . in heat transfer portion of -! coupled analysis ismall =0 , but ismalt remains the same. -! isoil control flag indicating that soil / pore pressure -! calculation . input data. -! ispect control flag for response spectrum calculation. input data. -! ispnow control flag to indicate to perform a spectrum response -! calculation now. -! istore store stresses flag. -! istore = 0 in elem.f and if first pass of creep -! convergence checking in ogetst.f -! or harmonic analysis or thruc.f if not -! converged. -! iswep control flag for eigenvalue analysis. -! iswep=1 - go do extraction process -! ithcrp control flag for auto therm creep option. input data. -! itherm control flag for either temperature dependent material -! properties and/or thermal loads. -! iupblg control flag for follower force option. input data. -! iupdat control flag for update lagrange option for current element. -! jacflg control flag for lanczos iteration method. input data. -! jel control flag indicating that total load applied in -! increment, ignore previous solution. -! jel = 1 in increment 0 -! = 1 if elastic or fourier -! = 1 in subincrements with elastic and adaptive -! jparks control flag for j integral by parks method. input data. -! largst control flag for finite strain plasticity. input data. -! lfond control variable that indicates if doing elastic -! foundation or film calculation. influences whether -! this is volumetric or surface integration. -! loadup control flag that indicates that nonlinearity occurred -! during previous increment. -! loaduq control flag that indicates that nonlinearity occurred. -! lodcor control flag for switching on the residual load correction. -! notice in input stage lodcor=0 means no loadcor, -! after omarc lodcor=1 means no loadcor -! lovl control flag for determining which "overlay" is to -! be called from ellib. -! lovl = 1 omarc -! = 2 oaread -! = 3 opress -! = 4 oasemb -! = 5 osolty -! = 6 ogetst -! = 7 oscinc -! = 8 odynam -! = 9 opmesh -! = 10 omesh2 -! = 11 osetz -! = 12 oass -! = 13 oincdt -! = 14 oasmas -! = 15 ofluas -! = 16 ofluso -! = 17 oshtra -! = 18 ocass -! = 19 osoltc -! = 20 orezon -! = 21 otest -! = 22 oeigen -! lsub control variable to determine which part of element -! assembly function is being done. -! lsub = 1 - no longer used -! = 2 - beta* -! = 3 - cons* -! = 4 - ldef* -! = 5 - posw* -! = 6 - theta* -! = 7 - tmarx* -! = 8 - geom* -! magnet control flag for magnetostatic analysis. input data. -! ncycle cycle number. accumulated in osolty.f -! note first time through oasemb.f , ncycle = 0. -! newtnt control flag for permanent copy of newton. -! newton iteration type. input data. -! newton : = 1 full newton raphson -! 2 modified newton raphson -! 3 newton raphson with strain correct. -! 4 direct substitution -! 5 direct substitution followed by n.r. -! 6 direct substitution with line search -! 7 full newton raphson with secant initial stress -! 8 secant method -! 9 full newton raphson with line search -! noshr control flag for calculation interlaminar shears for -! elements 22,45, and 75. input data. -!ees -! -! jactch = 1 or 2 if elements are activated or deactivated -! = 3 if elements are adaptively remeshed or rezoned -! = 0 normally / reset to 0 when assembly is done -! ifricsh = 0 call to fricsh in otest not needed -! = 1 call to fricsh (nodal friction) in otest needed -! iremkin = 0 remove deactivated kinematic boundary conditions -! immediately - only in new input format (this is default) -! = 1 remove deactivated kinematic boundary conditions -! gradually - only in new input format -! iremfor = 0 remove force boundary conditions immediately - -! only in new input format (this is default) -! = 1 remove force boundary conditions gradually - -! only in new input format (this is default) -! ishearp set to 1 if shear panel elements are present in the model -! -! jspf = 0 not in spf loadcase -! > 0 in spf loadcase (jspf=1 during first increment) -! machining = 1 if the metal cutting feature is used, for memory allocation purpose -! = 0 (default) if no metal cutting feature required -! -! jlshell = 1 if there is a shell element in the mesh -! icompsol = 1 if there is a composite solid element in the mesh -! iupblgfo = 1 if follower force for point loads -! jcondir = 1 if contact priority option is used -! nstcrp = 0 (default) steady state creep flag (undocumented feature. -! if not 0, turns off special ncycle = 0 code in radial.f) -! nactive = number of active passes, if =1 then it's not a coupled analysis -! ipassref = reference ipass, if not in a multiphysics pass ipass=ipassref -! icheckmpc = value of mpc-check parameter option -! noline = set to 1 in osolty if no line seacrh should be done in ogetst -! icuring = set to 1 if the curing is included for the heat transfer analysis. -! ishrink = set to 1 if shrinkage strain is included for mechancial analysis. -! ioffsflg = 1 for small displacement beam/shell offsets -! = 2 for large displacement beam/shell offsets -! isetoff = 0 - do not apply beam/shell offsets -! = 1 - apply beam/shell offsets -! ioffsetm = min. value of offset flag -! iharmt = 1 global flag if a coupled analysis contains an harmonic pass -! inc_incdat = flag to record increment number of a new loadcase in incdat.f -! iautspc = flag for AutoSPC option -! ibrake = brake squeal in this increment -! icbush = set to 1 if cbush elements present in model -! istream_input = set to 1 for streaming input calling Marc as library -! iprsinp = set to 1 if pressure input, introduced so other variables -! such as h could be a function of pressure -! ivlsinp = set to 1 if velocity input, introduced so other variables -! such as h could be a function of velocity -! ipin_m = # of beam element with PIN flag -! jgnstr_glb = global control over pre or fast integrated composite shells -! imarc_return = Marc return flag for streaming input control -! iqvcimp = if non-zero, then the number of QVECT boundary conditions -! nqvceid = number of QVECT boundary conditions, where emisivity/absorbtion id entered -! istpnx = 1 if to stop at end of increment -! imicro1 = 1 if micro1 interface is used -! iaxisymm = set to 1 if axisymmetric analysis -! jbreakglue = set to 1 if breaking glued option is used -! iglstif = 1 if ddm and global stiffness matrix formed (sgi solver 6 or solver9) -! jfastasm = 1 do fast assembly using SuperForm code -! iwear = set to 1 if wear model, set to 2 if wear model and coordinates updated -! iwearcf = set to 1 to store nodal coefficient of friction for wear calculation -! imixmeth = set=1 then use nonlinear mixture material - allocate memory -! ielcmadyn = flag for magnetodynamics -! 0 - electromagnetics using newmark beta -! 1 - transient magnetics using backward euler -! idinout = flag to control if inside out elements should be deactivated -! igena_meth = 0 - generalized alpha parameters depend on whether or not contact -! is flagged (dynamic,7) -! 10 - generalized alpha parameters are optimized for a contact -! analysis (dynamic,8) -! 11 - generalized alpha parameters are optimized for an analysis -! without contact (dynamic,8) -! magf_meth = - Method to compute force in magnetostatic - structural -! = 1 - Virtual work method based on finite difference for the force computation -! = 2 - Maxwell stress tensor -! = 3 - Virtual work method based on local derivative for the force computation -! non_assumed = 1 no assumed strain formulation (forced) -! iredoboudry set to 1 if contact boundary needs to be recalculated -! ioffsz0 = 1 if composite are used with reference position.ne.0 -! icomplt = 1 global flag if a coupled analysis contains an complex pass -! mesh_dual = 1 two independent meshes are used in magnetodynamic/thermal/structural -! one for magnetodynamic and the other for the remaining passes -! iactrp = 1 in an analysis with global remeshing, include inactive -! rigid bodies on post file -! mgnewton = 1 Use full Newton Raphson iteration for magnetostatic pass -! -! iusedens > 0 if mass density is used in the analysis (dynamics, mass dependent loading) -! igsigd0 = 1 set varselem(igsigd) to zero in next oasemb -! iaem = 1 if marc is called from aem (0 - off - default) -! icosim = 1 if marc is used in co-simulation software (ADAMS-MARC) -! inodels = 1 nodal integration elements 239/240/241 present -! nlharm = 0 harmonic subincrements are linear -! = 1 harmonic subincrements are nonlinear -! iampini = 0 amplitude of previous harmonic subinc is initial estimate (default) -! = 1 zero amplitude is initial estimate -! iphasetr = 1 phase transformation material model is used -! iforminp flag indicating that contact is switched on via the CONTACT -! option in the input file (as opposed to the case that contact -! is switched on internally due to cyclic symmetry or model -! section creation) -! ispecerror = a+10*b (only for spectrum response analysis with missing mass option) -! a=0 or a=1 (modal shape with non-zero shift) -! b=0 or b=1 (recover with new assembly of stiffness matrix) -! -!*********************************************************************** -!$omp threadprivate(/marc_concom/) -!! diff --git a/src/MarcInclude/creeps2016 b/src/MarcInclude/creeps2016 deleted file mode 100644 index 85c67492d..000000000 --- a/src/MarcInclude/creeps2016 +++ /dev/null @@ -1,66 +0,0 @@ -! common block definition file taken from respective MSC.Marc release and reformated to free format -!*********************************************************************** -! -! File: creeps.cmn -! -! MSC.Marc include file -! -real(pReal) cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b -integer(pInt) icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,& - icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa -real(pReal) time_beg_lcase,time_beg_inc,fractol,time_beg_pst -real(pReal) fraction_donn,timinc_ol2 -! -integer(pInt) num_creepsr,num_creepsi,num_creeps2r -parameter(num_creepsr=7) -parameter(num_creepsi=17) -parameter(num_creeps2r=6) -common/marc_creeps/cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,icfte,icfst,& - icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa -common/marc_creeps2/time_beg_lcase,time_beg_inc,fractol,time_beg_pst,fraction_donn,timinc_ol2 -! -! cptim Total time at begining of increment. -! timinc Incremental time for this step. -! icfte Local copy number of slopes of creep strain rate function -! versus temperature. Is -1 if exponent law used. -! icfst Local copy number of slopes of creep strain rate function -! versus equivalent stress. Is -1 if exponent law used. -! icfeq Local copy number of slopes of creep strain rate function -! versus equivalent strain. Is -1 if exponent law used. -! icftm Local copy number of slopes of creep strain rate function -! versus time. Is -1 if exponent law used. -! icetem Element number that needs to be checked for creep convergence -! or, if negative, the number of elements that need to -! be checked. In the latter case the elements to check -! are stored in ielcp. -! mcreep Maximum nuber of iterations for explicit creep. -! jcreep Counter of number of iterations for explicit creep -! procedure. jcreep must be .le. mcreep -! icpa Pointer to constant in creep strain rate expression. -! icftmp Pointer to temperature dependent creep strain rate data. -! icfstr Pointer to equivalent stress dependent creep strain rate data. -! icfqcp Pointer to equivalent creep strain dependent creep strain -! rate data. -! icfcpm Pointer to equivalent creep strain rate dependent -! creep strain rate data. -! icrppr Permanent copy of icreep -! icrcha Control flag for creep convergence checking , if set to -! 1 then testing on absolute change in stress and creep -! strain, not relative testing. Input data. -! icpb Pointer to storage of material id cross reference numbers. -! iicpmt -! iicpa Pointer to constant in creep strain rate expression -! -! time_beg_lcase time at the beginning of the current load case -! time_beg_inc time at the beginning of the current increment -! fractol fraction of loadcase or increment time when we -! consider it to be finished -! time_beg_pst time corresponding to first increment to be -! read in from thermal post file for auto step -! -! timinc_old Time step of the previous increment -! -!*********************************************************************** -!!$omp threadprivate(/marc_creeps/) -!!$omp threadprivate(/marc_creeps2/) -!! diff --git a/src/MarcInclude/creeps2017 b/src/MarcInclude/creeps2017 deleted file mode 100644 index 85c67492d..000000000 --- a/src/MarcInclude/creeps2017 +++ /dev/null @@ -1,66 +0,0 @@ -! common block definition file taken from respective MSC.Marc release and reformated to free format -!*********************************************************************** -! -! File: creeps.cmn -! -! MSC.Marc include file -! -real(pReal) cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b -integer(pInt) icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,& - icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa -real(pReal) time_beg_lcase,time_beg_inc,fractol,time_beg_pst -real(pReal) fraction_donn,timinc_ol2 -! -integer(pInt) num_creepsr,num_creepsi,num_creeps2r -parameter(num_creepsr=7) -parameter(num_creepsi=17) -parameter(num_creeps2r=6) -common/marc_creeps/cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,icfte,icfst,& - icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa -common/marc_creeps2/time_beg_lcase,time_beg_inc,fractol,time_beg_pst,fraction_donn,timinc_ol2 -! -! cptim Total time at begining of increment. -! timinc Incremental time for this step. -! icfte Local copy number of slopes of creep strain rate function -! versus temperature. Is -1 if exponent law used. -! icfst Local copy number of slopes of creep strain rate function -! versus equivalent stress. Is -1 if exponent law used. -! icfeq Local copy number of slopes of creep strain rate function -! versus equivalent strain. Is -1 if exponent law used. -! icftm Local copy number of slopes of creep strain rate function -! versus time. Is -1 if exponent law used. -! icetem Element number that needs to be checked for creep convergence -! or, if negative, the number of elements that need to -! be checked. In the latter case the elements to check -! are stored in ielcp. -! mcreep Maximum nuber of iterations for explicit creep. -! jcreep Counter of number of iterations for explicit creep -! procedure. jcreep must be .le. mcreep -! icpa Pointer to constant in creep strain rate expression. -! icftmp Pointer to temperature dependent creep strain rate data. -! icfstr Pointer to equivalent stress dependent creep strain rate data. -! icfqcp Pointer to equivalent creep strain dependent creep strain -! rate data. -! icfcpm Pointer to equivalent creep strain rate dependent -! creep strain rate data. -! icrppr Permanent copy of icreep -! icrcha Control flag for creep convergence checking , if set to -! 1 then testing on absolute change in stress and creep -! strain, not relative testing. Input data. -! icpb Pointer to storage of material id cross reference numbers. -! iicpmt -! iicpa Pointer to constant in creep strain rate expression -! -! time_beg_lcase time at the beginning of the current load case -! time_beg_inc time at the beginning of the current increment -! fractol fraction of loadcase or increment time when we -! consider it to be finished -! time_beg_pst time corresponding to first increment to be -! read in from thermal post file for auto step -! -! timinc_old Time step of the previous increment -! -!*********************************************************************** -!!$omp threadprivate(/marc_creeps/) -!!$omp threadprivate(/marc_creeps2/) -!! diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 301274897..0ae1323f0 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -9,10 +9,6 @@ #include "list.f90" #include "future.f90" #include "config.f90" -#ifdef DAMASKHDF5 -#include "HDF5_utilities.f90" -#include "results.f90" -#endif #include "math.f90" #include "quaternions.f90" #include "Lambert.f90" @@ -26,6 +22,10 @@ #ifdef Marc4DAMASK #include "mesh_marc.f90" #endif +#ifdef DAMASK_HDF5 +#include "HDF5_utilities.f90" +#include "results.f90" +#endif #include "material.f90" #include "lattice.f90" #include "source_thermal_dissipation.f90" @@ -46,9 +46,7 @@ #include "plastic_nonlocal.f90" #include "constitutive.f90" #include "crystallite.f90" -#include "homogenization_none.f90" -#include "homogenization_isostrain.f90" -#include "homogenization_RGC.f90" +#include "homogenization_mech_RGC.f90" #include "thermal_isothermal.f90" #include "thermal_adiabatic.f90" #include "thermal_conduction.f90" @@ -56,4 +54,6 @@ #include "damage_local.f90" #include "damage_nonlocal.f90" #include "homogenization.f90" +#include "homogenization_mech_none.f90" +#include "homogenization_mech_isostrain.f90" #include "CPFEM.f90" diff --git a/src/config.f90 b/src/config.f90 index 23268d1de..f86057b25 100644 --- a/src/config.f90 +++ b/src/config.f90 @@ -231,15 +231,21 @@ end function read_materialConfig !-------------------------------------------------------------------------------------------------- subroutine parse_materialConfig(sectionNames,part,line, & fileContent) + use prec, only: & + pStringLen + use IO, only: & + IO_intOut + implicit none character(len=64), allocatable, dimension(:), intent(out) :: sectionNames type(tPartitionedStringList), allocatable, dimension(:), intent(inout) :: part character(len=pStringLen), intent(inout) :: line character(len=pStringLen), dimension(:), intent(in) :: fileContent - integer, allocatable, dimension(:) :: partPosition ! position of [] tags + last line in section - integer :: i, j - logical :: echo + integer, allocatable, dimension(:) :: partPosition !< position of [] tags + last line in section + integer :: i, j + logical :: echo + character(len=pStringLen) :: section_ID echo = .false. @@ -263,7 +269,8 @@ subroutine parse_materialConfig(sectionNames,part,line, & partPosition = [partPosition, i] ! needed when actually storing content do i = 1, size(partPosition) -1 - sectionNames(i) = trim(adjustl(IO_getTag(fileContent(partPosition(i)),'[',']'))) + write(section_ID,'('//IO_intOut(size(partPosition))//')') i + sectionNames(i) = trim(section_ID)//'_'//trim(adjustl(IO_getTag(fileContent(partPosition(i)),'[',']'))) do j = partPosition(i) + 1, partPosition(i+1) -1 call part(i)%add(trim(adjustl(fileContent(j)))) enddo diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 23ae3f07b..6428e19d1 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -9,7 +9,7 @@ module constitutive implicit none private - integer(pInt), public, protected :: & + integer, public, protected :: & constitutive_plasticity_maxSizePostResults, & constitutive_plasticity_maxSizeDotState, & constitutive_source_maxSizePostResults, & @@ -37,7 +37,7 @@ contains !-------------------------------------------------------------------------------------------------- !> @brief allocates arrays pointing to array of the various constitutive modules !-------------------------------------------------------------------------------------------------- -subroutine constitutive_init() +subroutine constitutive_init use prec, only: & pReal use debug, only: & @@ -50,8 +50,7 @@ subroutine constitutive_init() IO_write_jobFile use config, only: & material_Nphase, & - phase_name, & - config_deallocate + phase_name use material, only: & material_phase, & phase_plasticity, & @@ -111,14 +110,14 @@ subroutine constitutive_init() use kinematics_thermal_expansion implicit none - integer(pInt), parameter :: FILEUNIT = 204_pInt - integer(pInt) :: & + integer, parameter :: FILEUNIT = 204 + integer :: & o, & !< counter in output loop ph, & !< counter in phase loop s, & !< counter in source loop ins !< instance of plasticity/source - integer(pInt), dimension(:,:), pointer :: thisSize + integer, dimension(:,:), pointer :: thisSize character(len=64), dimension(:,:), pointer :: thisOutput character(len=32) :: outputName !< name of output, intermediate fix until HDF5 output is ready logical :: knownPlasticity, knownSource, nonlocalConstitutionPresent @@ -149,15 +148,13 @@ subroutine constitutive_init() if (any(phase_kinematics == KINEMATICS_slipplane_opening_ID)) call kinematics_slipplane_opening_init if (any(phase_kinematics == KINEMATICS_thermal_expansion_ID)) call kinematics_thermal_expansion_init - call config_deallocate('material.config/phase') - write(6,'(/,a)') ' <<<+- constitutive init -+>>>' mainProcess: if (worldrank == 0) then !-------------------------------------------------------------------------------------------------- ! write description file for constitutive output call IO_write_jobFile(FILEUNIT,'outputConstitutive') - PhaseLoop: do ph = 1_pInt,material_Nphase + PhaseLoop: do ph = 1,material_Nphase activePhase: if (any(material_phase == ph)) then ins = phase_plasticityInstance(ph) knownPlasticity = .true. ! assume valid @@ -197,14 +194,14 @@ subroutine constitutive_init() if (knownPlasticity) then write(FILEUNIT,'(a)') '(plasticity)'//char(9)//trim(outputName) if (phase_plasticity(ph) /= PLASTICITY_NONE_ID) then - OutputPlasticityLoop: do o = 1_pInt,size(thisOutput(:,ins)) - if(len(trim(thisOutput(o,ins))) > 0_pInt) & + OutputPlasticityLoop: do o = 1,size(thisOutput(:,ins)) + if(len(trim(thisOutput(o,ins))) > 0) & write(FILEUNIT,'(a,i4)') trim(thisOutput(o,ins))//char(9),thisSize(o,ins) enddo OutputPlasticityLoop endif endif - SourceLoop: do s = 1_pInt, phase_Nsources(ph) + SourceLoop: do s = 1, phase_Nsources(ph) knownSource = .true. ! assume valid sourceType: select case (phase_source(s,ph)) case (SOURCE_thermal_dissipation_ID) sourceType @@ -242,8 +239,8 @@ subroutine constitutive_init() end select sourceType if (knownSource) then write(FILEUNIT,'(a)') '(source)'//char(9)//trim(outputName) - OutputSourceLoop: do o = 1_pInt,size(thisOutput(:,ins)) - if(len(trim(thisOutput(o,ins))) > 0_pInt) & + OutputSourceLoop: do o = 1,size(thisOutput(:,ins)) + if(len(trim(thisOutput(o,ins))) > 0) & write(FILEUNIT,'(a,i4)') trim(thisOutput(o,ins))//char(9),thisSize(o,ins) enddo OutputSourceLoop endif @@ -253,17 +250,17 @@ subroutine constitutive_init() close(FILEUNIT) endif mainProcess - constitutive_plasticity_maxSizeDotState = 0_pInt - constitutive_plasticity_maxSizePostResults = 0_pInt - constitutive_source_maxSizeDotState = 0_pInt - constitutive_source_maxSizePostResults = 0_pInt + constitutive_plasticity_maxSizeDotState = 0 + constitutive_plasticity_maxSizePostResults = 0 + constitutive_source_maxSizeDotState = 0 + constitutive_source_maxSizePostResults = 0 - PhaseLoop2:do ph = 1_pInt,material_Nphase + PhaseLoop2:do ph = 1,material_Nphase !-------------------------------------------------------------------------------------------------- ! partition and inititalize state plasticState(ph)%partionedState0 = plasticState(ph)%state0 plasticState(ph)%state = plasticState(ph)%partionedState0 - forall(s = 1_pInt:phase_Nsources(ph)) + forall(s = 1:phase_Nsources(ph)) sourceState(ph)%p(s)%partionedState0 = sourceState(ph)%p(s)%state0 sourceState(ph)%p(s)%state = sourceState(ph)%p(s)%partionedState0 end forall @@ -302,7 +299,7 @@ function constitutive_homogenizedC(ipc,ip,el) implicit none real(pReal), dimension(6,6) :: constitutive_homogenizedC - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -341,14 +338,14 @@ subroutine constitutive_microstructure(Fe, Fp, ipc, ip, el) plastic_disloUCLA_dependentState implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element real(pReal), intent(in), dimension(3,3) :: & Fe, & !< elastic deformation gradient Fp !< plastic deformation gradient - integer(pInt) :: & + integer :: & ho, & !< homogenization tme, & !< thermal member position instance, of @@ -412,7 +409,7 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & plastic_nonlocal_LpAndItsTangent implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -428,10 +425,10 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & dLp_dMp !< derivative of Lp with respect to Mandel stress real(pReal), dimension(3,3) :: & Mp !< Mandel stress work conjugate with Lp - integer(pInt) :: & + integer :: & ho, & !< homogenization tme !< thermal member position - integer(pInt) :: & + integer :: & i, j, instance, of ho = material_homogenizationAt(el) @@ -519,7 +516,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & kinematics_thermal_expansion_LiAndItsTangent implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -541,7 +538,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & my_dLi_dS real(pReal) :: & detFi - integer(pInt) :: & + integer :: & k, i, j, & instance, of @@ -562,7 +559,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & Li = Li + my_Li dLi_dS = dLi_dS + my_dLi_dS - KinematicsLoop: do k = 1_pInt, phase_Nkinematics(material_phase(ipc,ip,el)) + KinematicsLoop: do k = 1, phase_Nkinematics(material_phase(ipc,ip,el)) kinematicsType: select case (phase_kinematics(k,material_phase(ipc,ip,el))) case (KINEMATICS_cleavage_opening_ID) kinematicsType call kinematics_cleavage_opening_LiAndItsTangent(my_Li, my_dLi_dS, S, ipc, ip, el) @@ -583,7 +580,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & Li = matmul(matmul(Fi,Li),FiInv)*detFi !< push forward to intermediate configuration temp_33 = matmul(FiInv,Li) - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt + do i = 1,3; do j = 1,3 dLi_dS(1:3,1:3,i,j) = matmul(matmul(Fi,dLi_dS(1:3,1:3,i,j)),FiInv)*detFi dLi_dFi(1:3,1:3,i,j) = dLi_dFi(1:3,1:3,i,j) + Li*FiInv(j,i) dLi_dFi(1:3,i,1:3,j) = dLi_dFi(1:3,i,1:3,j) + math_I3*temp_33(j,i) + Li*FiInv(j,i) @@ -612,22 +609,22 @@ pure function constitutive_initialFi(ipc, ip, el) kinematics_thermal_expansion_initialStrain implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element real(pReal), dimension(3,3) :: & constitutive_initialFi !< composite initial intermediate deformation gradient - integer(pInt) :: & + integer :: & k !< counter in kinematics loop - integer(pInt) :: & + integer :: & phase, & homog, offset constitutive_initialFi = math_I3 phase = material_phase(ipc,ip,el) - KinematicsLoop: do k = 1_pInt, phase_Nkinematics(phase) !< Warning: small initial strain assumption + KinematicsLoop: do k = 1, phase_Nkinematics(phase) !< Warning: small initial strain assumption kinematicsType: select case (phase_kinematics(k,phase)) case (KINEMATICS_thermal_expansion_ID) kinematicsType homog = material_homogenizationAt(el) @@ -650,7 +647,7 @@ subroutine constitutive_SandItsTangents(S, dS_dFe, dS_dFi, Fe, Fi, ipc, ip, el) pReal implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -691,7 +688,7 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & STIFFNESS_DEGRADATION_damage_ID implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -705,19 +702,19 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & dS_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient real(pReal), dimension(3,3) :: E real(pReal), dimension(3,3,3,3) :: C - integer(pInt) :: & + integer :: & ho, & !< homogenization d !< counter in degradation loop - integer(pInt) :: & + integer :: & i, j ho = material_homogenizationAt(el) C = math_66toSym3333(constitutive_homogenizedC(ipc,ip,el)) - DegradationLoop: do d = 1_pInt, phase_NstiffnessDegradations(material_phase(ipc,ip,el)) + DegradationLoop: do d = 1, phase_NstiffnessDegradations(material_phase(ipc,ip,el)) degradationType: select case(phase_stiffnessDegradation(d,material_phase(ipc,ip,el))) case (STIFFNESS_DEGRADATION_damage_ID) degradationType - C = C * damage(ho)%p(damageMapping(ho)%p(ip,el))**2_pInt + C = C * damage(ho)%p(damageMapping(ho)%p(ip,el))**2 end select degradationType enddo DegradationLoop @@ -725,7 +722,7 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & S = math_mul3333xx33(C,matmul(matmul(transpose(Fi),E),Fi)) !< 2PK stress in lattice configuration in work conjugate with GL strain pulled back to lattice configuration dS_dFe = 0.0_pReal - forall (i=1_pInt:3_pInt, j=1_pInt:3_pInt) + forall (i=1:3, j=1:3) dS_dFe(i,j,1:3,1:3) = & matmul(Fe,matmul(matmul(Fi,C(i,j,1:3,1:3)),transpose(Fi))) !< dS_ij/dFe_kl = C_ijmn * Fi_lm * Fi_on * Fe_ko dS_dFi(i,j,1:3,1:3) = 2.0_pReal*matmul(matmul(E,Fi),C(i,j,1:3,1:3)) !< dS_ij/dFi_kl = C_ijln * E_km * Fe_mn @@ -790,7 +787,7 @@ subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, source_thermal_externalheat_dotState implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -805,7 +802,7 @@ subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, S !< 2nd Piola Kirchhoff stress (vector notation) real(pReal), dimension(3,3) :: & Mp - integer(pInt) :: & + integer :: & ho, & !< homogenization tme, & !< thermal member position i, & !< counter in source loop @@ -848,7 +845,7 @@ subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, subdt,ip,el) end select plasticityType - SourceLoop: do i = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) + SourceLoop: do i = 1, phase_Nsources(material_phase(ipc,ip,el)) sourceType: select case (phase_source(i,material_phase(ipc,ip,el))) @@ -900,7 +897,7 @@ subroutine constitutive_collectDeltaState(S, Fe, Fi, ipc, ip, el) source_damage_isoBrittle_deltaState implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -910,7 +907,7 @@ subroutine constitutive_collectDeltaState(S, Fe, Fi, ipc, ip, el) Fi !< intermediate deformation gradient real(pReal), dimension(3,3) :: & Mp - integer(pInt) :: & + integer :: & i, & instance, of @@ -928,7 +925,7 @@ subroutine constitutive_collectDeltaState(S, Fe, Fi, ipc, ip, el) end select plasticityType - sourceLoop: do i = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) + sourceLoop: do i = 1, phase_Nsources(material_phase(ipc,ip,el)) sourceType: select case (phase_source(i,material_phase(ipc,ip,el))) @@ -994,7 +991,7 @@ function constitutive_postResults(S, Fi, ipc, ip, el) source_damage_anisoDuctile_postResults implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -1007,9 +1004,9 @@ function constitutive_postResults(S, Fi, ipc, ip, el) S !< 2nd Piola Kirchhoff stress real(pReal), dimension(3,3) :: & Mp !< Mandel stress - integer(pInt) :: & + integer :: & startPos, endPos - integer(pInt) :: & + integer :: & ho, & !< homogenization tme, & !< thermal member position i, of, instance !< counter in source loop @@ -1021,7 +1018,7 @@ function constitutive_postResults(S, Fi, ipc, ip, el) ho = material_homogenizationAt(el) tme = thermalMapping(ho)%p(ip,el) - startPos = 1_pInt + startPos = 1 endPos = plasticState(material_phase(ipc,ip,el))%sizePostResults of = phasememberAt(ipc,ip,el) @@ -1054,8 +1051,8 @@ function constitutive_postResults(S, Fi, ipc, ip, el) end select plasticityType - SourceLoop: do i = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) - startPos = endPos + 1_pInt + SourceLoop: do i = 1, phase_Nsources(material_phase(ipc,ip,el)) + startPos = endPos + 1 endPos = endPos + sourceState(material_phase(ipc,ip,el))%p(i)%sizePostResults of = phasememberAt(ipc,ip,el) sourceType: select case (phase_source(i,material_phase(ipc,ip,el))) @@ -1077,7 +1074,7 @@ end function constitutive_postResults !-------------------------------------------------------------------------------------------------- !> @brief writes constitutive results to HDF5 output file !-------------------------------------------------------------------------------------------------- -subroutine constitutive_results() +subroutine constitutive_results use material, only: & PLASTICITY_ISOTROPIC_ID, & PLASTICITY_PHENOPOWERLAW_ID, & @@ -1085,7 +1082,7 @@ subroutine constitutive_results() PLASTICITY_DISLOTWIN_ID, & PLASTICITY_DISLOUCLA_ID, & PLASTICITY_NONLOCAL_ID -#if defined(PETSc) || defined(DAMASKHDF5) +#if defined(PETSc) || defined(DAMASK_HDF5) use results use HDF5_utilities use config, only: & @@ -1108,36 +1105,38 @@ subroutine constitutive_results() use plastic_nonlocal, only: & plastic_nonlocal_results - implicit none - integer :: p - call HDF5_closeGroup(results_addGroup('current/phase')) - do p=1,size(config_name_phase) - call HDF5_closeGroup(results_addGroup('current/phase/'//trim(config_name_phase(p)))) + integer :: p + character(len=256) :: group + + do p=1,size(config_name_phase) + group = trim('current/constituent')//'/'//trim(config_name_phase(p)) + call HDF5_closeGroup(results_addGroup(group)) + group = trim(group)//'/plastic' + + call HDF5_closeGroup(results_addGroup(group)) select case(material_phase_plasticity_type(p)) case(PLASTICITY_ISOTROPIC_ID) - call plastic_isotropic_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) + call plastic_isotropic_results(phase_plasticityInstance(p),group) case(PLASTICITY_PHENOPOWERLAW_ID) - call plastic_phenopowerlaw_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) + call plastic_phenopowerlaw_results(phase_plasticityInstance(p),group) - case(PLASTICITY_KINEHARDENING_ID) - call plastic_kinehardening_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) + case(PLASTICITY_KINEHARDENING_ID) + call plastic_kinehardening_results(phase_plasticityInstance(p),group) - case(PLASTICITY_DISLOTWIN_ID) - call plastic_dislotwin_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) + case(PLASTICITY_DISLOTWIN_ID) + call plastic_dislotwin_results(phase_plasticityInstance(p),group) - case(PLASTICITY_DISLOUCLA_ID) - call plastic_disloUCLA_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) + case(PLASTICITY_DISLOUCLA_ID) + call plastic_disloUCLA_results(phase_plasticityInstance(p),group) - case(PLASTICITY_NONLOCAL_ID) - call plastic_nonlocal_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) - + case(PLASTICITY_NONLOCAL_ID) + call plastic_nonlocal_results(phase_plasticityInstance(p),group) end select - enddo - + enddo #endif diff --git a/src/crystallite.f90 b/src/crystallite.f90 index b234d133d..02aec8b7a 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -10,7 +10,8 @@ module crystallite use prec, only: & - pReal + pReal, & + pStringLen use rotations, only: & rotation use FEsolving, only: & @@ -103,6 +104,13 @@ module crystallite end enum integer(kind(undefined_ID)),dimension(:,:), allocatable, private :: & crystallite_outputID !< ID of each post result output + + type, private :: tOutput !< new requested output (per phase) + character(len=65536), allocatable, dimension(:) :: & + label + end type tOutput + type(tOutput), allocatable, dimension(:), private :: output_constituent + procedure(), pointer :: integrateState public :: & @@ -111,7 +119,8 @@ module crystallite crystallite_stressTangent, & crystallite_orientations, & crystallite_push33ToRef, & - crystallite_postResults + crystallite_postResults, & + crystallite_results private :: & integrateStress, & integrateState, & @@ -156,6 +165,7 @@ subroutine crystallite_init use config, only: & config_deallocate, & config_crystallite, & + config_phase, & crystallite_name use constitutive, only: & constitutive_initialFi, & @@ -296,6 +306,18 @@ subroutine crystallite_init end select outputName enddo enddo + + allocate(output_constituent(size(config_phase))) + do c = 1, size(config_phase) +#if defined(__GFORTRAN__) + allocate(output_constituent(c)%label(1)) + output_constituent(c)%label(1)= 'GfortranBug86277' + output_constituent(c)%label = config_phase(c)%getStrings('(output)',defaultVal=output_constituent(c)%label ) + if (output_constituent(c)%label (1) == 'GfortranBug86277') output_constituent(c)%label = [character(len=pStringLen)::] +#else + output_constituent(c)%label = config_phase(c)%getStrings('(output)',defaultVal=[character(len=pStringLen)::]) +#endif + enddo do r = 1,size(config_crystallite) @@ -340,6 +362,7 @@ subroutine crystallite_init close(FILEUNIT) endif + call config_deallocate('material.config/phase') call config_deallocate('material.config/crystallite') !-------------------------------------------------------------------------------------------------- @@ -1053,6 +1076,156 @@ function crystallite_postResults(ipc, ip, el) end function crystallite_postResults +!-------------------------------------------------------------------------------------------------- +!> @brief writes crystallite results to HDF5 output file +!-------------------------------------------------------------------------------------------------- +subroutine crystallite_results +#if defined(PETSc) || defined(DAMASK_HDF5) + use lattice + use results + use HDF5_utilities + use rotations + use config, only: & + config_name_phase => phase_name ! anticipate logical name + + use material, only: & + material_phase_plasticity_type => phase_plasticity + + implicit none + integer :: p,o + real(pReal), allocatable, dimension(:,:,:) :: selected_tensors + type(rotation), allocatable, dimension(:) :: selected_rotations + character(len=256) :: group,lattice_label + + do p=1,size(config_name_phase) + group = trim('current/constituent')//'/'//trim(config_name_phase(p))//'/generic' + + call HDF5_closeGroup(results_addGroup(group)) + + do o = 1, size(output_constituent(p)%label) + select case (output_constituent(p)%label(o)) + case('f') + selected_tensors = select_tensors(crystallite_partionedF,p) + call results_writeDataset(group,selected_tensors,'F',& + 'deformation gradient','1') + case('fe') + selected_tensors = select_tensors(crystallite_Fe,p) + call results_writeDataset(group,selected_tensors,'Fe',& + 'elastic deformation gradient','1') + case('fp') + selected_tensors = select_tensors(crystallite_Fp,p) + call results_writeDataset(group,selected_tensors,'Fp',& + 'plastic deformation gradient','1') + case('fi') + selected_tensors = select_tensors(crystallite_Fi,p) + call results_writeDataset(group,selected_tensors,'Fi',& + 'inelastic deformation gradient','1') + case('lp') + selected_tensors = select_tensors(crystallite_Lp,p) + call results_writeDataset(group,selected_tensors,'Lp',& + 'plastic velocity gradient','1/s') + case('li') + selected_tensors = select_tensors(crystallite_Li,p) + call results_writeDataset(group,selected_tensors,'Li',& + 'inelastic velocity gradient','1/s') + case('p') + selected_tensors = select_tensors(crystallite_P,p) + call results_writeDataset(group,selected_tensors,'P',& + '1st Piola-Kirchoff stress','Pa') + case('s') + selected_tensors = select_tensors(crystallite_S,p) + call results_writeDataset(group,selected_tensors,'S',& + '2nd Piola-Kirchoff stress','Pa') + case('orientation') + select case(lattice_structure(p)) + case(LATTICE_iso_ID) + lattice_label = 'iso' + case(LATTICE_fcc_ID) + lattice_label = 'fcc' + case(LATTICE_bcc_ID) + lattice_label = 'bcc' + case(LATTICE_bct_ID) + lattice_label = 'bct' + case(LATTICE_hex_ID) + lattice_label = 'hex' + case(LATTICE_ort_ID) + lattice_label = 'ort' + end select + selected_rotations = select_rotations(crystallite_orientation,p) + call results_writeDataset(group,selected_rotations,'orientation',& + 'crystal orientation as quaternion',lattice_label) + end select + enddo + enddo + + contains + +!-------------------------------------------------------------------------------------------------- +!> @brief select tensors for output +!-------------------------------------------------------------------------------------------------- + function select_tensors(dataset,instance) + + use material, only: & + homogenization_maxNgrains, & + material_phaseAt + + integer, intent(in) :: instance + real(pReal), dimension(:,:,:,:,:), intent(in) :: dataset + real(pReal), allocatable, dimension(:,:,:) :: select_tensors + integer :: e,i,c,j + + allocate(select_tensors(3,3,count(material_phaseAt==instance)*homogenization_maxNgrains)) + + j=0 + do e = 1, size(material_phaseAt,2) + do i = 1, homogenization_maxNgrains !ToDo: this needs to be changed for varying Ngrains + do c = 1, size(material_phaseAt,1) + if (material_phaseAt(c,e) == instance) then + j = j + 1 + select_tensors(1:3,1:3,j) = dataset(1:3,1:3,c,i,e) + endif + enddo + enddo + enddo + + end function select_tensors + + +!-------------------------------------------------------------------------------------------------- +!> @brief select rotations for output +!-------------------------------------------------------------------------------------------------- + function select_rotations(dataset,instance) + + use material, only: & + homogenization_maxNgrains, & + material_phaseAt + + integer, intent(in) :: instance + type(rotation), dimension(:,:,:), intent(in) :: dataset + type(rotation), allocatable, dimension(:) :: select_rotations + integer :: e,i,c,j + + allocate(select_rotations(count(material_phaseAt==instance)*homogenization_maxNgrains)) + + j=0 + do e = 1, size(material_phaseAt,2) + do i = 1, homogenization_maxNgrains !ToDo: this needs to be changed for varying Ngrains + do c = 1, size(material_phaseAt,1) + if (material_phaseAt(c,e) == instance) then + j = j + 1 + select_rotations(j) = dataset(c,i,e) + endif + enddo + enddo + enddo + + end function select_rotations +#endif + + +end subroutine crystallite_results + + !-------------------------------------------------------------------------------------------------- !> @brief calculation of stress (P) with time integration based on a residuum in Lp and !> intermediate acceleration of the Newton-Raphson correction diff --git a/src/DAMASK_grid.f90 b/src/grid/DAMASK_grid.f90 similarity index 99% rename from src/DAMASK_grid.f90 rename to src/grid/DAMASK_grid.f90 index 29b505d14..f2f52bb2f 100644 --- a/src/DAMASK_grid.f90 +++ b/src/grid/DAMASK_grid.f90 @@ -358,6 +358,11 @@ program DAMASK_spectral enddo close(fileUnit) + call results_openJobFile + call results_addAttribute('grid',grid,'mapping') + call results_addAttribute('size',geomSize,'mapping') + call results_closeJobFile + !-------------------------------------------------------------------------------------------------- ! doing initialization depending on active solvers call Utilities_init() diff --git a/src/grid_damage_spectral.f90 b/src/grid/grid_damage_spectral.f90 similarity index 99% rename from src/grid_damage_spectral.f90 rename to src/grid/grid_damage_spectral.f90 index c5e9a254b..3ce37c5ff 100644 --- a/src/grid_damage_spectral.f90 +++ b/src/grid/grid_damage_spectral.f90 @@ -64,7 +64,6 @@ subroutine grid_damage_spectral_init worldsize, & petsc_options - implicit none PetscInt, dimension(worldsize) :: localK integer :: i, j, k, cell DM :: damage_grid @@ -164,7 +163,6 @@ function grid_damage_spectral_solution(timeinc,timeinc_old,loadCaseTime) result( use damage_nonlocal, only: & damage_nonlocal_putNonLocalDamage - implicit none real(pReal), intent(in) :: & timeinc, & !< increment in time for current solution timeinc_old, & !< increment in time of last increment @@ -236,7 +234,6 @@ subroutine grid_damage_spectral_forward damage_nonlocal_getDiffusion33, & damage_nonlocal_getMobility - implicit none integer :: i, j, k, cell DM :: dm_local PetscScalar, dimension(:,:,:), pointer :: x_scal @@ -301,7 +298,6 @@ subroutine formResidual(in,x_scal,f_scal,dummy,ierr) damage_nonlocal_getDiffusion33, & damage_nonlocal_getMobility - implicit none DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & in PetscScalar, dimension( & diff --git a/src/grid/grid_mech_FEM.f90 b/src/grid/grid_mech_FEM.f90 new file mode 100644 index 000000000..2feec76df --- /dev/null +++ b/src/grid/grid_mech_FEM.f90 @@ -0,0 +1,713 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Arko Jyoti Bhattacharjee, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Grid solver for mechanics: FEM +!-------------------------------------------------------------------------------------------------- +module grid_mech_FEM +#include +#include + use DAMASK_interface + use HDF5_utilities + use PETScdmda + use PETScsnes + use prec, only: & + pReal + use math, only: & + math_I3 + use spectral_utilities, only: & + tSolutionState, & + tSolutionParams + + implicit none + private + +!-------------------------------------------------------------------------------------------------- +! derived types + type(tSolutionParams), private :: params + +!-------------------------------------------------------------------------------------------------- +! PETSc data + DM, private :: mech_grid + SNES, private :: mech_snes + Vec, private :: solution_current, solution_lastInc, solution_rate + +!-------------------------------------------------------------------------------------------------- +! common pointwise data + real(pReal), private, dimension(:,:,:,:,:), allocatable :: F, P_current, F_lastInc + real(pReal), private :: detJ + real(pReal), private, dimension(3) :: delta + real(pReal), private, dimension(3,8) :: BMat + real(pReal), private, dimension(8,8) :: HGMat + PetscInt, private :: xstart,ystart,zstart,xend,yend,zend + +!-------------------------------------------------------------------------------------------------- +! stress, stiffness and compliance average etc. + real(pReal), private, dimension(3,3) :: & + F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient + F_aim = math_I3, & !< current prescribed deformation gradient + F_aim_lastIter = math_I3, & + F_aim_lastInc = math_I3, & !< previous average deformation gradient + P_av = 0.0_pReal !< average 1st Piola--Kirchhoff stress + + character(len=1024), private :: incInfo !< time and increment information + + real(pReal), private, dimension(3,3,3,3) :: & + C_volAvg = 0.0_pReal, & !< current volume average stiffness + C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness + S = 0.0_pReal !< current compliance (filled up with zeros) + + real(pReal), private :: & + err_BC !< deviation from stress BC + + integer, private :: & + totalIter = 0 !< total iteration in current increment + + public :: & + grid_mech_FEM_init, & + grid_mech_FEM_solution, & + grid_mech_FEM_forward + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all necessary fields and fills them with data, potentially from restart info +!-------------------------------------------------------------------------------------------------- +subroutine grid_mech_FEM_init + use IO, only: & + IO_intOut, & + IO_error, & + IO_open_jobFile_binary + use FEsolving, only: & + restartInc + use numerics, only: & + worldrank, & + worldsize, & + petsc_options + use homogenization, only: & + materialpoint_F0 + use DAMASK_interface, only: & + getSolverJobName + use spectral_utilities, only: & + utilities_constitutiveResponse, & + utilities_updateIPcoords, & + wgt + use mesh, only: & + geomSize, & + grid, & + grid3 + use math, only: & + math_invSym3333 + + real(pReal) :: HGCoeff = 0e-2_pReal + PetscInt, dimension(:), allocatable :: localK + real(pReal), dimension(3,3) :: & + temp33_Real = 0.0_pReal + real(pReal), dimension(4,8) :: & + HGcomp = reshape([ 1.0_pReal, 1.0_pReal, 1.0_pReal,-1.0_pReal, & + 1.0_pReal,-1.0_pReal,-1.0_pReal, 1.0_pReal, & + -1.0_pReal, 1.0_pReal,-1.0_pReal, 1.0_pReal, & + -1.0_pReal,-1.0_pReal, 1.0_pReal,-1.0_pReal, & + -1.0_pReal,-1.0_pReal, 1.0_pReal, 1.0_pReal, & + -1.0_pReal, 1.0_pReal,-1.0_pReal,-1.0_pReal, & + 1.0_pReal,-1.0_pReal,-1.0_pReal,-1.0_pReal, & + 1.0_pReal, 1.0_pReal, 1.0_pReal, 1.0_pReal], [4,8]) + PetscErrorCode :: ierr + integer :: rank + integer(HID_T) :: fileHandle + character(len=1024) :: rankStr + real(pReal), dimension(3,3,3,3) :: devNull + PetscScalar, pointer, dimension(:,:,:,:) :: & + u_current,u_lastInc + + write(6,'(/,a)') ' <<<+- grid_mech_FEM init -+>>>' + +!-------------------------------------------------------------------------------------------------- +! set default and user defined options for PETSc + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,'-mech_snes_type newtonls -mech_ksp_type fgmres & + &-mech_ksp_max_it 25 -mech_pc_type ml -mech_mg_levels_ksp_type chebyshev',ierr) + CHKERRQ(ierr) + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) + CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! allocate global fields + allocate(F (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(P_current (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(F_lastInc (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + +!-------------------------------------------------------------------------------------------------- +! initialize solver specific parts of PETSc + call SNESCreate(PETSC_COMM_WORLD,mech_snes,ierr); CHKERRQ(ierr) + call SNESSetOptionsPrefix(mech_snes,'mech_',ierr);CHKERRQ(ierr) + allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 + do rank = 1, worldsize + call MPI_Bcast(localK(rank),1,MPI_INTEGER,rank-1,PETSC_COMM_WORLD,ierr) + enddo + call DMDACreate3d(PETSC_COMM_WORLD, & + DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, & + DMDA_STENCIL_BOX, & + grid(1),grid(2),grid(3), & + 1, 1, worldsize, & + 3, 1, & + [grid(1)],[grid(2)],localK, & + mech_grid,ierr) + CHKERRQ(ierr) + call DMDASetUniformCoordinates(mech_grid,0.0_pReal,geomSize(1),0.0_pReal,geomSize(2),0.0_pReal,geomSize(3),ierr) + CHKERRQ(ierr) + call SNESSetDM(mech_snes,mech_grid,ierr); CHKERRQ(ierr) + call DMsetFromOptions(mech_grid,ierr); CHKERRQ(ierr) + call DMsetUp(mech_grid,ierr); CHKERRQ(ierr) + call DMCreateGlobalVector(mech_grid,solution_current,ierr); CHKERRQ(ierr) + call DMCreateGlobalVector(mech_grid,solution_lastInc,ierr); CHKERRQ(ierr) + call DMCreateGlobalVector(mech_grid,solution_rate ,ierr); CHKERRQ(ierr) + call DMSNESSetFunctionLocal(mech_grid,formResidual,PETSC_NULL_SNES,ierr) + CHKERRQ(ierr) + call DMSNESSetJacobianLocal(mech_grid,formJacobian,PETSC_NULL_SNES,ierr) + CHKERRQ(ierr) + call SNESSetConvergenceTest(mech_snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "_converged" + CHKERRQ(ierr) + call SNESSetMaxLinearSolveFailures(mech_snes, huge(1), ierr); CHKERRQ(ierr) ! ignore linear solve failures + call SNESSetFromOptions(mech_snes,ierr); CHKERRQ(ierr) ! pull it all together with additional cli arguments + +!-------------------------------------------------------------------------------------------------- +! init fields + call VecSet(solution_current,0.0_pReal,ierr);CHKERRQ(ierr) + call VecSet(solution_lastInc,0.0_pReal,ierr);CHKERRQ(ierr) + call VecSet(solution_rate ,0.0_pReal,ierr);CHKERRQ(ierr) + call DMDAVecGetArrayF90(mech_grid,solution_current,u_current,ierr); CHKERRQ(ierr) + call DMDAVecGetArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr); CHKERRQ(ierr) + + call DMDAGetCorners(mech_grid,xstart,ystart,zstart,xend,yend,zend,ierr) ! local grid extent + CHKERRQ(ierr) + xend = xstart+xend-1 + yend = ystart+yend-1 + zend = zstart+zend-1 + delta = geomSize/real(grid,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 + + HGMat = matmul(transpose(HGcomp),HGcomp) & + * HGCoeff*(delta(1)*delta(2) + delta(2)*delta(3) + delta(3)*delta(1))/16.0_pReal ! hourglass stabilization matrix + +!-------------------------------------------------------------------------------------------------- +! init fields + restart: if (restartInc > 0) then + write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading values of increment ', restartInc, ' from file' + + write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') + + call HDF5_read(fileHandle,F_aim, 'F_aim') + call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') + call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_read(fileHandle,F, 'F') + call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_read(fileHandle,u_current, 'u') + call HDF5_read(fileHandle,u_lastInc, 'u_lastInc') + + elseif (restartInc == 0) then restart + F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity + F = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) + endif restart + materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent + call utilities_updateIPcoords(F) + call utilities_constitutiveResponse(P_current,temp33_Real,C_volAvg,devNull, & ! stress field, stress avg, global average of stiffness and (min+max)/2 + F, & ! target F + 0.0_pReal, & ! time increment + math_I3) ! no rotation of boundary condition + call DMDAVecRestoreArrayF90(mech_grid,solution_current,u_current,ierr) + CHKERRQ(ierr) + call DMDAVecRestoreArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr) + CHKERRQ(ierr) + + restartRead: if (restartInc > 0) then + write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading more values of increment ', restartInc, ' from file' + call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_closeFile(fileHandle) + endif restartRead + +end subroutine grid_mech_FEM_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief solution for the FEM scheme with internal iterations +!-------------------------------------------------------------------------------------------------- +function grid_mech_FEM_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation_BC) result(solution) + use IO, only: & + IO_error + use spectral_utilities, only: & + tBoundaryCondition, & + utilities_maskedCompliance + use FEsolving, only: & + restartWrite, & + terminallyIll + +!-------------------------------------------------------------------------------------------------- +! input data for solution + character(len=*), intent(in) :: & + incInfoIn + real(pReal), intent(in) :: & + timeinc, & !< time increment of current solution + timeinc_old !< time increment of last successful increment + type(tBoundaryCondition), intent(in) :: & + stress_BC + real(pReal), dimension(3,3), intent(in) :: rotation_BC + type(tSolutionState) :: & + solution +!-------------------------------------------------------------------------------------------------- +! PETSc Data + PetscErrorCode :: ierr + SNESConvergedReason :: reason + + incInfo = incInfoIn + +!-------------------------------------------------------------------------------------------------- +! update stiffness (and gamma operator) + S = utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) +!-------------------------------------------------------------------------------------------------- +! set module wide available data + params%stress_mask = stress_BC%maskFloat + params%stress_BC = stress_BC%values + params%rotation_BC = rotation_BC + params%timeinc = timeinc + params%timeincOld = timeinc_old + +!-------------------------------------------------------------------------------------------------- +! solve BVP + call SNESsolve(mech_snes,PETSC_NULL_VEC,solution_current,ierr);CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! check convergence + call SNESGetConvergedReason(mech_snes,reason,ierr);CHKERRQ(ierr) + + solution%converged = reason > 0 + solution%iterationsNeeded = totalIter + solution%termIll = terminallyIll + terminallyIll = .false. + +end function grid_mech_FEM_solution + + +!-------------------------------------------------------------------------------------------------- +!> @brief forwarding routine +!> @details find new boundary conditions and best F estimate for end of current timestep +!> possibly writing restart information, triggering of state increment in DAMASK, and updating of IPcoordinates +!-------------------------------------------------------------------------------------------------- +subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) + use math, only: & + math_rotate_backward33 + use numerics, only: & + worldrank + use homogenization, only: & + materialpoint_F0 + use mesh, only: & + grid, & + grid3 + use CPFEM2, only: & + CPFEM_age + use spectral_utilities, only: & + utilities_updateIPcoords, & + tBoundaryCondition, & + cutBack + use IO, only: & + IO_open_jobFile_binary + use FEsolving, only: & + restartWrite + + logical, intent(in) :: & + guess + real(pReal), intent(in) :: & + timeinc_old, & + timeinc, & + loadCaseTime !< remaining time of current load case + type(tBoundaryCondition), intent(in) :: & + stress_BC, & + deformation_BC + real(pReal), dimension(3,3), intent(in) :: & + rotation_BC + PetscErrorCode :: ierr + integer(HID_T) :: fileHandle + character(len=32) :: rankStr + PetscScalar, pointer, dimension(:,:,:,:) :: & + u_current,u_lastInc + + call DMDAVecGetArrayF90(mech_grid,solution_current,u_current,ierr); CHKERRQ(ierr) + call DMDAVecGetArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr); CHKERRQ(ierr) + + if (cutBack) then + C_volAvg = C_volAvgLastInc ! QUESTION: where is this required? + else + !-------------------------------------------------------------------------------------------------- + ! restart information for spectral solver + if (restartWrite) then + write(6,'(/,a)') ' writing converged results for restart';flush(6) + + write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') + + call HDF5_write(fileHandle,F_aim, 'F_aim') + call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') + call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_write(fileHandle,F, 'F') + call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_write(fileHandle,u_current, 'u') + call HDF5_write(fileHandle,u_lastInc, 'u_lastInc') + + call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + + call HDF5_closeFile(fileHandle) + + endif + call CPFEM_age ! age state and kinematics + call utilities_updateIPcoords(F) + + C_volAvgLastInc = C_volAvg + + F_aimDot = merge(stress_BC%maskFloat*(F_aim-F_aim_lastInc)/timeinc_old, 0.0_pReal, guess) + F_aim_lastInc = F_aim + + !-------------------------------------------------------------------------------------------------- + ! calculate rate for aim + if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F + F_aimDot = & + F_aimDot + deformation_BC%maskFloat * matmul(deformation_BC%values, F_aim_lastInc) + elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed + F_aimDot = & + F_aimDot + deformation_BC%maskFloat * deformation_BC%values + elseif (deformation_BC%myType=='f') then ! aim at end of load case is prescribed + F_aimDot = & + F_aimDot + deformation_BC%maskFloat * (deformation_BC%values - F_aim_lastInc)/loadCaseTime + endif + + + if (guess) then + call VecWAXPY(solution_rate,-1.0_pReal,solution_lastInc,solution_current,ierr) + CHKERRQ(ierr) + call VecScale(solution_rate,1.0_pReal/timeinc_old,ierr); CHKERRQ(ierr) + else + call VecSet(solution_rate,0.0_pReal,ierr); CHKERRQ(ierr) + endif + call VecCopy(solution_current,solution_lastInc,ierr); CHKERRQ(ierr) + + F_lastInc = F ! winding F forward + materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent + + endif + +!-------------------------------------------------------------------------------------------------- +! update average and local deformation gradients + F_aim = F_aim_lastInc + F_aimDot * timeinc + call VecAXPY(solution_current,timeinc,solution_rate,ierr); CHKERRQ(ierr) + + call DMDAVecRestoreArrayF90(mech_grid,solution_current,u_current,ierr) + CHKERRQ(ierr) + call DMDAVecRestoreArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr) + CHKERRQ(ierr) + +end subroutine grid_mech_FEM_forward + + +!-------------------------------------------------------------------------------------------------- +!> @brief convergence check +!-------------------------------------------------------------------------------------------------- +subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,ierr) + use mesh + use spectral_utilities + use numerics, only: & + itmax, & + itmin, & + err_div_tolRel, & + err_div_tolAbs, & + err_stress_tolRel, & + err_stress_tolAbs + use FEsolving, only: & + terminallyIll + + SNES :: snes_local + PetscInt, intent(in) :: PETScIter + PetscReal, intent(in) :: & + devNull1, & + devNull2, & + fnorm + SNESConvergedReason :: reason + PetscObject :: dummy + PetscErrorCode :: ierr + real(pReal) :: & + err_div, & + divTol, & + BCTol + + err_div = fnorm*sqrt(wgt)*geomSize(1)/scaledGeomSize(1)/detJ + divTol = max(maxval(abs(P_av))*err_div_tolRel ,err_div_tolAbs) + BCTol = max(maxval(abs(P_av))*err_stress_tolRel,err_stress_tolAbs) + + if ((totalIter >= itmin .and. & + all([ err_div/divTol, & + err_BC /BCTol ] < 1.0_pReal)) & + .or. terminallyIll) then + reason = 1 + elseif (totalIter >= itmax) then + reason = -1 + else + reason = 0 + endif + +!-------------------------------------------------------------------------------------------------- +! report + write(6,'(1/,a)') ' ... reporting .............................................................' + write(6,'(1/,a,f12.2,a,es8.2,a,es9.2,a)') ' error divergence = ', & + err_div/divTol, ' (',err_div,' / m, tol = ',divTol,')' + write(6,'(a,f12.2,a,es8.2,a,es9.2,a)') ' error stress BC = ', & + err_BC/BCTol, ' (',err_BC, ' Pa, tol = ',BCTol,')' + write(6,'(/,a)') ' ===========================================================================' + flush(6) + +end subroutine converged + + +!-------------------------------------------------------------------------------------------------- +!> @brief forms the residual vector +!-------------------------------------------------------------------------------------------------- +subroutine formResidual(da_local,x_local, & + f_local,dummy,ierr) + use numerics, only: & + itmax, & + itmin + use numerics, only: & + worldrank + use mesh, only: & + grid + use math, only: & + math_rotate_backward33, & + math_mul3333xx33 + use debug, only: & + debug_level, & + debug_spectral, & + debug_spectralRotation + use spectral_utilities, only: & + utilities_constitutiveResponse + use IO, only: & + IO_intOut + use FEsolving, only: & + terminallyIll + use homogenization, only: & + materialpoint_dPdF + + DM :: da_local + Vec :: x_local, f_local + PetscScalar, pointer,dimension(:,:,:,:) :: x_scal, f_scal + PetscScalar, dimension(8,3) :: x_elem, f_elem + PetscInt :: i, ii, j, jj, k, kk, ctr, ele + real(pReal), dimension(3,3) :: & + deltaF_aim + PetscInt :: & + PETScIter, & + nfuncs + PetscObject :: dummy + PetscErrorCode :: ierr + real(pReal), dimension(3,3,3,3) :: devNull + + + call SNESGetNumberFunctionEvals(mech_snes,nfuncs,ierr); CHKERRQ(ierr) + call SNESGetIterationNumber(mech_snes,PETScIter,ierr); CHKERRQ(ierr) + + if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1 ! new increment + +!-------------------------------------------------------------------------------------------------- +! begin of new iteration + newIteration: if (totalIter <= PETScIter) then + totalIter = totalIter + 1 + write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') & + trim(incInfo), ' @ Iteration ', itmin, '≤',totalIter+1, '≤', itmax + if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & + ' deformation gradient aim (lab) =', transpose(math_rotate_backward33(F_aim,params%rotation_BC)) + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & + ' deformation gradient aim =', transpose(F_aim) + flush(6) + endif newIteration + +!-------------------------------------------------------------------------------------------------- +! get deformation gradient + call DMDAVecGetArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) + do k = zstart, zend; do j = ystart, yend; do i = xstart, xend + ctr = 0 + do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 + ctr = ctr + 1 + x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) + enddo; enddo; enddo + ii = i-xstart+1; jj = j-ystart+1; kk = k-zstart+1 + F(1:3,1:3,ii,jj,kk) = math_rotate_backward33(F_aim,params%rotation_BC) + transpose(matmul(BMat,x_elem)) + enddo; enddo; enddo + call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! evaluate constitutive response + call Utilities_constitutiveResponse(P_current,& + P_av,C_volAvg,devNull, & + F,params%timeinc,params%rotation_BC) + call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) + +!-------------------------------------------------------------------------------------------------- +! stress BC handling + F_aim_lastIter = F_aim + deltaF_aim = math_mul3333xx33(S, P_av - params%stress_BC) + F_aim = F_aim - deltaF_aim + err_BC = maxval(abs(params%stress_mask * (P_av - params%stress_BC))) ! mask = 0.0 when no stress bc + +!-------------------------------------------------------------------------------------------------- +! constructing residual + call VecSet(f_local,0.0_pReal,ierr);CHKERRQ(ierr) + call DMDAVecGetArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) + call DMDAVecGetArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) + ele = 0 + do k = zstart, zend; do j = ystart, yend; do i = xstart, xend + ctr = 0 + do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 + ctr = ctr + 1 + x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) + enddo; enddo; enddo + ii = i-xstart+1; jj = j-ystart+1; kk = k-zstart+1 + ele = ele + 1 + f_elem = matmul(transpose(BMat),transpose(P_current(1:3,1:3,ii,jj,kk)))*detJ + & + matmul(HGMat,x_elem)*(materialpoint_dPdF(1,1,1,1,1,ele) + & + materialpoint_dPdF(2,2,2,2,1,ele) + & + materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal + ctr = 0 + do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 + ctr = ctr + 1 + f_scal(0:2,i+ii,j+jj,k+kk) = f_scal(0:2,i+ii,j+jj,k+kk) + f_elem(ctr,1:3) + enddo; enddo; enddo + enddo; enddo; enddo + call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) + call DMDAVecRestoreArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! applying boundary conditions + call DMDAVecGetArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) + if (zstart == 0) then + f_scal(0:2,xstart,ystart,zstart) = 0.0 + f_scal(0:2,xend+1,ystart,zstart) = 0.0 + f_scal(0:2,xstart,yend+1,zstart) = 0.0 + f_scal(0:2,xend+1,yend+1,zstart) = 0.0 + endif + if (zend + 1 == grid(3)) then + f_scal(0:2,xstart,ystart,zend+1) = 0.0 + f_scal(0:2,xend+1,ystart,zend+1) = 0.0 + f_scal(0:2,xstart,yend+1,zend+1) = 0.0 + f_scal(0:2,xend+1,yend+1,zend+1) = 0.0 + endif + call DMDAVecRestoreArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) + +end subroutine formResidual + + +!-------------------------------------------------------------------------------------------------- +!> @brief forms the FEM stiffness matrix +!-------------------------------------------------------------------------------------------------- +subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,ierr) + use mesh, only: & + mesh_ipCoordinates + use homogenization, only: & + materialpoint_dPdF + + + DM :: da_local + Vec :: x_local, coordinates + Mat :: Jac_pre, Jac + MatStencil,dimension(4,24) :: row, col + PetscScalar,pointer,dimension(:,:,:,:) :: x_scal + PetscScalar,dimension(24,24) :: K_ele + PetscScalar,dimension(9,24) :: BMatFull + PetscInt :: i, ii, j, jj, k, kk, ctr, ele + PetscInt,dimension(3) :: rows + PetscScalar :: diag + PetscObject :: dummy + MatNullSpace :: matnull + PetscErrorCode :: ierr + + BMatFull = 0.0 + BMatFull(1:3,1 :8 ) = BMat + BMatFull(4:6,9 :16) = BMat + BMatFull(7:9,17:24) = BMat + call MatSetOption(Jac,MAT_KEEP_NONZERO_PATTERN,PETSC_TRUE,ierr); CHKERRQ(ierr) + call MatSetOption(Jac,MAT_NEW_NONZERO_ALLOCATION_ERR,PETSC_FALSE,ierr); CHKERRQ(ierr) + call MatZeroEntries(Jac,ierr); CHKERRQ(ierr) + ele = 0 + do k = zstart, zend; do j = ystart, yend; do i = xstart, xend + ctr = 0 + do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 + ctr = ctr + 1 + col(MatStencil_i,ctr ) = i+ii + col(MatStencil_j,ctr ) = j+jj + col(MatStencil_k,ctr ) = k+kk + col(MatStencil_c,ctr ) = 0 + col(MatStencil_i,ctr+8 ) = i+ii + col(MatStencil_j,ctr+8 ) = j+jj + col(MatStencil_k,ctr+8 ) = k+kk + col(MatStencil_c,ctr+8 ) = 1 + col(MatStencil_i,ctr+16) = i+ii + col(MatStencil_j,ctr+16) = j+jj + col(MatStencil_k,ctr+16) = k+kk + col(MatStencil_c,ctr+16) = 2 + enddo; enddo; enddo + row = col + ele = ele + 1 + K_ele = 0.0 + K_ele(1 :8 ,1 :8 ) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & + materialpoint_dPdF(2,2,2,2,1,ele) + & + materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal + K_ele(9 :16,9 :16) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & + materialpoint_dPdF(2,2,2,2,1,ele) + & + materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal + K_ele(17:24,17:24) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & + materialpoint_dPdF(2,2,2,2,1,ele) + & + materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal + K_ele = K_ele + & + matmul(transpose(BMatFull), & + matmul(reshape(reshape(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,ele), & + shape=[3,3,3,3], order=[2,1,4,3]),shape=[9,9]),BMatFull))*detJ + call MatSetValuesStencil(Jac,24,row,24,col,K_ele,ADD_VALUES,ierr) + CHKERRQ(ierr) + enddo; enddo; enddo + call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyBegin(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyEnd(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! applying boundary conditions + rows = [0, 1, 2] + diag = (C_volAvg(1,1,1,1)/delta(1)**2.0_pReal + & + C_volAvg(2,2,2,2)/delta(2)**2.0_pReal + & + C_volAvg(3,3,3,3)/delta(3)**2.0_pReal)*detJ + call MatZeroRowsColumns(Jac,size(rows),rows,diag,PETSC_NULL_VEC,PETSC_NULL_VEC,ierr) + CHKERRQ(ierr) + call DMGetGlobalVector(da_local,coordinates,ierr);CHKERRQ(ierr) + call DMDAVecGetArrayF90(da_local,coordinates,x_scal,ierr);CHKERRQ(ierr) + ele = 0 + do k = zstart, zend; do j = ystart, yend; do i = xstart, xend + ele = ele + 1 + x_scal(0:2,i,j,k) = mesh_ipCoordinates(1:3,1,ele) + enddo; enddo; enddo + call DMDAVecRestoreArrayF90(da_local,coordinates,x_scal,ierr);CHKERRQ(ierr) ! initialize to undeformed coordinates (ToDo: use ip coordinates) + call MatNullSpaceCreateRigidBody(coordinates,matnull,ierr);CHKERRQ(ierr) ! get rigid body deformation modes + call DMRestoreGlobalVector(da_local,coordinates,ierr);CHKERRQ(ierr) + call MatSetNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) + call MatSetNearNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) + call MatNullSpaceDestroy(matnull,ierr); CHKERRQ(ierr) + +end subroutine formJacobian + +end module grid_mech_FEM diff --git a/src/grid_mech_spectral_basic.f90 b/src/grid/grid_mech_spectral_basic.f90 similarity index 88% rename from src/grid_mech_spectral_basic.f90 rename to src/grid/grid_mech_spectral_basic.f90 index 99839e50f..2daebefbd 100644 --- a/src/grid_mech_spectral_basic.f90 +++ b/src/grid/grid_mech_spectral_basic.f90 @@ -7,6 +7,8 @@ module grid_mech_spectral_basic #include #include + use DAMASK_interface + use HDF5_utilities use PETScdmda use PETScsnes use prec, only: & @@ -25,8 +27,7 @@ module grid_mech_spectral_basic type(tSolutionParams), private :: params type, private :: tNumerics - logical :: & - update_gamma !< update gamma operator with current stiffness + logical :: update_gamma !< update gamma operator with current stiffness end type tNumerics type(tNumerics) :: num ! numerics parameters. Better name? @@ -40,8 +41,8 @@ module grid_mech_spectral_basic !-------------------------------------------------------------------------------------------------- ! common pointwise data real(pReal), private, dimension(:,:,:,:,:), allocatable :: & - F_lastInc, & - Fdot + F_lastInc, & !< field of previous compatible deformation gradients + Fdot !< field of assumed rate of compatible deformation gradient !-------------------------------------------------------------------------------------------------- ! stress, stiffness and compliance average etc. @@ -99,23 +100,22 @@ subroutine grid_mech_spectral_basic_init use spectral_utilities, only: & utilities_constitutiveResponse, & utilities_updateGamma, & - utilities_updateIPcoords, & - wgt + utilities_updateIPcoords use mesh, only: & grid, & grid3 use math, only: & math_invSym3333 - implicit none real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P real(pReal), dimension(3,3) :: & temp33_Real = 0.0_pReal PetscErrorCode :: ierr PetscScalar, pointer, dimension(:,:,:,:) :: & - F ! pointer to solution data + F ! pointer to solution data PetscInt, dimension(worldsize) :: localK + integer(HID_T) :: fileHandle integer :: fileUnit character(len=1024) :: rankStr @@ -163,7 +163,7 @@ subroutine grid_mech_spectral_basic_init call DMcreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 9, i.e. every def grad tensor) call DMDASNESsetFunctionLocal(da,INSERT_VALUES,formResidual,PETSC_NULL_SNES,ierr) ! residual vector of same shape as solution vector CHKERRQ(ierr) - call SNESsetConvergenceTest(snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr)! specify custom convergence check function "converged" + call SNESsetConvergenceTest(snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "converged" CHKERRQ(ierr) call SNESsetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional CLI arguments @@ -174,19 +174,14 @@ subroutine grid_mech_spectral_basic_init restart: if (restartInc > 0) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading values of increment ', restartInc, ' from file' - fileUnit = IO_open_jobFile_binary('F_aim') - read(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc') - read(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot') - read(fileUnit) F_aimDot; close(fileUnit) - write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr)) - read(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr)) - read(fileUnit) F_lastInc; close (fileUnit) + call HDF5_read(fileHandle,F_aim, 'F_aim') + call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') + call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_read(fileHandle,F, 'F') + call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') elseif (restartInc == 0) then restart F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity @@ -203,15 +198,15 @@ subroutine grid_mech_spectral_basic_init restartRead: if (restartInc > 0) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading more values of increment ', restartInc, ' from file' - fileUnit = IO_open_jobFile_binary('C_volAvg') - read(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') - read(fileUnit) C_volAvgLastInc; close(fileUnit) + call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_closeFile(fileHandle) + fileUnit = IO_open_jobFile_binary('C_ref') read(fileUnit) C_minMaxAvg; close(fileUnit) endif restartRead - call Utilities_updateGamma(C_minMaxAvg,.true.) + call utilities_updateGamma(C_minMaxAvg,.true.) end subroutine grid_mech_spectral_basic_init @@ -228,8 +223,6 @@ function grid_mech_spectral_basic_solution(incInfoIn,timeinc,timeinc_old,stress_ restartWrite, & terminallyIll - implicit none - !-------------------------------------------------------------------------------------------------- ! input data for solution character(len=*), intent(in) :: & @@ -251,8 +244,8 @@ function grid_mech_spectral_basic_solution(incInfoIn,timeinc,timeinc_old,stress_ !-------------------------------------------------------------------------------------------------- ! update stiffness (and gamma operator) - S = Utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) - if (num%update_gamma) call Utilities_updateGamma(C_minMaxAvg,restartWrite) + S = utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) + if (num%update_gamma) call utilities_updateGamma(C_minMaxAvg,restartWrite) !-------------------------------------------------------------------------------------------------- ! set module wide available data @@ -306,7 +299,6 @@ subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTi use FEsolving, only: & restartWrite - implicit none logical, intent(in) :: & guess real(pReal), intent(in) :: & @@ -321,7 +313,7 @@ subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTi PetscErrorCode :: ierr PetscScalar, dimension(:,:,:,:), pointer :: F - integer :: fileUnit + integer(HID_T) :: fileHandle character(len=32) :: rankStr call DMDAVecGetArrayF90(da,solution_vec,F,ierr); CHKERRQ(ierr) @@ -331,29 +323,24 @@ subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTi C_minMaxAvg = C_minMaxAvgLastInc ! QUESTION: where is this required? else !-------------------------------------------------------------------------------------------------- - ! restart information for spectral solver - if (restartWrite) then ! QUESTION: where is this logical properly set? - write(6,'(/,a)') ' writing converged results for restart' - flush(6) - - if (worldrank == 0) then - fileUnit = IO_open_jobFile_binary('C_volAvg','w') - write(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') - write(fileUnit) C_volAvgLastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim','w') - write(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') - write(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot','w') - write(fileUnit) F_aimDot; close(fileUnit) - endif - + ! restart information for spectral solver + if (restartWrite) then + write(6,'(/,a)') ' writing converged results for restart';flush(6) + write(rankStr,'(a1,i0)')'_',worldrank - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr),'w') - write(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr),'w') - write(fileUnit) F_lastInc; close (fileUnit) + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') + + call HDF5_write(fileHandle,F_aim, 'F_aim') + call HDF5_write(fileHandle,F_aim_lastInc,'F_aim_lastInc') + call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_write(fileHandle,F, 'F') + call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') + + call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_write(fileHandle,C_minMaxAvg, 'C_minMaxAvg') + + call HDF5_closeFile(fileHandle) endif call CPFEM_age ! age state and kinematics @@ -399,7 +386,7 @@ end subroutine grid_mech_spectral_basic_forward !-------------------------------------------------------------------------------------------------- !> @brief convergence check !-------------------------------------------------------------------------------------------------- -subroutine converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) +subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dummy,ierr) use numerics, only: & itmax, & itmin, & @@ -410,13 +397,12 @@ subroutine converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) use FEsolving, only: & terminallyIll - implicit none SNES :: snes_local - PetscInt :: PETScIter - PetscReal :: & - xnorm, & ! not used - snorm, & ! not used - fnorm ! not used + PetscInt, intent(in) :: PETScIter + PetscReal, intent(in) :: & + devNull1, & + devNull2, & + devNull3 SNESConvergedReason :: reason PetscObject :: dummy PetscErrorCode :: ierr @@ -452,7 +438,7 @@ end subroutine converged !-------------------------------------------------------------------------------------------------- -!> @brief forms the basic residual vector +!> @brief forms the residual vector !-------------------------------------------------------------------------------------------------- subroutine formResidual(in, F, & residuum, dummy, ierr) @@ -481,7 +467,6 @@ subroutine formResidual(in, F, & use FEsolving, only: & terminallyIll - implicit none DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: in !< DMDA info (needs to be named "in" for macros like XRANGE to work) PetscScalar, dimension(3,3,XG_RANGE,YG_RANGE,ZG_RANGE), & intent(in) :: F !< deformation gradient field @@ -515,7 +500,7 @@ subroutine formResidual(in, F, & !-------------------------------------------------------------------------------------------------- ! evaluate constitutive response - call Utilities_constitutiveResponse(residuum, & ! "residuum" gets field of first PK stress (to save memory) + call utilities_constitutiveResponse(residuum, & ! "residuum" gets field of first PK stress (to save memory) P_av,C_volAvg,C_minMaxAvg, & F,params%timeinc,params%rotation_BC) call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) diff --git a/src/grid/grid_mech_spectral_polarisation.f90 b/src/grid/grid_mech_spectral_polarisation.f90 new file mode 100644 index 000000000..3bd30a360 --- /dev/null +++ b/src/grid/grid_mech_spectral_polarisation.f90 @@ -0,0 +1,640 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Grid solver for mechanics: Spectral Polarisation +!-------------------------------------------------------------------------------------------------- +module grid_mech_spectral_polarisation +#include +#include + use DAMASK_interface + use HDF5_utilities + use PETScdmda + use PETScsnes + use prec, only: & + pReal + use math, only: & + math_I3 + use spectral_utilities, only: & + tSolutionState, & + tSolutionParams + + implicit none + private + +!-------------------------------------------------------------------------------------------------- +! derived types + type(tSolutionParams), private :: params + + type, private :: tNumerics + logical :: update_gamma !< update gamma operator with current stiffness + end type tNumerics + + type(tNumerics) :: num ! numerics parameters. Better name? + +!-------------------------------------------------------------------------------------------------- +! PETSc data + DM, private :: da + SNES, private :: snes + Vec, private :: solution_vec + +!-------------------------------------------------------------------------------------------------- +! common pointwise data + real(pReal), private, dimension(:,:,:,:,:), allocatable :: & + F_lastInc, & !< field of previous compatible deformation gradients + F_tau_lastInc, & !< field of previous incompatible deformation gradient + Fdot, & !< field of assumed rate of compatible deformation gradient + F_tauDot !< field of assumed rate of incopatible deformation gradient + +!-------------------------------------------------------------------------------------------------- +! stress, stiffness and compliance average etc. + real(pReal), private, dimension(3,3) :: & + F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient + F_aim = math_I3, & !< current prescribed deformation gradient + F_aim_lastInc = math_I3, & !< previous average deformation gradient + F_av = 0.0_pReal, & !< average incompatible def grad field + P_av = 0.0_pReal !< average 1st Piola--Kirchhoff stress + + character(len=1024), private :: incInfo !< time and increment information + real(pReal), private, dimension(3,3,3,3) :: & + C_volAvg = 0.0_pReal, & !< current volume average stiffness + C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness + C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness + C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness + S = 0.0_pReal, & !< current compliance (filled up with zeros) + C_scale = 0.0_pReal, & + S_scale = 0.0_pReal + + real(pReal), private :: & + err_BC, & !< deviation from stress BC + err_curl, & !< RMS of curl of F + err_div !< RMS of div of P + + integer, private :: & + totalIter = 0 !< total iteration in current increment + + public :: & + grid_mech_spectral_polarisation_init, & + grid_mech_spectral_polarisation_solution, & + grid_mech_spectral_polarisation_forward + private :: & + converged, & + formResidual + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all necessary fields and fills them with data, potentially from restart info +!-------------------------------------------------------------------------------------------------- +subroutine grid_mech_spectral_polarisation_init + use IO, only: & + IO_intOut, & + IO_error, & + IO_open_jobFile_binary + use FEsolving, only: & + restartInc + use config, only :& + config_numerics + use numerics, only: & + worldrank, & + worldsize, & + petsc_options + use homogenization, only: & + materialpoint_F0 + use DAMASK_interface, only: & + getSolverJobName + use spectral_utilities, only: & + utilities_constitutiveResponse, & + utilities_updateGamma, & + utilities_updateIPcoords + use mesh, only: & + grid, & + grid3 + use math, only: & + math_invSym3333 + + real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P + real(pReal), dimension(3,3) :: & + temp33_Real = 0.0_pReal + + PetscErrorCode :: ierr + PetscScalar, pointer, dimension(:,:,:,:) :: & + FandF_tau, & ! overall pointer to solution data + F, & ! specific (sub)pointer + F_tau ! specific (sub)pointer + PetscInt, dimension(worldsize) :: localK + integer(HID_T) :: fileHandle + integer :: fileUnit + character(len=1024) :: rankStr + + write(6,'(/,a)') ' <<<+- grid_mech_spectral_polarisation init -+>>>' + + write(6,'(/,a)') ' Shanthraj et al., International Journal of Plasticity 66:31–45, 2015' + write(6,'(a)') ' https://doi.org/10.1016/j.ijplas.2014.02.006' + + num%update_gamma = config_numerics%getInt('update_gamma',defaultVal=0) > 0 + +!-------------------------------------------------------------------------------------------------- +! set default and user defined options for PETSc + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,'-mech_snes_type ngmres',ierr) + CHKERRQ(ierr) + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) + CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! allocate global fields + allocate(F_lastInc (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(Fdot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(F_tau_lastInc(3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(F_tauDot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + +!-------------------------------------------------------------------------------------------------- +! initialize solver specific parts of PETSc + call SNESCreate(PETSC_COMM_WORLD,snes,ierr); CHKERRQ(ierr) + call SNESSetOptionsPrefix(snes,'mech_',ierr);CHKERRQ(ierr) + localK = 0 + localK(worldrank+1) = grid3 + call MPI_Allreduce(MPI_IN_PLACE,localK,worldsize,MPI_INTEGER,MPI_SUM,PETSC_COMM_WORLD,ierr) + call DMDACreate3d(PETSC_COMM_WORLD, & + DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary + DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point + grid(1),grid(2),grid(3), & ! global grid + 1 , 1, worldsize, & + 18, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) + [grid(1)],[grid(2)],localK, & ! local grid + da,ierr) ! handle, error + CHKERRQ(ierr) + call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) ! connect snes to da + call DMsetFromOptions(da,ierr); CHKERRQ(ierr) + call DMsetUp(da,ierr); CHKERRQ(ierr) + call DMcreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 18, i.e. every def grad tensor) + call DMDASNESsetFunctionLocal(da,INSERT_VALUES,formResidual,PETSC_NULL_SNES,ierr) ! residual vector of same shape as solution vector + CHKERRQ(ierr) + call SNESsetConvergenceTest(snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "converged" + CHKERRQ(ierr) + call SNESsetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional CLI arguments + +!-------------------------------------------------------------------------------------------------- +! init fields + call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) ! places pointer on PETSc data + F => FandF_tau( 0: 8,:,:,:) + F_tau => FandF_tau( 9:17,:,:,:) + + restart: if (restartInc > 0) then + write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading values of increment ', restartInc, ' from file' + + write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') + + call HDF5_read(fileHandle,F_aim, 'F_aim') + call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') + call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_read(fileHandle,F, 'F') + call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_read(fileHandle,F_tau, 'F_tau') + call HDF5_read(fileHandle,F_tau_lastInc,'F_tau_lastInc') + + elseif (restartInc == 0) then restart + F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity + F = reshape(F_lastInc,[9,grid(1),grid(2),grid3]) + F_tau = 2.0_pReal*F + F_tau_lastInc = 2.0_pReal*F_lastInc + endif restart + + materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent + call Utilities_updateIPcoords(reshape(F,shape(F_lastInc))) + call Utilities_constitutiveResponse(P,temp33_Real,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2 + reshape(F,shape(F_lastInc)), & ! target F + 0.0_pReal, & ! time increment + math_I3) ! no rotation of boundary condition + call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) ! deassociate pointer + + restartRead: if (restartInc > 0) then + write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading more values of increment ', restartInc, ' from file' + call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_closeFile(fileHandle) + + fileUnit = IO_open_jobFile_binary('C_ref') + read(fileUnit) C_minMaxAvg; close(fileUnit) + endif restartRead + + call utilities_updateGamma(C_minMaxAvg,.true.) + C_scale = C_minMaxAvg + S_scale = math_invSym3333(C_minMaxAvg) + +end subroutine grid_mech_spectral_polarisation_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief solution for the Polarisation scheme with internal iterations +!-------------------------------------------------------------------------------------------------- +function grid_mech_spectral_polarisation_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation_BC) result(solution) + use math, only: & + math_invSym3333 + use spectral_utilities, only: & + tBoundaryCondition, & + utilities_maskedCompliance, & + utilities_updateGamma + use FEsolving, only: & + restartWrite, & + terminallyIll + +!-------------------------------------------------------------------------------------------------- +! input data for solution + character(len=*), intent(in) :: & + incInfoIn + real(pReal), intent(in) :: & + timeinc, & !< time increment of current solution + timeinc_old !< time increment of last successful increment + type(tBoundaryCondition), intent(in) :: & + stress_BC + real(pReal), dimension(3,3), intent(in) :: rotation_BC + type(tSolutionState) :: & + solution +!-------------------------------------------------------------------------------------------------- +! PETSc Data + PetscErrorCode :: ierr + SNESConvergedReason :: reason + + incInfo = incInfoIn + +!-------------------------------------------------------------------------------------------------- +! update stiffness (and gamma operator) + S = utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) + if (num%update_gamma) then + call utilities_updateGamma(C_minMaxAvg,restartWrite) + C_scale = C_minMaxAvg + S_scale = math_invSym3333(C_minMaxAvg) + endif + +!-------------------------------------------------------------------------------------------------- +! set module wide available data + params%stress_mask = stress_BC%maskFloat + params%stress_BC = stress_BC%values + params%rotation_BC = rotation_BC + params%timeinc = timeinc + params%timeincOld = timeinc_old + +!-------------------------------------------------------------------------------------------------- +! solve BVP + call SNESsolve(snes,PETSC_NULL_VEC,solution_vec,ierr); CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! check convergence + call SNESGetConvergedReason(snes,reason,ierr); CHKERRQ(ierr) + + solution%converged = reason > 0 + solution%iterationsNeeded = totalIter + solution%termIll = terminallyIll + terminallyIll = .false. + +end function grid_mech_spectral_polarisation_solution + + +!-------------------------------------------------------------------------------------------------- +!> @brief forwarding routine +!> @details find new boundary conditions and best F estimate for end of current timestep +!> possibly writing restart information, triggering of state increment in DAMASK, and updating of IPcoordinates +!-------------------------------------------------------------------------------------------------- +subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) + use math, only: & + math_mul3333xx33, & + math_rotate_backward33 + use numerics, only: & + worldrank + use homogenization, only: & + materialpoint_F0 + use mesh, only: & + grid, & + grid3 + use CPFEM2, only: & + CPFEM_age + use spectral_utilities, only: & + utilities_calculateRate, & + utilities_forwardField, & + utilities_updateIPcoords, & + tBoundaryCondition, & + cutBack + use IO, only: & + IO_open_jobFile_binary + use FEsolving, only: & + restartWrite + + logical, intent(in) :: & + guess + real(pReal), intent(in) :: & + timeinc_old, & + timeinc, & + loadCaseTime !< remaining time of current load case + type(tBoundaryCondition), intent(in) :: & + stress_BC, & + deformation_BC + real(pReal), dimension(3,3), intent(in) ::& + rotation_BC + PetscErrorCode :: ierr + PetscScalar, dimension(:,:,:,:), pointer :: FandF_tau, F, F_tau + integer :: i, j, k + real(pReal), dimension(3,3) :: F_lambda33 + + integer(HID_T) :: fileHandle + character(len=32) :: rankStr + + call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) + F => FandF_tau( 0: 8,:,:,:) + F_tau => FandF_tau( 9:17,:,:,:) + + if (cutBack) then + C_volAvg = C_volAvgLastInc ! QUESTION: where is this required? + C_minMaxAvg = C_minMaxAvgLastInc ! QUESTION: where is this required? + else + !-------------------------------------------------------------------------------------------------- + ! restart information for spectral solver + if (restartWrite) then + write(6,'(/,a)') ' writing converged results for restart';flush(6) + + write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') + + call HDF5_write(fileHandle,F_aim, 'F_aim') + call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') + call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_write(fileHandle,F, 'F') + call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_write(fileHandle,F_tau, 'F_tau') + call HDF5_write(fileHandle,F_tau_lastInc, 'F_tau_lastInc') + + call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + + call HDF5_closeFile(fileHandle) + endif + + call CPFEM_age ! age state and kinematics + call utilities_updateIPcoords(F) + + C_volAvgLastInc = C_volAvg + C_minMaxAvgLastInc = C_minMaxAvg + + F_aimDot = merge(stress_BC%maskFloat*(F_aim-F_aim_lastInc)/timeinc_old, 0.0_pReal, guess) + F_aim_lastInc = F_aim + + !-------------------------------------------------------------------------------------------------- + ! calculate rate for aim + if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F + F_aimDot = & + F_aimDot + deformation_BC%maskFloat * matmul(deformation_BC%values, F_aim_lastInc) + elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed + F_aimDot = & + F_aimDot + deformation_BC%maskFloat * deformation_BC%values + elseif (deformation_BC%myType=='f') then ! aim at end of load case is prescribed + F_aimDot = & + F_aimDot + deformation_BC%maskFloat * (deformation_BC%values - F_aim_lastInc)/loadCaseTime + endif + + + Fdot = utilities_calculateRate(guess, & + F_lastInc,reshape(F,[3,3,grid(1),grid(2),grid3]),timeinc_old, & + math_rotate_backward33(F_aimDot,rotation_BC)) + F_tauDot = utilities_calculateRate(guess, & + F_tau_lastInc,reshape(F_tau,[3,3,grid(1),grid(2),grid3]), timeinc_old, & + math_rotate_backward33(F_aimDot,rotation_BC)) + F_lastInc = reshape(F, [3,3,grid(1),grid(2),grid3]) ! winding F forward + F_tau_lastInc = reshape(F_tau, [3,3,grid(1),grid(2),grid3]) ! winding F_tau forward + materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent + endif + +!-------------------------------------------------------------------------------------------------- +! update average and local deformation gradients + F_aim = F_aim_lastInc + F_aimDot * timeinc + F = reshape(utilities_forwardField(timeinc,F_lastInc,Fdot, & ! estimate of F at end of time+timeinc that matches rotated F_aim on average + math_rotate_backward33(F_aim,rotation_BC)),& + [9,grid(1),grid(2),grid3]) + if (guess) then + F_tau = reshape(Utilities_forwardField(timeinc,F_tau_lastInc,F_taudot), & + [9,grid(1),grid(2),grid3]) ! does not have any average value as boundary condition + else + do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) + F_lambda33 = reshape(F_tau(1:9,i,j,k)-F(1:9,i,j,k),[3,3]) + F_lambda33 = math_mul3333xx33(S_scale,matmul(F_lambda33, & + math_mul3333xx33(C_scale,& + matmul(transpose(F_lambda33),& + F_lambda33)-math_I3))*0.5_pReal)& + + math_I3 + F_tau(1:9,i,j,k) = reshape(F_lambda33,[9])+F(1:9,i,j,k) + enddo; enddo; enddo + endif + + call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) + +end subroutine grid_mech_spectral_polarisation_forward + + +!-------------------------------------------------------------------------------------------------- +!> @brief convergence check +!-------------------------------------------------------------------------------------------------- +subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dummy,ierr) + use numerics, only: & + itmax, & + itmin, & + err_div_tolRel, & + err_div_tolAbs, & + err_curl_tolRel, & + err_curl_tolAbs, & + err_stress_tolRel, & + err_stress_tolAbs + use FEsolving, only: & + terminallyIll + + SNES :: snes_local + PetscInt, intent(in) :: PETScIter + PetscReal, intent(in) :: & + devNull1, & + devNull2, & + devNull3 + SNESConvergedReason :: reason + PetscObject :: dummy + PetscErrorCode :: ierr + real(pReal) :: & + curlTol, & + divTol, & + BCTol + + curlTol = max(maxval(abs(F_aim-math_I3))*err_curl_tolRel ,err_curl_tolAbs) + divTol = max(maxval(abs(P_av)) *err_div_tolRel ,err_div_tolAbs) + BCTol = max(maxval(abs(P_av)) *err_stress_tolRel,err_stress_tolAbs) + + if ((totalIter >= itmin .and. & + all([ err_div /divTol, & + err_curl/curlTol, & + err_BC /BCTol ] < 1.0_pReal)) & + .or. terminallyIll) then + reason = 1 + elseif (totalIter >= itmax) then + reason = -1 + else + reason = 0 + endif + +!-------------------------------------------------------------------------------------------------- +! report + write(6,'(1/,a)') ' ... reporting .............................................................' + write(6,'(1/,a,f12.2,a,es8.2,a,es9.2,a)') ' error divergence = ', & + err_div/divTol, ' (',err_div, ' / m, tol = ',divTol,')' + write(6, '(a,f12.2,a,es8.2,a,es9.2,a)') ' error curl = ', & + err_curl/curlTol,' (',err_curl,' -, tol = ',curlTol,')' + write(6, '(a,f12.2,a,es8.2,a,es9.2,a)') ' error BC = ', & + err_BC/BCTol, ' (',err_BC, ' Pa, tol = ',BCTol,')' + write(6,'(/,a)') ' ===========================================================================' + flush(6) + +end subroutine converged + + +!-------------------------------------------------------------------------------------------------- +!> @brief forms the residual vector +!-------------------------------------------------------------------------------------------------- +subroutine formResidual(in, FandF_tau, & + residuum, dummy,ierr) + use numerics, only: & + itmax, & + itmin, & + polarAlpha, & + polarBeta + use mesh, only: & + grid, & + grid3 + use math, only: & + math_rotate_forward33, & + math_rotate_backward33, & + math_mul3333xx33, & + math_invSym3333 + use debug, only: & + debug_level, & + debug_spectral, & + debug_spectralRotation + use spectral_utilities, only: & + wgt, & + tensorField_real, & + utilities_FFTtensorForward, & + utilities_fourierGammaConvolution, & + utilities_FFTtensorBackward, & + utilities_constitutiveResponse, & + utilities_divergenceRMS, & + utilities_curlRMS + use IO, only: & + IO_intOut + use homogenization, only: & + materialpoint_dPdF + use FEsolving, only: & + terminallyIll + + DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: in !< DMDA info (needs to be named "in" for macros like XRANGE to work) + PetscScalar, dimension(3,3,2,XG_RANGE,YG_RANGE,ZG_RANGE), & + target, intent(in) :: FandF_tau + PetscScalar, dimension(3,3,2,X_RANGE,Y_RANGE,Z_RANGE),& + target, intent(out) :: residuum !< residuum field + PetscScalar, pointer, dimension(:,:,:,:,:) :: & + F, & + F_tau, & + residual_F, & + residual_F_tau + PetscInt :: & + PETScIter, & + nfuncs + PetscObject :: dummy + PetscErrorCode :: ierr + integer :: & + i, j, k, e + + F => FandF_tau(1:3,1:3,1,& + XG_RANGE,YG_RANGE,ZG_RANGE) + F_tau => FandF_tau(1:3,1:3,2,& + XG_RANGE,YG_RANGE,ZG_RANGE) + residual_F => residuum(1:3,1:3,1,& + X_RANGE, Y_RANGE, Z_RANGE) + residual_F_tau => residuum(1:3,1:3,2,& + X_RANGE, Y_RANGE, Z_RANGE) + + F_av = sum(sum(sum(F,dim=5),dim=4),dim=3) * wgt + call MPI_Allreduce(MPI_IN_PLACE,F_av,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + + call SNESGetNumberFunctionEvals(snes,nfuncs,ierr); CHKERRQ(ierr) + call SNESGetIterationNumber(snes,PETScIter,ierr); CHKERRQ(ierr) + + if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1 ! new increment +!-------------------------------------------------------------------------------------------------- +! begin of new iteration + newIteration: if (totalIter <= PETScIter) then + totalIter = totalIter + 1 + write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') & + trim(incInfo), ' @ Iteration ', itmin, '≤',totalIter, '≤', itmax + if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & + ' deformation gradient aim (lab) =', transpose(math_rotate_backward33(F_aim,params%rotation_BC)) + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & + ' deformation gradient aim =', transpose(F_aim) + flush(6) + endif newIteration + +!-------------------------------------------------------------------------------------------------- +! + tensorField_real = 0.0_pReal + do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) + tensorField_real(1:3,1:3,i,j,k) = & + polarBeta*math_mul3333xx33(C_scale,F(1:3,1:3,i,j,k) - math_I3) -& + polarAlpha*matmul(F(1:3,1:3,i,j,k), & + math_mul3333xx33(C_scale,F_tau(1:3,1:3,i,j,k) - F(1:3,1:3,i,j,k) - math_I3)) + enddo; enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! doing convolution in Fourier space + call utilities_FFTtensorForward + call utilities_fourierGammaConvolution(math_rotate_backward33(polarBeta*F_aim,params%rotation_BC)) + call utilities_FFTtensorBackward + +!-------------------------------------------------------------------------------------------------- +! constructing residual + residual_F_tau = polarBeta*F - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) + +!-------------------------------------------------------------------------------------------------- +! evaluate constitutive response + call utilities_constitutiveResponse(residual_F, & ! "residuum" gets field of first PK stress (to save memory) + P_av,C_volAvg,C_minMaxAvg, & + F - residual_F_tau/polarBeta,params%timeinc,params%rotation_BC) + call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) + +!-------------------------------------------------------------------------------------------------- +! stress BC handling + F_aim = F_aim - math_mul3333xx33(S, ((P_av - params%stress_BC))) ! S = 0.0 for no bc + err_BC = maxval(abs((1.0_pReal-params%stress_mask) * math_mul3333xx33(C_scale,F_aim & + -math_rotate_forward33(F_av,params%rotation_BC)) + & + params%stress_mask * (P_av-params%stress_BC))) ! mask = 0.0 for no bc +! calculate divergence + tensorField_real = 0.0_pReal + tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = residual_F !< stress field in disguise + call utilities_FFTtensorForward + err_div = Utilities_divergenceRMS() !< root mean squared error in divergence of stress + +!-------------------------------------------------------------------------------------------------- +! constructing residual + e = 0 + do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) + e = e + 1 + residual_F(1:3,1:3,i,j,k) = & + math_mul3333xx33(math_invSym3333(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,e) + C_scale), & + residual_F(1:3,1:3,i,j,k) - matmul(F(1:3,1:3,i,j,k), & + math_mul3333xx33(C_scale,F_tau(1:3,1:3,i,j,k) - F(1:3,1:3,i,j,k) - math_I3))) & + + residual_F_tau(1:3,1:3,i,j,k) + enddo; enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! calculating curl + tensorField_real = 0.0_pReal + tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = F + call utilities_FFTtensorForward + err_curl = Utilities_curlRMS() + +end subroutine formResidual + +end module grid_mech_spectral_polarisation diff --git a/src/grid_thermal_spectral.f90 b/src/grid/grid_thermal_spectral.f90 similarity index 99% rename from src/grid_thermal_spectral.f90 rename to src/grid/grid_thermal_spectral.f90 index 31740feb9..e899fd89a 100644 --- a/src/grid_thermal_spectral.f90 +++ b/src/grid/grid_thermal_spectral.f90 @@ -69,7 +69,6 @@ subroutine grid_thermal_spectral_init worldsize, & petsc_options - implicit none PetscInt, dimension(worldsize) :: localK integer :: i, j, k, cell DM :: thermal_grid @@ -167,7 +166,6 @@ function grid_thermal_spectral_solution(timeinc,timeinc_old,loadCaseTime) result use thermal_conduction, only: & thermal_conduction_putTemperatureAndItsRate - implicit none real(pReal), intent(in) :: & timeinc, & !< increment in time for current solution timeinc_old, & !< increment in time of last increment @@ -242,7 +240,6 @@ subroutine grid_thermal_spectral_forward thermal_conduction_getMassDensity, & thermal_conduction_getSpecificHeat - implicit none integer :: i, j, k, cell DM :: dm_local PetscScalar, dimension(:,:,:), pointer :: x_scal @@ -311,7 +308,6 @@ subroutine formResidual(in,x_scal,f_scal,dummy,ierr) thermal_conduction_getMassDensity, & thermal_conduction_getSpecificHeat - implicit none DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & in PetscScalar, dimension( & diff --git a/src/spectral_utilities.f90 b/src/grid/spectral_utilities.f90 similarity index 100% rename from src/spectral_utilities.f90 rename to src/grid/spectral_utilities.f90 diff --git a/src/grid_mech_FEM.f90 b/src/grid_mech_FEM.f90 deleted file mode 100644 index e31d93637..000000000 --- a/src/grid_mech_FEM.f90 +++ /dev/null @@ -1,736 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Arko Jyoti Bhattacharjee, Max-Planck-Institut für Eisenforschung GmbH -!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @brief Grid solver for mechanics: FEM -!-------------------------------------------------------------------------------------------------- -module grid_mech_FEM -#include -#include - use PETScdmda - use PETScsnes - use prec, only: & - pInt, & - pReal - use math, only: & - math_I3 - use spectral_utilities, only: & - tSolutionState, & - tSolutionParams - - implicit none - private - -!-------------------------------------------------------------------------------------------------- -! derived types - type(tSolutionParams), private :: params - -!-------------------------------------------------------------------------------------------------- -! PETSc data - DM, private :: mech_grid - SNES, private :: mech_snes - Vec, private :: solution_current, solution_lastInc, solution_rate - -!-------------------------------------------------------------------------------------------------- -! common pointwise data - real(pReal), private, dimension(:,:,:,:,:), allocatable :: F, P_current, F_lastInc - real(pReal), private :: detJ - real(pReal), private, dimension(3) :: delta - real(pReal), private, dimension(3,8) :: BMat - real(pReal), private, dimension(8,8) :: HGMat - PetscInt, private :: xstart,ystart,zstart,xend,yend,zend - -!-------------------------------------------------------------------------------------------------- -! stress, stiffness and compliance average etc. - real(pReal), private, dimension(3,3) :: & - F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient - F_aim = math_I3, & !< current prescribed deformation gradient - F_aim_lastIter = math_I3, & - F_aim_lastInc = math_I3, & !< previous average deformation gradient - P_av = 0.0_pReal !< average 1st Piola--Kirchhoff stress - - character(len=1024), private :: incInfo !< time and increment information - - real(pReal), private, dimension(3,3,3,3) :: & - C_volAvg = 0.0_pReal, & !< current volume average stiffness - C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness - S = 0.0_pReal !< current compliance (filled up with zeros) - - real(pReal), private :: & - err_BC !< deviation from stress BC - - integer(pInt), private :: & - totalIter = 0_pInt !< total iteration in current increment - - public :: & - grid_mech_FEM_init, & - grid_mech_FEM_solution, & - grid_mech_FEM_forward - -contains - -!-------------------------------------------------------------------------------------------------- -!> @brief allocates all necessary fields and fills them with data, potentially from restart info -!-------------------------------------------------------------------------------------------------- -subroutine grid_mech_FEM_init - use IO, only: & - IO_intOut, & - IO_error, & - IO_open_jobFile_binary - use FEsolving, only: & - restartInc - use numerics, only: & - worldrank, & - worldsize, & - petsc_options - use homogenization, only: & - materialpoint_F0 - use DAMASK_interface, only: & - getSolverJobName - use spectral_utilities, only: & - utilities_constitutiveResponse, & - utilities_updateIPcoords, & - wgt - use mesh, only: & - geomSize, & - grid, & - grid3 - use math, only: & - math_invSym3333 - - implicit none - real(pReal) :: HGCoeff = 0e-2_pReal - PetscInt, dimension(:), allocatable :: localK - real(pReal), dimension(3,3) :: & - temp33_Real = 0.0_pReal - real(pReal), dimension(4,8) :: & - HGcomp = reshape([ 1.0_pReal, 1.0_pReal, 1.0_pReal,-1.0_pReal, & - 1.0_pReal,-1.0_pReal,-1.0_pReal, 1.0_pReal, & - -1.0_pReal, 1.0_pReal,-1.0_pReal, 1.0_pReal, & - -1.0_pReal,-1.0_pReal, 1.0_pReal,-1.0_pReal, & - -1.0_pReal,-1.0_pReal, 1.0_pReal, 1.0_pReal, & - -1.0_pReal, 1.0_pReal,-1.0_pReal,-1.0_pReal, & - 1.0_pReal,-1.0_pReal,-1.0_pReal,-1.0_pReal, & - 1.0_pReal, 1.0_pReal, 1.0_pReal, 1.0_pReal], [4,8]) - PetscErrorCode :: ierr - integer(pInt) :: rank - integer :: fileUnit - character(len=1024) :: rankStr - real(pReal), dimension(3,3,3,3) :: devNull - PetscScalar, pointer, dimension(:,:,:,:) :: & - u_current,u_lastInc - - write(6,'(/,a)') ' <<<+- grid_mech_FEM init -+>>>' - -!-------------------------------------------------------------------------------------------------- -! set default and user defined options for PETSc - call PETScOptionsInsertString(PETSC_NULL_OPTIONS,'-mech_snes_type newtonls -mech_ksp_type fgmres & - &-mech_ksp_max_it 25 -mech_pc_type ml -mech_mg_levels_ksp_type chebyshev',ierr) - CHKERRQ(ierr) - call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) - CHKERRQ(ierr) - -!-------------------------------------------------------------------------------------------------- -! allocate global fields - allocate (F (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (P_current (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (F_lastInc (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - -!-------------------------------------------------------------------------------------------------- -! initialize solver specific parts of PETSc - call SNESCreate(PETSC_COMM_WORLD,mech_snes,ierr); CHKERRQ(ierr) - call SNESSetOptionsPrefix(mech_snes,'mech_',ierr);CHKERRQ(ierr) - allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 - do rank = 1, worldsize - call MPI_Bcast(localK(rank),1,MPI_INTEGER,rank-1,PETSC_COMM_WORLD,ierr) - enddo - call DMDACreate3d(PETSC_COMM_WORLD, & - DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, & - DMDA_STENCIL_BOX, & - grid(1),grid(2),grid(3), & - 1, 1, worldsize, & - 3, 1, & - [grid(1)],[grid(2)],localK, & - mech_grid,ierr) - CHKERRQ(ierr) - call DMDASetUniformCoordinates(mech_grid,0.0_pReal,geomSize(1),0.0_pReal,geomSize(2),0.0_pReal,geomSize(3),ierr) - CHKERRQ(ierr) - call SNESSetDM(mech_snes,mech_grid,ierr); CHKERRQ(ierr) - call DMsetFromOptions(mech_grid,ierr); CHKERRQ(ierr) - call DMsetUp(mech_grid,ierr); CHKERRQ(ierr) - call DMCreateGlobalVector(mech_grid,solution_current,ierr); CHKERRQ(ierr) - call DMCreateGlobalVector(mech_grid,solution_lastInc,ierr); CHKERRQ(ierr) - call DMCreateGlobalVector(mech_grid,solution_rate ,ierr); CHKERRQ(ierr) - call DMSNESSetFunctionLocal(mech_grid,formResidual,PETSC_NULL_SNES,ierr) - CHKERRQ(ierr) - call DMSNESSetJacobianLocal(mech_grid,formJacobian,PETSC_NULL_SNES,ierr) - CHKERRQ(ierr) - call SNESSetConvergenceTest(mech_snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) - CHKERRQ(ierr) ! specify custom convergence check function "_converged" - call SNESSetMaxLinearSolveFailures(mech_snes, huge(1), ierr); CHKERRQ(ierr) ! ignore linear solve failures - call SNESSetFromOptions(mech_snes,ierr); CHKERRQ(ierr) ! pull it all together with additional cli arguments - -!-------------------------------------------------------------------------------------------------- -! init fields - call VecSet(solution_current,0.0_pReal,ierr);CHKERRQ(ierr) - call VecSet(solution_lastInc,0.0_pReal,ierr);CHKERRQ(ierr) - call VecSet(solution_rate ,0.0_pReal,ierr);CHKERRQ(ierr) - call DMDAVecGetArrayF90(mech_grid,solution_current,u_current,ierr); CHKERRQ(ierr) - call DMDAVecGetArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr); CHKERRQ(ierr) - - call DMDAGetCorners(mech_grid,xstart,ystart,zstart,xend,yend,zend,ierr) ! local grid extent - CHKERRQ(ierr) - xend = xstart+xend-1 - yend = ystart+yend-1 - zend = zstart+zend-1 - delta = geomSize/real(grid,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 - - HGMat = matmul(transpose(HGcomp),HGcomp) & - * HGCoeff*(delta(1)*delta(2) + delta(2)*delta(3) + delta(3)*delta(1))/16.0_pReal ! hourglass stabilization matrix - -!-------------------------------------------------------------------------------------------------- -! init fields - restart: if (restartInc > 0) then - write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading values of increment ', restartInc, ' from file' - - fileUnit = IO_open_jobFile_binary('F_aim') - read(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc') - read(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot') - read(fileUnit) F_aimDot; close(fileUnit) - - write(rankStr,'(a1,i0)')'_',worldrank - - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr)) - read(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr)) - read(fileUnit) F_lastInc; close (fileUnit) - fileUnit = IO_open_jobFile_binary('u'//trim(rankStr)) - read(fileUnit) u_current; close (fileUnit) - fileUnit = IO_open_jobFile_binary('u_lastInc'//trim(rankStr)) - read(fileUnit) u_lastInc; close (fileUnit) - - elseif (restartInc == 0) then restart - F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity - F = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) - endif restart - materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent - call Utilities_updateIPcoords(F) - call Utilities_constitutiveResponse(P_current,temp33_Real,C_volAvg,devNull, & ! stress field, stress avg, global average of stiffness and (min+max)/2 - F, & ! target F - 0.0_pReal, & ! time increment - math_I3) ! no rotation of boundary condition - call DMDAVecRestoreArrayF90(mech_grid,solution_current,u_current,ierr) - CHKERRQ(ierr) - call DMDAVecRestoreArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr) - CHKERRQ(ierr) - - restartRead: if (restartInc > 0_pInt) then - write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading more values of increment ', restartInc, ' from file' - fileUnit = IO_open_jobFile_binary('C_volAvg') - read(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') - read(fileUnit) C_volAvgLastInc; close(fileUnit) - endif restartRead - -end subroutine grid_mech_FEM_init - - -!-------------------------------------------------------------------------------------------------- -!> @brief solution for the FEM scheme with internal iterations -!-------------------------------------------------------------------------------------------------- -function grid_mech_FEM_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation_BC) result(solution) - use IO, only: & - IO_error - use spectral_utilities, only: & - tBoundaryCondition, & - utilities_maskedCompliance - use FEsolving, only: & - restartWrite, & - terminallyIll - - implicit none - -!-------------------------------------------------------------------------------------------------- -! input data for solution - character(len=*), intent(in) :: & - incInfoIn - real(pReal), intent(in) :: & - timeinc, & !< time increment of current solution - timeinc_old !< time increment of last successful increment - type(tBoundaryCondition), intent(in) :: & - stress_BC - real(pReal), dimension(3,3), intent(in) :: rotation_BC - type(tSolutionState) :: & - solution - -!-------------------------------------------------------------------------------------------------- -! PETSc Data - PetscErrorCode :: ierr - SNESConvergedReason :: reason - - incInfo = incInfoIn - -!-------------------------------------------------------------------------------------------------- -! update stiffness (and gamma operator) - S = Utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) -!-------------------------------------------------------------------------------------------------- -! set module wide available data - params%stress_mask = stress_BC%maskFloat - params%stress_BC = stress_BC%values - params%rotation_BC = rotation_BC - params%timeinc = timeinc - params%timeincOld = timeinc_old - -!-------------------------------------------------------------------------------------------------- -! solve BVP - call SNESsolve(mech_snes,PETSC_NULL_VEC,solution_current,ierr);CHKERRQ(ierr) - -!-------------------------------------------------------------------------------------------------- -! check convergence - call SNESGetConvergedReason(mech_snes,reason,ierr);CHKERRQ(ierr) - - solution%converged = reason > 0 - solution%iterationsNeeded = totalIter - solution%termIll = terminallyIll - terminallyIll = .false. - -end function grid_mech_FEM_solution - - -!-------------------------------------------------------------------------------------------------- -!> @brief forwarding routine -!> @details find new boundary conditions and best F estimate for end of current timestep -!> possibly writing restart information, triggering of state increment in DAMASK, and updating of IPcoordinates -!-------------------------------------------------------------------------------------------------- -subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) - use math, only: & - math_rotate_backward33 - use numerics, only: & - worldrank - use homogenization, only: & - materialpoint_F0 - use mesh, only: & - grid, & - grid3 - use CPFEM2, only: & - CPFEM_age - use spectral_utilities, only: & - utilities_updateIPcoords, & - tBoundaryCondition, & - cutBack - use IO, only: & - IO_open_jobFile_binary - use FEsolving, only: & - restartWrite - - implicit none - logical, intent(in) :: & - guess - real(pReal), intent(in) :: & - timeinc_old, & - timeinc, & - loadCaseTime !< remaining time of current load case - type(tBoundaryCondition), intent(in) :: & - stress_BC, & - deformation_BC - real(pReal), dimension(3,3), intent(in) :: & - rotation_BC - PetscErrorCode :: ierr - integer :: fileUnit - character(len=32) :: rankStr - PetscScalar, pointer, dimension(:,:,:,:) :: & - u_current,u_lastInc - - call DMDAVecGetArrayF90(mech_grid,solution_current,u_current,ierr); CHKERRQ(ierr) - call DMDAVecGetArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr); CHKERRQ(ierr) - - if (cutBack) then - C_volAvg = C_volAvgLastInc ! QUESTION: where is this required? - else - !-------------------------------------------------------------------------------------------------- - ! restart information for spectral solver - if (restartWrite) then ! QUESTION: where is this logical properly set? - write(6,'(/,a)') ' writing converged results for restart' - flush(6) - - if (worldrank == 0) then - fileUnit = IO_open_jobFile_binary('C_volAvg','w') - write(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') - write(fileUnit) C_volAvgLastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim','w') - write(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') - write(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot','w') - write(fileUnit) F_aimDot; close(fileUnit) - endif - - write(rankStr,'(a1,i0)')'_',worldrank - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr),'w') - write(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr),'w') - write(fileUnit) F_lastInc; close (fileUnit) - fileUnit = IO_open_jobFile_binary('u'//trim(rankStr),'w') - write(fileUnit) u_current; close (fileUnit) - fileUnit = IO_open_jobFile_binary('u_lastInc'//trim(rankStr),'w') - write(fileUnit) u_lastInc; close (fileUnit) - - endif - call CPFEM_age() ! age state and kinematics - call utilities_updateIPcoords(F) - - C_volAvgLastInc = C_volAvg - - F_aimDot = merge(stress_BC%maskFloat*(F_aim-F_aim_lastInc)/timeinc_old, 0.0_pReal, guess) - F_aim_lastInc = F_aim - - !-------------------------------------------------------------------------------------------------- - ! calculate rate for aim - if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F - F_aimDot = & - F_aimDot + deformation_BC%maskFloat * matmul(deformation_BC%values, F_aim_lastInc) - elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed - F_aimDot = & - F_aimDot + deformation_BC%maskFloat * deformation_BC%values - elseif (deformation_BC%myType=='f') then ! aim at end of load case is prescribed - F_aimDot = & - F_aimDot + deformation_BC%maskFloat * (deformation_BC%values - F_aim_lastInc)/loadCaseTime - endif - - - if (guess) then - call VecWAXPY(solution_rate,-1.0_pReal,solution_lastInc,solution_current,ierr) - CHKERRQ(ierr) - call VecScale(solution_rate,1.0_pReal/timeinc_old,ierr); CHKERRQ(ierr) - else - call VecSet(solution_rate,0.0_pReal,ierr); CHKERRQ(ierr) - endif - call VecCopy(solution_current,solution_lastInc,ierr); CHKERRQ(ierr) - - F_lastInc = F ! winding F forward - materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent - - endif - -!-------------------------------------------------------------------------------------------------- -! update average and local deformation gradients - F_aim = F_aim_lastInc + F_aimDot * timeinc - call VecAXPY(solution_current,timeinc,solution_rate,ierr); CHKERRQ(ierr) - - call DMDAVecRestoreArrayF90(mech_grid,solution_current,u_current,ierr) - CHKERRQ(ierr) - call DMDAVecRestoreArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr) - CHKERRQ(ierr) - -end subroutine grid_mech_FEM_forward - - -!-------------------------------------------------------------------------------------------------- -!> @brief convergence check -!-------------------------------------------------------------------------------------------------- -subroutine converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) -use mesh -use spectral_utilities - use numerics, only: & - itmax, & - itmin, & - err_div_tolRel, & - err_div_tolAbs, & - err_stress_tolRel, & - err_stress_tolAbs - use FEsolving, only: & - terminallyIll - - implicit none - SNES :: snes_local - PetscInt :: PETScIter - PetscReal :: & - xnorm, & ! not used - snorm, & ! not used - fnorm - SNESConvergedReason :: reason - PetscObject :: dummy - PetscErrorCode :: ierr - real(pReal) :: & - err_div, & - divTol, & - BCTol - - err_div = fnorm*sqrt(wgt)*geomSize(1)/scaledGeomSize(1)/detJ - divTol = max(maxval(abs(P_av))*err_div_tolRel ,err_div_tolAbs) - BCTol = max(maxval(abs(P_av))*err_stress_tolRel,err_stress_tolAbs) - - - if ((totalIter >= itmin .and. & - all([ err_div/divTol, & - err_BC /BCTol ] < 1.0_pReal)) & - .or. terminallyIll) then - reason = 1 - elseif (totalIter >= itmax) then - reason = -1 - else - reason = 0 - endif - -!-------------------------------------------------------------------------------------------------- -! report - write(6,'(1/,a)') ' ... reporting .............................................................' - write(6,'(1/,a,f12.2,a,es8.2,a,es9.2,a)') ' error divergence = ', & - err_div/divTol, ' (',err_div,' / m, tol = ',divTol,')' - write(6,'(a,f12.2,a,es8.2,a,es9.2,a)') ' error stress BC = ', & - err_BC/BCTol, ' (',err_BC, ' Pa, tol = ',BCTol,')' - write(6,'(/,a)') ' ===========================================================================' - flush(6) - -end subroutine converged - - -!-------------------------------------------------------------------------------------------------- -!> @brief forms the residual vector -!-------------------------------------------------------------------------------------------------- -subroutine formResidual(da_local,x_local,f_local,dummy,ierr) - use numerics, only: & - itmax, & - itmin - use numerics, only: & - worldrank - use mesh, only: & - grid - use math, only: & - math_rotate_backward33, & - math_mul3333xx33 - use debug, only: & - debug_level, & - debug_spectral, & - debug_spectralRotation - use spectral_utilities, only: & - utilities_constitutiveResponse - use IO, only: & - IO_intOut - use FEsolving, only: & - terminallyIll - use homogenization, only: & - materialpoint_dPdF - - implicit none - DM :: da_local - Vec :: x_local, f_local - PetscScalar, pointer,dimension(:,:,:,:) :: x_scal, f_scal - PetscScalar, dimension(8,3) :: x_elem, f_elem - PetscInt :: i, ii, j, jj, k, kk, ctr, ele - real(pReal), dimension(3,3) :: & - deltaF_aim - PetscInt :: & - PETScIter, & - nfuncs - PetscObject :: dummy - PetscErrorCode :: ierr - real(pReal), dimension(3,3,3,3) :: devNull - - - call SNESGetNumberFunctionEvals(mech_snes,nfuncs,ierr); CHKERRQ(ierr) - call SNESGetIterationNumber(mech_snes,PETScIter,ierr); CHKERRQ(ierr) - - if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1_pInt ! new increment - -!-------------------------------------------------------------------------------------------------- -! begin of new iteration - newIteration: if (totalIter <= PETScIter) then - totalIter = totalIter + 1_pInt - write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') & - trim(incInfo), ' @ Iteration ', itmin, '≤',totalIter+1, '≤', itmax - if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & - write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & - ' deformation gradient aim (lab) =', transpose(math_rotate_backward33(F_aim,params%rotation_BC)) - write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & - ' deformation gradient aim =', transpose(F_aim) - flush(6) - endif newIteration - -!-------------------------------------------------------------------------------------------------- -! get deformation gradient - call DMDAVecGetArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) - do k = zstart, zend; do j = ystart, yend; do i = xstart, xend - ctr = 0 - do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 - ctr = ctr + 1 - x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) - enddo; enddo; enddo - ii = i-xstart+1; jj = j-ystart+1; kk = k-zstart+1 - F(1:3,1:3,ii,jj,kk) = math_rotate_backward33(F_aim,params%rotation_BC) + transpose(matmul(BMat,x_elem)) - enddo; enddo; enddo - call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) - -!-------------------------------------------------------------------------------------------------- -! evaluate constitutive response - call Utilities_constitutiveResponse(P_current,& - P_av,C_volAvg,devNull, & - F,params%timeinc,params%rotation_BC) - call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) - -!-------------------------------------------------------------------------------------------------- -! stress BC handling - F_aim_lastIter = F_aim - deltaF_aim = math_mul3333xx33(S, P_av - params%stress_BC) - F_aim = F_aim - deltaF_aim - err_BC = maxval(abs(params%stress_mask * (P_av - params%stress_BC))) ! mask = 0.0 when no stress bc - -!-------------------------------------------------------------------------------------------------- -! constructing residual - call VecSet(f_local,0.0_pReal,ierr);CHKERRQ(ierr) - call DMDAVecGetArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) - call DMDAVecGetArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) - ele = 0 - do k = zstart, zend; do j = ystart, yend; do i = xstart, xend - ctr = 0 - do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 - ctr = ctr + 1 - x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) - enddo; enddo; enddo - ii = i-xstart+1; jj = j-ystart+1; kk = k-zstart+1 - ele = ele + 1 - f_elem = matmul(transpose(BMat),transpose(P_current(1:3,1:3,ii,jj,kk)))*detJ + & - matmul(HGMat,x_elem)*(materialpoint_dPdF(1,1,1,1,1,ele) + & - materialpoint_dPdF(2,2,2,2,1,ele) + & - materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal - ctr = 0 - do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 - ctr = ctr + 1 - f_scal(0:2,i+ii,j+jj,k+kk) = f_scal(0:2,i+ii,j+jj,k+kk) + f_elem(ctr,1:3) - enddo; enddo; enddo - enddo; enddo; enddo - call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) - call DMDAVecRestoreArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) - -!-------------------------------------------------------------------------------------------------- -! applying boundary conditions - call DMDAVecGetArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) - if (zstart == 0) then - f_scal(0:2,xstart,ystart,zstart) = 0.0 - f_scal(0:2,xend+1,ystart,zstart) = 0.0 - f_scal(0:2,xstart,yend+1,zstart) = 0.0 - f_scal(0:2,xend+1,yend+1,zstart) = 0.0 - endif - if (zend + 1 == grid(3)) then - f_scal(0:2,xstart,ystart,zend+1) = 0.0 - f_scal(0:2,xend+1,ystart,zend+1) = 0.0 - f_scal(0:2,xstart,yend+1,zend+1) = 0.0 - f_scal(0:2,xend+1,yend+1,zend+1) = 0.0 - endif - call DMDAVecRestoreArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) - -end subroutine formResidual - - -!-------------------------------------------------------------------------------------------------- -!> @brief forms the FEM stiffness matrix -!-------------------------------------------------------------------------------------------------- -subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,ierr) - use mesh, only: & - mesh_ipCoordinates - use homogenization, only: & - materialpoint_dPdF - - implicit none - - DM :: da_local - Vec :: x_local, coordinates - Mat :: Jac_pre, Jac - MatStencil,dimension(4,24) :: row, col - PetscScalar,pointer,dimension(:,:,:,:) :: x_scal - PetscScalar,dimension(24,24) :: K_ele - PetscScalar,dimension(9,24) :: BMatFull - PetscInt :: i, ii, j, jj, k, kk, ctr, ele - PetscInt,dimension(3) :: rows - PetscScalar :: diag - PetscObject :: dummy - MatNullSpace :: matnull - PetscErrorCode :: ierr - - BMatFull = 0.0 - BMatFull(1:3,1 :8 ) = BMat - BMatFull(4:6,9 :16) = BMat - BMatFull(7:9,17:24) = BMat - call MatSetOption(Jac,MAT_KEEP_NONZERO_PATTERN,PETSC_TRUE,ierr); CHKERRQ(ierr) - call MatSetOption(Jac,MAT_NEW_NONZERO_ALLOCATION_ERR,PETSC_FALSE,ierr); CHKERRQ(ierr) - call MatZeroEntries(Jac,ierr); CHKERRQ(ierr) - ele = 0 - do k = zstart, zend; do j = ystart, yend; do i = xstart, xend - ctr = 0 - do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 - ctr = ctr + 1 - col(MatStencil_i,ctr ) = i+ii - col(MatStencil_j,ctr ) = j+jj - col(MatStencil_k,ctr ) = k+kk - col(MatStencil_c,ctr ) = 0 - col(MatStencil_i,ctr+8 ) = i+ii - col(MatStencil_j,ctr+8 ) = j+jj - col(MatStencil_k,ctr+8 ) = k+kk - col(MatStencil_c,ctr+8 ) = 1 - col(MatStencil_i,ctr+16) = i+ii - col(MatStencil_j,ctr+16) = j+jj - col(MatStencil_k,ctr+16) = k+kk - col(MatStencil_c,ctr+16) = 2 - enddo; enddo; enddo - row = col - ele = ele + 1 - K_ele = 0.0 - K_ele(1 :8 ,1 :8 ) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & - materialpoint_dPdF(2,2,2,2,1,ele) + & - materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal - K_ele(9 :16,9 :16) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & - materialpoint_dPdF(2,2,2,2,1,ele) + & - materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal - K_ele(17:24,17:24) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & - materialpoint_dPdF(2,2,2,2,1,ele) + & - materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal - K_ele = K_ele + & - matmul(transpose(BMatFull), & - matmul(reshape(reshape(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,ele), & - shape=[3,3,3,3], order=[2,1,4,3]),shape=[9,9]),BMatFull))*detJ - call MatSetValuesStencil(Jac,24,row,24,col,K_ele,ADD_VALUES,ierr) - CHKERRQ(ierr) - enddo; enddo; enddo - call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - call MatAssemblyBegin(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - call MatAssemblyEnd(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - -!-------------------------------------------------------------------------------------------------- -! applying boundary conditions - rows = [0, 1, 2] - diag = (C_volAvg(1,1,1,1)/delta(1)**2.0_pReal + & - C_volAvg(2,2,2,2)/delta(2)**2.0_pReal + & - C_volAvg(3,3,3,3)/delta(3)**2.0_pReal)*detJ - call MatZeroRowsColumns(Jac,size(rows),rows,diag,PETSC_NULL_VEC,PETSC_NULL_VEC,ierr) - CHKERRQ(ierr) - call DMGetGlobalVector(da_local,coordinates,ierr);CHKERRQ(ierr) - call DMDAVecGetArrayF90(da_local,coordinates,x_scal,ierr);CHKERRQ(ierr) - ele = 0 - do k = zstart, zend; do j = ystart, yend; do i = xstart, xend - ele = ele + 1 - x_scal(0:2,i,j,k) = mesh_ipCoordinates(1:3,1,ele) - enddo; enddo; enddo - call DMDAVecRestoreArrayF90(da_local,coordinates,x_scal,ierr);CHKERRQ(ierr) ! initialize to undeformed coordinates (ToDo: use ip coordinates) - call MatNullSpaceCreateRigidBody(coordinates,matnull,ierr);CHKERRQ(ierr) ! get rigid body deformation modes - call DMRestoreGlobalVector(da_local,coordinates,ierr);CHKERRQ(ierr) - call MatSetNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) - call MatSetNearNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) - call MatNullSpaceDestroy(matnull,ierr); CHKERRQ(ierr) - -end subroutine formJacobian - -end module grid_mech_FEM diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 deleted file mode 100644 index aff4913b1..000000000 --- a/src/grid_mech_spectral_polarisation.f90 +++ /dev/null @@ -1,659 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH -!> @brief Grid solver for mechanics: Spectral Polarisation -!-------------------------------------------------------------------------------------------------- -module grid_mech_spectral_polarisation -#include -#include - use PETScdmda - use PETScsnes - use prec, only: & - pReal - use math, only: & - math_I3 - use spectral_utilities, only: & - tSolutionState, & - tSolutionParams - - implicit none - private - -!-------------------------------------------------------------------------------------------------- -! derived types - type(tSolutionParams), private :: params - - type, private :: tNumerics - logical :: & - update_gamma !< update gamma operator with current stiffness - end type tNumerics - - type(tNumerics) :: num ! numerics parameters. Better name? - -!-------------------------------------------------------------------------------------------------- -! PETSc data - DM, private :: da - SNES, private :: snes - Vec, private :: solution_vec - -!-------------------------------------------------------------------------------------------------- -! common pointwise data - real(pReal), private, dimension(:,:,:,:,:), allocatable :: & - F_lastInc, & !< field of previous compatible deformation gradients - F_tau_lastInc, & !< field of previous incompatible deformation gradient - Fdot, & !< field of assumed rate of compatible deformation gradient - F_tauDot !< field of assumed rate of incopatible deformation gradient - -!-------------------------------------------------------------------------------------------------- -! stress, stiffness and compliance average etc. - real(pReal), private, dimension(3,3) :: & - F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient - F_aim = math_I3, & !< current prescribed deformation gradient - F_aim_lastInc = math_I3, & !< previous average deformation gradient - F_av = 0.0_pReal, & !< average incompatible def grad field - P_av = 0.0_pReal !< average 1st Piola--Kirchhoff stress - - character(len=1024), private :: incInfo !< time and increment information - real(pReal), private, dimension(3,3,3,3) :: & - C_volAvg = 0.0_pReal, & !< current volume average stiffness - C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness - C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness - C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness - S = 0.0_pReal, & !< current compliance (filled up with zeros) - C_scale = 0.0_pReal, & - S_scale = 0.0_pReal - - real(pReal), private :: & - err_BC, & !< deviation from stress BC - err_curl, & !< RMS of curl of F - err_div !< RMS of div of P - - integer, private :: & - totalIter = 0 !< total iteration in current increment - - public :: & - grid_mech_spectral_polarisation_init, & - grid_mech_spectral_polarisation_solution, & - grid_mech_spectral_polarisation_forward - private :: & - converged, & - formResidual - -contains - -!-------------------------------------------------------------------------------------------------- -!> @brief allocates all necessary fields and fills them with data, potentially from restart info -!-------------------------------------------------------------------------------------------------- -subroutine grid_mech_spectral_polarisation_init - use IO, only: & - IO_intOut, & - IO_error, & - IO_open_jobFile_binary - use FEsolving, only: & - restartInc - use config, only :& - config_numerics - use numerics, only: & - worldrank, & - worldsize, & - petsc_options - use homogenization, only: & - materialpoint_F0 - use DAMASK_interface, only: & - getSolverJobName - use spectral_utilities, only: & - utilities_constitutiveResponse, & - utilities_updateGamma, & - utilities_updateIPcoords, & - wgt - use mesh, only: & - grid, & - grid3 - use math, only: & - math_invSym3333 - - implicit none - real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P - real(pReal), dimension(3,3) :: & - temp33_Real = 0.0_pReal - - PetscErrorCode :: ierr - PetscScalar, pointer, dimension(:,:,:,:) :: & - FandF_tau, & ! overall pointer to solution data - F, & ! specific (sub)pointer - F_tau ! specific (sub)pointer - PetscInt, dimension(worldsize) :: localK - integer :: fileUnit - character(len=1024) :: rankStr - - write(6,'(/,a)') ' <<<+- grid_mech_spectral_polarisation init -+>>>' - - write(6,'(/,a)') ' Shanthraj et al., International Journal of Plasticity 66:31–45, 2015' - write(6,'(a)') ' https://doi.org/10.1016/j.ijplas.2014.02.006' - - num%update_gamma = config_numerics%getInt('update_gamma',defaultVal=0) > 0 - -!-------------------------------------------------------------------------------------------------- -! set default and user defined options for PETSc - call PETScOptionsInsertString(PETSC_NULL_OPTIONS,'-mech_snes_type ngmres',ierr) - CHKERRQ(ierr) - call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) - CHKERRQ(ierr) - -!-------------------------------------------------------------------------------------------------- -! allocate global fields - allocate (F_lastInc (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (Fdot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (F_tau_lastInc(3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (F_tauDot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - -!-------------------------------------------------------------------------------------------------- -! initialize solver specific parts of PETSc - call SNESCreate(PETSC_COMM_WORLD,snes,ierr); CHKERRQ(ierr) - call SNESSetOptionsPrefix(snes,'mech_',ierr);CHKERRQ(ierr) - localK = 0 - localK(worldrank+1) = grid3 - call MPI_Allreduce(MPI_IN_PLACE,localK,worldsize,MPI_INTEGER,MPI_SUM,PETSC_COMM_WORLD,ierr) - call DMDACreate3d(PETSC_COMM_WORLD, & - DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary - DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point - grid(1),grid(2),grid(3), & ! global grid - 1 , 1, worldsize, & - 18, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) - [grid(1)],[grid(2)],localK, & ! local grid - da,ierr) ! handle, error - CHKERRQ(ierr) - call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) ! connect snes to da - call DMsetFromOptions(da,ierr); CHKERRQ(ierr) - call DMsetUp(da,ierr); CHKERRQ(ierr) - call DMcreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 18, i.e. every def grad tensor) - call DMDASNESsetFunctionLocal(da,INSERT_VALUES,formResidual,PETSC_NULL_SNES,ierr) ! residual vector of same shape as solution vector - CHKERRQ(ierr) - call SNESsetConvergenceTest(snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "converged" - CHKERRQ(ierr) - call SNESsetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional CLI arguments - -!-------------------------------------------------------------------------------------------------- -! init fields - call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) ! places pointer on PETSc data - F => FandF_tau( 0: 8,:,:,:) - F_tau => FandF_tau( 9:17,:,:,:) - - restart: if (restartInc > 0) then - write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading values of increment ', restartInc, ' from file' - - fileUnit = IO_open_jobFile_binary('F_aim') - read(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc') - read(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot') - read(fileUnit) F_aimDot; close(fileUnit) - - write(rankStr,'(a1,i0)')'_',worldrank - - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr)) - read(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr)) - read(fileUnit) F_lastInc; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_tau'//trim(rankStr)) - read(fileUnit) F_tau; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_tau_lastInc'//trim(rankStr)) - read(fileUnit) F_tau_lastInc; close (fileUnit) - - elseif (restartInc == 0) then restart - F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity - F = reshape(F_lastInc,[9,grid(1),grid(2),grid3]) - F_tau = 2.0_pReal*F - F_tau_lastInc = 2.0_pReal*F_lastInc - endif restart - - materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent - call Utilities_updateIPcoords(reshape(F,shape(F_lastInc))) - call Utilities_constitutiveResponse(P,temp33_Real,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2 - reshape(F,shape(F_lastInc)), & ! target F - 0.0_pReal, & ! time increment - math_I3) ! no rotation of boundary condition - call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) ! deassociate pointer - - restartRead: if (restartInc > 0) then - write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading more values of increment ', restartInc, ' from file' - fileUnit = IO_open_jobFile_binary('C_volAvg') - read(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') - read(fileUnit) C_volAvgLastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_ref') - read(fileUnit) C_minMaxAvg; close(fileUnit) - endif restartRead - - call Utilities_updateGamma(C_minMaxAvg,.true.) - C_scale = C_minMaxAvg - S_scale = math_invSym3333(C_minMaxAvg) - -end subroutine grid_mech_spectral_polarisation_init - - -!-------------------------------------------------------------------------------------------------- -!> @brief solution for the Polarisation scheme with internal iterations -!-------------------------------------------------------------------------------------------------- -function grid_mech_spectral_polarisation_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation_BC) result(solution) - use math, only: & - math_invSym3333 - use spectral_utilities, only: & - tBoundaryCondition, & - utilities_maskedCompliance, & - utilities_updateGamma - use FEsolving, only: & - restartWrite, & - terminallyIll - - implicit none - -!-------------------------------------------------------------------------------------------------- -! input data for solution - character(len=*), intent(in) :: & - incInfoIn - real(pReal), intent(in) :: & - timeinc, & !< time increment of current solution - timeinc_old !< time increment of last successful increment - type(tBoundaryCondition), intent(in) :: & - stress_BC - real(pReal), dimension(3,3), intent(in) :: rotation_BC - type(tSolutionState) :: & - solution -!-------------------------------------------------------------------------------------------------- -! PETSc Data - PetscErrorCode :: ierr - SNESConvergedReason :: reason - - incInfo = incInfoIn - -!-------------------------------------------------------------------------------------------------- -! update stiffness (and gamma operator) - S = Utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) - if (num%update_gamma) then - call utilities_updateGamma(C_minMaxAvg,restartWrite) - C_scale = C_minMaxAvg - S_scale = math_invSym3333(C_minMaxAvg) - endif - -!-------------------------------------------------------------------------------------------------- -! set module wide available data - params%stress_mask = stress_BC%maskFloat - params%stress_BC = stress_BC%values - params%rotation_BC = rotation_BC - params%timeinc = timeinc - params%timeincOld = timeinc_old - -!-------------------------------------------------------------------------------------------------- -! solve BVP - call SNESsolve(snes,PETSC_NULL_VEC,solution_vec,ierr); CHKERRQ(ierr) - -!-------------------------------------------------------------------------------------------------- -! check convergence - call SNESGetConvergedReason(snes,reason,ierr); CHKERRQ(ierr) - - solution%converged = reason > 0 - solution%iterationsNeeded = totalIter - solution%termIll = terminallyIll - terminallyIll = .false. - -end function grid_mech_spectral_polarisation_solution - - -!-------------------------------------------------------------------------------------------------- -!> @brief forwarding routine -!> @details find new boundary conditions and best F estimate for end of current timestep -!> possibly writing restart information, triggering of state increment in DAMASK, and updating of IPcoordinates -!-------------------------------------------------------------------------------------------------- -subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) - use math, only: & - math_mul3333xx33, & - math_rotate_backward33 - use numerics, only: & - worldrank - use homogenization, only: & - materialpoint_F0 - use mesh, only: & - grid, & - grid3 - use CPFEM2, only: & - CPFEM_age - use spectral_utilities, only: & - utilities_calculateRate, & - utilities_forwardField, & - utilities_updateIPcoords, & - tBoundaryCondition, & - cutBack - use IO, only: & - IO_open_jobFile_binary - use FEsolving, only: & - restartWrite - - implicit none - logical, intent(in) :: & - guess - real(pReal), intent(in) :: & - timeinc_old, & - timeinc, & - loadCaseTime !< remaining time of current load case - type(tBoundaryCondition), intent(in) :: & - stress_BC, & - deformation_BC - real(pReal), dimension(3,3), intent(in) ::& - rotation_BC - PetscErrorCode :: ierr - PetscScalar, dimension(:,:,:,:), pointer :: FandF_tau, F, F_tau - integer :: i, j, k - real(pReal), dimension(3,3) :: F_lambda33 - - integer :: fileUnit - character(len=32) :: rankStr - - call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) - F => FandF_tau( 0: 8,:,:,:) - F_tau => FandF_tau( 9:17,:,:,:) - - if (cutBack) then - C_volAvg = C_volAvgLastInc ! QUESTION: where is this required? - C_minMaxAvg = C_minMaxAvgLastInc ! QUESTION: where is this required? - else - !-------------------------------------------------------------------------------------------------- - ! restart information for spectral solver - if (restartWrite) then ! QUESTION: where is this logical properly set? - write(6,'(/,a)') ' writing converged results for restart' - flush(6) - - if (worldrank == 0) then - fileUnit = IO_open_jobFile_binary('C_volAvg','w') - write(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') - write(fileUnit) C_volAvgLastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim','w') - write(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') - write(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot','w') - write(fileUnit) F_aimDot; close(fileUnit) - endif - - write(rankStr,'(a1,i0)')'_',worldrank - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr),'w') - write(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr),'w') - write(fileUnit) F_lastInc; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_tau'//trim(rankStr),'w') - write(fileUnit) F_tau; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_tau_lastInc'//trim(rankStr),'w') - write(fileUnit) F_tau_lastInc; close (fileUnit) - endif - - call CPFEM_age ! age state and kinematics - call utilities_updateIPcoords(F) - - C_volAvgLastInc = C_volAvg - C_minMaxAvgLastInc = C_minMaxAvg - - F_aimDot = merge(stress_BC%maskFloat*(F_aim-F_aim_lastInc)/timeinc_old, 0.0_pReal, guess) - F_aim_lastInc = F_aim - - !-------------------------------------------------------------------------------------------------- - ! calculate rate for aim - if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F - F_aimDot = & - F_aimDot + deformation_BC%maskFloat * matmul(deformation_BC%values, F_aim_lastInc) - elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed - F_aimDot = & - F_aimDot + deformation_BC%maskFloat * deformation_BC%values - elseif (deformation_BC%myType=='f') then ! aim at end of load case is prescribed - F_aimDot = & - F_aimDot + deformation_BC%maskFloat * (deformation_BC%values - F_aim_lastInc)/loadCaseTime - endif - - - Fdot = utilities_calculateRate(guess, & - F_lastInc,reshape(F,[3,3,grid(1),grid(2),grid3]),timeinc_old, & - math_rotate_backward33(F_aimDot,rotation_BC)) - F_tauDot = utilities_calculateRate(guess, & - F_tau_lastInc,reshape(F_tau,[3,3,grid(1),grid(2),grid3]), timeinc_old, & - math_rotate_backward33(F_aimDot,rotation_BC)) - F_lastInc = reshape(F, [3,3,grid(1),grid(2),grid3]) ! winding F forward - F_tau_lastInc = reshape(F_tau, [3,3,grid(1),grid(2),grid3]) ! winding F_tau forward - materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent - endif - -!-------------------------------------------------------------------------------------------------- -! update average and local deformation gradients - F_aim = F_aim_lastInc + F_aimDot * timeinc - F = reshape(utilities_forwardField(timeinc,F_lastInc,Fdot, & ! estimate of F at end of time+timeinc that matches rotated F_aim on average - math_rotate_backward33(F_aim,rotation_BC)),& - [9,grid(1),grid(2),grid3]) - if (guess) then - F_tau = reshape(Utilities_forwardField(timeinc,F_tau_lastInc,F_taudot), & - [9,grid(1),grid(2),grid3]) ! does not have any average value as boundary condition - else - do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) - F_lambda33 = reshape(F_tau(1:9,i,j,k)-F(1:9,i,j,k),[3,3]) - F_lambda33 = math_mul3333xx33(S_scale,matmul(F_lambda33, & - math_mul3333xx33(C_scale,& - matmul(transpose(F_lambda33),& - F_lambda33)-math_I3))*0.5_pReal)& - + math_I3 - F_tau(1:9,i,j,k) = reshape(F_lambda33,[9])+F(1:9,i,j,k) - enddo; enddo; enddo - endif - - call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) - -end subroutine grid_mech_spectral_polarisation_forward - - -!-------------------------------------------------------------------------------------------------- -!> @brief convergence check -!-------------------------------------------------------------------------------------------------- -subroutine converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) - use numerics, only: & - itmax, & - itmin, & - err_div_tolRel, & - err_div_tolAbs, & - err_curl_tolRel, & - err_curl_tolAbs, & - err_stress_tolRel, & - err_stress_tolAbs - use FEsolving, only: & - terminallyIll - - implicit none - SNES :: snes_local - PetscInt :: PETScIter - PetscReal :: & - xnorm, & ! not used - snorm, & ! not used - fnorm ! not used - SNESConvergedReason :: reason - PetscObject :: dummy - PetscErrorCode :: ierr - real(pReal) :: & - curlTol, & - divTol, & - BCTol - - curlTol = max(maxval(abs(F_aim-math_I3))*err_curl_tolRel ,err_curl_tolAbs) - divTol = max(maxval(abs(P_av)) *err_div_tolRel ,err_div_tolAbs) - BCTol = max(maxval(abs(P_av)) *err_stress_tolRel,err_stress_tolAbs) - - if ((totalIter >= itmin .and. & - all([ err_div /divTol, & - err_curl/curlTol, & - err_BC /BCTol ] < 1.0_pReal)) & - .or. terminallyIll) then - reason = 1 - elseif (totalIter >= itmax) then - reason = -1 - else - reason = 0 - endif - -!-------------------------------------------------------------------------------------------------- -! report - write(6,'(1/,a)') ' ... reporting .............................................................' - write(6,'(1/,a,f12.2,a,es8.2,a,es9.2,a)') ' error divergence = ', & - err_div/divTol, ' (',err_div, ' / m, tol = ',divTol,')' - write(6, '(a,f12.2,a,es8.2,a,es9.2,a)') ' error curl = ', & - err_curl/curlTol,' (',err_curl,' -, tol = ',curlTol,')' - write(6, '(a,f12.2,a,es8.2,a,es9.2,a)') ' error BC = ', & - err_BC/BCTol, ' (',err_BC, ' Pa, tol = ',BCTol,')' - write(6,'(/,a)') ' ===========================================================================' - flush(6) - -end subroutine converged - - -!-------------------------------------------------------------------------------------------------- -!> @brief forms the polarisation residual vector -!-------------------------------------------------------------------------------------------------- -subroutine formResidual(in, FandF_tau, & - residuum, dummy,ierr) - use numerics, only: & - itmax, & - itmin, & - polarAlpha, & - polarBeta - use mesh, only: & - grid, & - grid3 - use math, only: & - math_rotate_forward33, & - math_rotate_backward33, & - math_mul3333xx33, & - math_invSym3333 - use debug, only: & - debug_level, & - debug_spectral, & - debug_spectralRotation - use spectral_utilities, only: & - wgt, & - tensorField_real, & - utilities_FFTtensorForward, & - utilities_fourierGammaConvolution, & - utilities_FFTtensorBackward, & - utilities_constitutiveResponse, & - utilities_divergenceRMS, & - utilities_curlRMS - use IO, only: & - IO_intOut - use homogenization, only: & - materialpoint_dPdF - use FEsolving, only: & - terminallyIll - - implicit none - DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: in !< DMDA info (needs to be named "in" for macros like XRANGE to work) - PetscScalar, dimension(3,3,2,XG_RANGE,YG_RANGE,ZG_RANGE), & - target, intent(in) :: FandF_tau - PetscScalar, dimension(3,3,2,X_RANGE,Y_RANGE,Z_RANGE),& - target, intent(out) :: residuum !< residuum field - PetscScalar, pointer, dimension(:,:,:,:,:) :: & - F, & - F_tau, & - residual_F, & - residual_F_tau - PetscInt :: & - PETScIter, & - nfuncs - PetscObject :: dummy - PetscErrorCode :: ierr - integer :: & - i, j, k, e - - F => FandF_tau(1:3,1:3,1,& - XG_RANGE,YG_RANGE,ZG_RANGE) - F_tau => FandF_tau(1:3,1:3,2,& - XG_RANGE,YG_RANGE,ZG_RANGE) - residual_F => residuum(1:3,1:3,1,& - X_RANGE, Y_RANGE, Z_RANGE) - residual_F_tau => residuum(1:3,1:3,2,& - X_RANGE, Y_RANGE, Z_RANGE) - - F_av = sum(sum(sum(F,dim=5),dim=4),dim=3) * wgt - call MPI_Allreduce(MPI_IN_PLACE,F_av,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) - - call SNESGetNumberFunctionEvals(snes,nfuncs,ierr); CHKERRQ(ierr) - call SNESGetIterationNumber(snes,PETScIter,ierr); CHKERRQ(ierr) - - if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1 ! new increment -!-------------------------------------------------------------------------------------------------- -! begin of new iteration - newIteration: if (totalIter <= PETScIter) then - totalIter = totalIter + 1 - write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') & - trim(incInfo), ' @ Iteration ', itmin, '≤',totalIter, '≤', itmax - if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & - write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & - ' deformation gradient aim (lab) =', transpose(math_rotate_backward33(F_aim,params%rotation_BC)) - write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & - ' deformation gradient aim =', transpose(F_aim) - flush(6) - endif newIteration - -!-------------------------------------------------------------------------------------------------- -! - tensorField_real = 0.0_pReal - do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) - tensorField_real(1:3,1:3,i,j,k) = & - polarBeta*math_mul3333xx33(C_scale,F(1:3,1:3,i,j,k) - math_I3) -& - polarAlpha*matmul(F(1:3,1:3,i,j,k), & - math_mul3333xx33(C_scale,F_tau(1:3,1:3,i,j,k) - F(1:3,1:3,i,j,k) - math_I3)) - enddo; enddo; enddo - -!-------------------------------------------------------------------------------------------------- -! doing convolution in Fourier space - call utilities_FFTtensorForward - call utilities_fourierGammaConvolution(math_rotate_backward33(polarBeta*F_aim,params%rotation_BC)) - call utilities_FFTtensorBackward - -!-------------------------------------------------------------------------------------------------- -! constructing residual - residual_F_tau = polarBeta*F - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) - -!-------------------------------------------------------------------------------------------------- -! evaluate constitutive response - call utilities_constitutiveResponse(residual_F, & ! "residuum" gets field of first PK stress (to save memory) - P_av,C_volAvg,C_minMaxAvg, & - F - residual_F_tau/polarBeta,params%timeinc,params%rotation_BC) - call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) - -!-------------------------------------------------------------------------------------------------- -! stress BC handling - F_aim = F_aim - math_mul3333xx33(S, ((P_av - params%stress_BC))) ! S = 0.0 for no bc - err_BC = maxval(abs((1.0_pReal-params%stress_mask) * math_mul3333xx33(C_scale,F_aim & - -math_rotate_forward33(F_av,params%rotation_BC)) + & - params%stress_mask * (P_av-params%stress_BC))) ! mask = 0.0 for no bc -! calculate divergence - tensorField_real = 0.0_pReal - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = residual_F !< stress field in disguise - call utilities_FFTtensorForward - err_div = Utilities_divergenceRMS() !< root mean squared error in divergence of stress -!-------------------------------------------------------------------------------------------------- -! constructing residual - e = 0 - do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) - e = e + 1 - residual_F(1:3,1:3,i,j,k) = & - math_mul3333xx33(math_invSym3333(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,e) + C_scale), & - residual_F(1:3,1:3,i,j,k) - matmul(F(1:3,1:3,i,j,k), & - math_mul3333xx33(C_scale,F_tau(1:3,1:3,i,j,k) - F(1:3,1:3,i,j,k) - math_I3))) & - + residual_F_tau(1:3,1:3,i,j,k) - enddo; enddo; enddo - -!-------------------------------------------------------------------------------------------------- -! calculating curl - tensorField_real = 0.0_pReal - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = F - call utilities_FFTtensorForward - err_curl = Utilities_curlRMS() - -end subroutine formResidual - -end module grid_mech_spectral_polarisation diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 06c8bd44c..06da6ab2e 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -6,7 +6,6 @@ !-------------------------------------------------------------------------------------------------- module homogenization use prec, only: & - pInt, & pReal !-------------------------------------------------------------------------------------------------- @@ -21,7 +20,7 @@ module homogenization materialpoint_dPdF !< tangent of first P--K stress at IP real(pReal), dimension(:,:,:), allocatable, public :: & materialpoint_results !< results array of material point - integer(pInt), public, protected :: & + integer, public, protected :: & materialpoint_sizeResults, & homogenization_maxSizePostResults, & thermal_maxSizePostResults, & @@ -39,6 +38,30 @@ module homogenization materialpoint_converged logical, dimension(:,:,:), allocatable, private :: & materialpoint_doneAndHappy + + interface + + module subroutine mech_none_init + end subroutine mech_none_init + + module subroutine mech_isostrain_init + end subroutine mech_isostrain_init + + module subroutine mech_isostrain_partitionDeformation(F,avgF) + real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient + real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point + end subroutine mech_isostrain_partitionDeformation + + module subroutine mech_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) + real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point + real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point + + real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses + real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses + integer, intent(in) :: instance + end subroutine mech_isostrain_averageStressAndItsTangent + + end interface public :: & homogenization_init, & @@ -78,9 +101,7 @@ subroutine homogenization_init config_homogenization, & homogenization_name use material - use homogenization_none - use homogenization_isostrain - use homogenization_RGC + use homogenization_mech_RGC use thermal_isothermal use thermal_adiabatic use thermal_conduction @@ -92,17 +113,17 @@ subroutine homogenization_init worldrank implicit none - integer(pInt), parameter :: FILEUNIT = 200_pInt - integer(pInt) :: e,i,p - integer(pInt), dimension(:,:), pointer :: thisSize - integer(pInt), dimension(:) , pointer :: thisNoutput + integer, parameter :: FILEUNIT = 200 + integer :: e,i,p + integer, dimension(:,:), pointer :: thisSize + integer, dimension(:) , pointer :: thisNoutput character(len=64), dimension(:,:), pointer :: thisOutput character(len=32) :: outputName !< name of output, intermediate fix until HDF5 output is ready logical :: valid - if (any(homogenization_type == HOMOGENIZATION_NONE_ID)) call homogenization_none_init - if (any(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID)) call homogenization_isostrain_init + if (any(homogenization_type == HOMOGENIZATION_NONE_ID)) call mech_none_init + if (any(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID)) call mech_isostrain_init if (any(homogenization_type == HOMOGENIZATION_RGC_ID)) call homogenization_RGC_init if (any(thermal_type == THERMAL_isothermal_ID)) call thermal_isothermal_init @@ -232,9 +253,9 @@ subroutine homogenization_init !-------------------------------------------------------------------------------------------------- ! allocate and initialize global state and postresutls variables - homogenization_maxSizePostResults = 0_pInt - thermal_maxSizePostResults = 0_pInt - damage_maxSizePostResults = 0_pInt + homogenization_maxSizePostResults = 0 + thermal_maxSizePostResults = 0 + damage_maxSizePostResults = 0 do p = 1,size(config_homogenization) homogenization_maxSizePostResults = max(homogenization_maxSizePostResults,homogState (p)%sizePostResults) thermal_maxSizePostResults = max(thermal_maxSizePostResults, thermalState (p)%sizePostResults) @@ -252,7 +273,7 @@ subroutine homogenization_init write(6,'(/,a)') ' <<<+- homogenization init -+>>>' - if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0) then #ifdef TODO write(6,'(a32,1x,7(i8,1x))') 'homogenization_state0: ', shape(homogenization_state0) write(6,'(a32,1x,7(i8,1x))') 'homogenization_subState0: ', shape(homogenization_subState0) @@ -275,7 +296,7 @@ subroutine homogenization_init flush(6) if (debug_g < 1 .or. debug_g > homogenization_Ngrains(mesh_element(3,debug_e))) & - call IO_error(602_pInt,ext_msg='constituent', el=debug_e, g=debug_g) + call IO_error(602,ext_msg='constituent', el=debug_e, g=debug_g) end subroutine homogenization_init @@ -344,7 +365,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) implicit none real(pReal), intent(in) :: dt !< time increment logical, intent(in) :: updateJaco !< initiating Jacobian update - integer(pInt) :: & + integer :: & NiterationHomog, & NiterationMPstate, & g, & !< grain number @@ -354,7 +375,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) myNgrains #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0) then write(6,'(/a,i5,1x,i2)') '<< HOMOG >> Material Point start at el ip ', debug_e, debug_i write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< HOMOG >> F0', & @@ -372,7 +393,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) plasticState (phaseAt(g,i,e))%partionedState0(:,phasememberAt(g,i,e)) = & plasticState (phaseAt(g,i,e))%state0( :,phasememberAt(g,i,e)) - do mySource = 1_pInt, phase_Nsources(phaseAt(g,i,e)) + do mySource = 1, phase_Nsources(phaseAt(g,i,e)) sourceState(phaseAt(g,i,e))%p(mySource)%partionedState0(:,phasememberAt(g,i,e)) = & sourceState(phaseAt(g,i,e))%p(mySource)%state0( :,phasememberAt(g,i,e)) enddo @@ -393,19 +414,19 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) materialpoint_requested(i,e) = .true. ! everybody requires calculation endforall forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - homogState(material_homogenizationAt(e))%sizeState > 0_pInt) & + homogState(material_homogenizationAt(e))%sizeState > 0) & homogState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & homogState(material_homogenizationAt(e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal homogenization state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - thermalState(material_homogenizationAt(e))%sizeState > 0_pInt) & + thermalState(material_homogenizationAt(e))%sizeState > 0) & thermalState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & thermalState(material_homogenizationAt(e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal thermal state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - damageState(material_homogenizationAt(e))%sizeState > 0_pInt) & + damageState(material_homogenizationAt(e))%sizeState > 0) & damageState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & damageState(material_homogenizationAt(e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal damage state enddo - NiterationHomog = 0_pInt + NiterationHomog = 0 cutBackLooping: do while (.not. terminallyIll .and. & any(materialpoint_subStep(:,FEsolving_execELem(1):FEsolving_execElem(2)) > subStepMinHomog)) @@ -417,9 +438,9 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) converged: if ( materialpoint_converged(i,e) ) then #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0 & .and. ((e == debug_e .and. i == debug_i) & - .or. .not. iand(debug_level(debug_homogenization),debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_homogenization),debug_levelSelective) /= 0)) then write(6,'(a,1x,f12.8,1x,a,1x,f12.8,1x,a,i8,1x,i2/)') '<< HOMOG >> winding forward from', & materialpoint_subFrac(i,e), 'to current materialpoint_subFrac', & materialpoint_subFrac(i,e)+materialpoint_subStep(i,e),'in materialpoint_stressAndItsTangent at el ip',e,i @@ -456,29 +477,29 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) do g = 1,myNgrains plasticState (phaseAt(g,i,e))%partionedState0(:,phasememberAt(g,i,e)) = & plasticState (phaseAt(g,i,e))%state( :,phasememberAt(g,i,e)) - do mySource = 1_pInt, phase_Nsources(phaseAt(g,i,e)) + do mySource = 1, phase_Nsources(phaseAt(g,i,e)) sourceState(phaseAt(g,i,e))%p(mySource)%partionedState0(:,phasememberAt(g,i,e)) = & sourceState(phaseAt(g,i,e))%p(mySource)%state( :,phasememberAt(g,i,e)) enddo enddo forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - homogState(material_homogenizationAt(e))%sizeState > 0_pInt) & + homogState(material_homogenizationAt(e))%sizeState > 0) & homogState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & homogState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) ! ...internal homogenization state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - thermalState(material_homogenizationAt(e))%sizeState > 0_pInt) & + thermalState(material_homogenizationAt(e))%sizeState > 0) & thermalState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & thermalState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) ! ...internal thermal state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - damageState(material_homogenizationAt(e))%sizeState > 0_pInt) & + damageState(material_homogenizationAt(e))%sizeState > 0) & damageState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & damageState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) ! ...internal damage state materialpoint_subF0(1:3,1:3,i,e) = materialpoint_subF(1:3,1:3,i,e) ! ...def grad endif steppingNeeded else converged - if ( (myNgrains == 1_pInt .and. materialpoint_subStep(i,e) <= 1.0 ) .or. & ! single grain already tried internal subStepping in crystallite + if ( (myNgrains == 1 .and. materialpoint_subStep(i,e) <= 1.0 ) .or. & ! single grain already tried internal subStepping in crystallite subStepSizeHomog * materialpoint_subStep(i,e) <= subStepMinHomog ) then ! would require too small subStep ! cutback makes no sense !$OMP FLUSH(terminallyIll) @@ -494,9 +515,9 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) materialpoint_subStep(i,e) = subStepSizeHomog * materialpoint_subStep(i,e) ! crystallite had severe trouble, so do a significant cutback #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0 & .and. ((e == debug_e .and. i == debug_i) & - .or. .not. iand(debug_level(debug_homogenization), debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_homogenization), debug_levelSelective) /= 0)) then write(6,'(a,1x,f12.8,a,i8,1x,i2/)') & '<< HOMOG >> cutback step in materialpoint_stressAndItsTangent with new materialpoint_subStep:',& materialpoint_subStep(i,e),' at el ip',e,i @@ -518,21 +539,21 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) do g = 1, myNgrains plasticState (phaseAt(g,i,e))%state( :,phasememberAt(g,i,e)) = & plasticState (phaseAt(g,i,e))%partionedState0(:,phasememberAt(g,i,e)) - do mySource = 1_pInt, phase_Nsources(phaseAt(g,i,e)) + do mySource = 1, phase_Nsources(phaseAt(g,i,e)) sourceState(phaseAt(g,i,e))%p(mySource)%state( :,phasememberAt(g,i,e)) = & sourceState(phaseAt(g,i,e))%p(mySource)%partionedState0(:,phasememberAt(g,i,e)) enddo enddo forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - homogState(material_homogenizationAt(e))%sizeState > 0_pInt) & + homogState(material_homogenizationAt(e))%sizeState > 0) & homogState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) = & homogState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal homogenization state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - thermalState(material_homogenizationAt(e))%sizeState > 0_pInt) & + thermalState(material_homogenizationAt(e))%sizeState > 0) & thermalState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) = & thermalState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal thermal state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - damageState(material_homogenizationAt(e))%sizeState > 0_pInt) & + damageState(material_homogenizationAt(e))%sizeState > 0) & damageState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) = & damageState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal damage state endif @@ -550,7 +571,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) enddo elementLooping1 !$OMP END PARALLEL DO - NiterationMPstate = 0_pInt + NiterationMPstate = 0 convergenceLooping: do while (.not. terminallyIll .and. & any( materialpoint_requested(:,FEsolving_execELem(1):FEsolving_execElem(2)) & @@ -606,7 +627,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) enddo convergenceLooping - NiterationHomog = NiterationHomog + 1_pInt + NiterationHomog = NiterationHomog + 1 enddo cutBackLooping @@ -652,7 +673,7 @@ subroutine materialpoint_postResults crystallite_postResults implicit none - integer(pInt) :: & + integer :: & thePos, & theSize, & myNgrains, & @@ -666,21 +687,21 @@ subroutine materialpoint_postResults myNgrains = homogenization_Ngrains(mesh_element(3,e)) myCrystallite = microstructure_crystallite(mesh_element(4,e)) IpLooping: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - thePos = 0_pInt + thePos = 0 theSize = homogState (material_homogenizationAt(e))%sizePostResults & + thermalState (material_homogenizationAt(e))%sizePostResults & + damageState (material_homogenizationAt(e))%sizePostResults materialpoint_results(thePos+1,i,e) = real(theSize,pReal) ! tell size of homogenization results - thePos = thePos + 1_pInt + thePos = thePos + 1 - if (theSize > 0_pInt) then ! any homogenization results to mention? + if (theSize > 0) then ! any homogenization results to mention? materialpoint_results(thePos+1:thePos+theSize,i,e) = postResults(i,e) ! tell homogenization results thePos = thePos + theSize endif materialpoint_results(thePos+1,i,e) = real(myNgrains,pReal) ! tell number of grains at materialpoint - thePos = thePos + 1_pInt + thePos = thePos + 1 grainLooping :do g = 1,myNgrains theSize = 1 + crystallite_sizePostResults(myCrystallite) + & @@ -710,13 +731,11 @@ subroutine partitionDeformation(ip,el) HOMOGENIZATION_RGC_ID use crystallite, only: & crystallite_partionedF - use homogenization_isostrain, only: & - homogenization_isostrain_partitionDeformation - use homogenization_RGC, only: & + use homogenization_mech_RGC, only: & homogenization_RGC_partitionDeformation implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ip, & !< integration point el !< element number @@ -726,7 +745,7 @@ subroutine partitionDeformation(ip,el) crystallite_partionedF(1:3,1:3,1,ip,el) = materialpoint_subF(1:3,1:3,ip,el) case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization - call homogenization_isostrain_partitionDeformation(& + call mech_isostrain_partitionDeformation(& crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & materialpoint_subF(1:3,1:3,ip,el)) @@ -761,7 +780,7 @@ function updateState(ip,el) crystallite_dPdF, & crystallite_partionedF,& crystallite_partionedF0 - use homogenization_RGC, only: & + use homogenization_mech_RGC, only: & homogenization_RGC_updateState use thermal_adiabatic, only: & thermal_adiabatic_updateState @@ -769,7 +788,7 @@ function updateState(ip,el) damage_local_updateState implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ip, & !< integration point el !< element number logical, dimension(2) :: updateState @@ -825,13 +844,11 @@ subroutine averageStressAndItsTangent(ip,el) HOMOGENIZATION_RGC_ID use crystallite, only: & crystallite_P,crystallite_dPdF - use homogenization_isostrain, only: & - homogenization_isostrain_averageStressAndItsTangent - use homogenization_RGC, only: & + use homogenization_mech_RGC, only: & homogenization_RGC_averageStressAndItsTangent implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ip, & !< integration point el !< element number @@ -841,7 +858,7 @@ subroutine averageStressAndItsTangent(ip,el) materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el) = crystallite_dPdF(1:3,1:3,1:3,1:3,1,ip,el) case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization - call homogenization_isostrain_averageStressAndItsTangent(& + call mech_isostrain_averageStressAndItsTangent(& materialpoint_P(1:3,1:3,ip,el), & materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el),& crystallite_P(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & @@ -888,7 +905,7 @@ function postResults(ip,el) DAMAGE_none_ID, & DAMAGE_local_ID, & DAMAGE_nonlocal_ID - use homogenization_RGC, only: & + use homogenization_mech_RGC, only: & homogenization_RGC_postResults use thermal_adiabatic, only: & thermal_adiabatic_postResults @@ -900,20 +917,20 @@ function postResults(ip,el) damage_nonlocal_postResults implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ip, & !< integration point el !< element number real(pReal), dimension( homogState (material_homogenizationAt(el))%sizePostResults & + thermalState (material_homogenizationAt(el))%sizePostResults & + damageState (material_homogenizationAt(el))%sizePostResults) :: & postResults - integer(pInt) :: & + integer :: & startPos, endPos ,& of, instance, homog postResults = 0.0_pReal - startPos = 1_pInt + startPos = 1 endPos = homogState(material_homogenizationAt(el))%sizePostResults chosenHomogenization: select case (homogenization_type(mesh_element(3,el))) @@ -924,7 +941,7 @@ function postResults(ip,el) end select chosenHomogenization - startPos = endPos + 1_pInt + startPos = endPos + 1 endPos = endPos + thermalState(material_homogenizationAt(el))%sizePostResults chosenThermal: select case (thermal_type(mesh_element(3,el))) @@ -939,7 +956,7 @@ function postResults(ip,el) end select chosenThermal - startPos = endPos + 1_pInt + startPos = endPos + 1 endPos = endPos + damageState(material_homogenizationAt(el))%sizePostResults chosenDamage: select case (damage_type(mesh_element(3,el))) diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 deleted file mode 100644 index 366d76b59..000000000 --- a/src/homogenization_isostrain.f90 +++ /dev/null @@ -1,149 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH -!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH -!> @brief Isostrain (full constraint Taylor assuption) homogenization scheme -!-------------------------------------------------------------------------------------------------- -module homogenization_isostrain - use prec, only: & - pInt - - implicit none - private - enum, bind(c) - enumerator :: & - parallel_ID, & - average_ID - end enum - - type, private :: tParameters !< container type for internal constitutive parameters - integer(pInt) :: & - Nconstituents - integer(kind(average_ID)) :: & - mapping - end type - - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - - public :: & - homogenization_isostrain_init, & - homogenization_isostrain_partitionDeformation, & - homogenization_isostrain_averageStressAndItsTangent - -contains - -!-------------------------------------------------------------------------------------------------- -!> @brief allocates all neccessary fields, reads information from material configuration file -!-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_init() - use debug, only: & - debug_HOMOGENIZATION, & - debug_level, & - debug_levelBasic - use IO, only: & - IO_error - use material, only: & - homogenization_type, & - material_homogenizationAt, & - homogState, & - HOMOGENIZATION_ISOSTRAIN_ID, & - HOMOGENIZATION_ISOSTRAIN_LABEL, & - homogenization_typeInstance - use config, only: & - config_homogenization - - implicit none - integer(pInt) :: & - Ninstance, & - h, & - NofMyHomog - character(len=65536) :: & - tag = '' - - write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_ISOSTRAIN_label//' init -+>>>' - - Ninstance = int(count(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID),pInt) - if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - - allocate(param(Ninstance)) ! one container of parameters per instance - - do h = 1_pInt, size(homogenization_type) - if (homogenization_type(h) /= HOMOGENIZATION_ISOSTRAIN_ID) cycle - - associate(prm => param(homogenization_typeInstance(h)),& - config => config_homogenization(h)) - - prm%Nconstituents = config_homogenization(h)%getInt('nconstituents') - tag = 'sum' - select case(trim(config%getString('mapping',defaultVal = tag))) - case ('sum') - prm%mapping = parallel_ID - case ('avg') - prm%mapping = average_ID - case default - call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_isostrain_label//')') - end select - - NofMyHomog = count(material_homogenizationAt == h) - homogState(h)%sizeState = 0_pInt - homogState(h)%sizePostResults = 0_pInt - allocate(homogState(h)%state0 (0_pInt,NofMyHomog)) - allocate(homogState(h)%subState0(0_pInt,NofMyHomog)) - allocate(homogState(h)%state (0_pInt,NofMyHomog)) - - end associate - - enddo - -end subroutine homogenization_isostrain_init - - -!-------------------------------------------------------------------------------------------------- -!> @brief partitions the deformation gradient onto the constituents -!-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_partitionDeformation(F,avgF) - use prec, only: & - pReal - - implicit none - real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient - - real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point - - F = spread(avgF,3,size(F,3)) - -end subroutine homogenization_isostrain_partitionDeformation - - -!-------------------------------------------------------------------------------------------------- -!> @brief derive average stress and stiffness from constituent quantities -!-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) - use prec, only: & - pReal - - implicit none - real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point - real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point - - real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses - real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses - integer(pInt), intent(in) :: instance - - associate(prm => param(instance)) - - select case (prm%mapping) - case (parallel_ID) - avgP = sum(P,3) - dAvgPdAvgF = sum(dPdF,5) - case (average_ID) - avgP = sum(P,3) /real(prm%Nconstituents,pReal) - dAvgPdAvgF = sum(dPdF,5)/real(prm%Nconstituents,pReal) - end select - - end associate - -end subroutine homogenization_isostrain_averageStressAndItsTangent - -end module homogenization_isostrain diff --git a/src/homogenization_RGC.f90 b/src/homogenization_mech_RGC.f90 similarity index 78% rename from src/homogenization_RGC.f90 rename to src/homogenization_mech_RGC.f90 index 6a513193b..012ad6086 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_mech_RGC.f90 @@ -6,16 +6,15 @@ !> @brief Relaxed grain cluster (RGC) homogenization scheme !> Nconstituents is defined as p x q x r (cluster) !-------------------------------------------------------------------------------------------------- -module homogenization_RGC +module homogenization_mech_RGC use prec, only: & - pReal, & - pInt + pReal implicit none private - integer(pInt), dimension(:,:), allocatable,target, public :: & + integer, dimension(:,:), allocatable,target, public :: & homogenization_RGC_sizePostResult - character(len=64), dimension(:,:), allocatable,target, public :: & + character(len=64), dimension(:,:), allocatable,target, public :: & homogenization_RGC_output ! name of each post result output enum, bind(c) @@ -30,7 +29,7 @@ module homogenization_RGC end enum type, private :: tParameters - integer(pInt), dimension(:), allocatable :: & + integer, dimension(:), allocatable :: & Nconstituents real(pReal) :: & xiAlpha, & @@ -38,8 +37,8 @@ module homogenization_RGC real(pReal), dimension(:), allocatable :: & dAlpha, & angles - integer(pInt) :: & - of_debug = 0_pInt + integer :: & + of_debug = 0 integer(kind(undefined_ID)), dimension(:), allocatable :: & outputID end type tParameters @@ -121,7 +120,7 @@ subroutine homogenization_RGC_init() config_homogenization implicit none - integer(pInt) :: & + integer :: & Ninstance, & h, i, & NofMyHomog, outputSize, & @@ -152,11 +151,11 @@ subroutine homogenization_RGC_init() allocate(state0(Ninstance)) allocate(dependentState(Ninstance)) - allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),Ninstance),source=0_pInt) + allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),Ninstance),source=0) allocate(homogenization_RGC_output(maxval(homogenization_Noutput),Ninstance)) homogenization_RGC_output='' - do h = 1_pInt, size(homogenization_type) + do h = 1, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_RGC_ID) cycle associate(prm => param(homogenization_typeInstance(h)), & stt => state(homogenization_typeInstance(h)), & @@ -172,7 +171,7 @@ subroutine homogenization_RGC_init() prm%Nconstituents = config%getInts('clustersize',requiredSize=3) if (homogenization_Ngrains(h) /= product(prm%Nconstituents)) & - call IO_error(211_pInt,ext_msg='clustersize ('//HOMOGENIZATION_RGC_label//')') + call IO_error(211,ext_msg='clustersize ('//HOMOGENIZATION_RGC_label//')') prm%xiAlpha = config%getFloat('scalingparameter') prm%ciAlpha = config%getFloat('overproportionality') @@ -183,28 +182,28 @@ subroutine homogenization_RGC_init() outputs = config%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) - do i=1_pInt, size(outputs) + do i=1, size(outputs) outputID = undefined_ID select case(outputs(i)) case('constitutivework') outputID = constitutivework_ID - outputSize = 1_pInt + outputSize = 1 case('penaltyenergy') outputID = penaltyenergy_ID - outputSize = 1_pInt + outputSize = 1 case('volumediscrepancy') outputID = volumediscrepancy_ID - outputSize = 1_pInt + outputSize = 1 case('averagerelaxrate') outputID = averagerelaxrate_ID - outputSize = 1_pInt + outputSize = 1 case('maximumrelaxrate') outputID = maximumrelaxrate_ID - outputSize = 1_pInt + outputSize = 1 case('magnitudemismatch') outputID = magnitudemismatch_ID - outputSize = 3_pInt + outputSize = 3 end select @@ -217,9 +216,9 @@ subroutine homogenization_RGC_init() enddo NofMyHomog = count(material_homogenizationAt == h) - nIntFaceTot = 3_pInt*( (prm%Nconstituents(1)-1_pInt)*prm%Nconstituents(2)*prm%Nconstituents(3) & - + prm%Nconstituents(1)*(prm%Nconstituents(2)-1_pInt)*prm%Nconstituents(3) & - + prm%Nconstituents(1)*prm%Nconstituents(2)*(prm%Nconstituents(3)-1_pInt)) + nIntFaceTot = 3*( (prm%Nconstituents(1)-1)*prm%Nconstituents(2)*prm%Nconstituents(3) & + + prm%Nconstituents(1)*(prm%Nconstituents(2)-1)*prm%Nconstituents(3) & + + prm%Nconstituents(1)*prm%Nconstituents(2)*(prm%Nconstituents(3)-1)) sizeState = nIntFaceTot & + size(['avg constitutive work ','average penalty energy']) @@ -266,36 +265,36 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) real(pReal), dimension (:,:,:), intent(out) :: F !< partioned F per grain real(pReal), dimension (:,:), intent(in) :: avgF !< averaged F - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of - real(pReal), dimension (3) :: aVect,nVect - integer(pInt), dimension (4) :: intFace - integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: iGrain,iFace,i,j + real(pReal), dimension(3) :: aVect,nVect + integer, dimension(4) :: intFace + integer, dimension(3) :: iGrain3 + integer :: iGrain,iFace,i,j associate(prm => param(instance)) !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations F = 0.0_pReal - do iGrain = 1_pInt,product(prm%Nconstituents) + do iGrain = 1,product(prm%Nconstituents) iGrain3 = grain1to3(iGrain,prm%Nconstituents) - do iFace = 1_pInt,6_pInt + do iFace = 1,6 intFace = getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain aVect = relaxationVector(intFace,instance,of) ! get the relaxation vectors for each interface from global relaxation vector array nVect = interfaceNormal(intFace,instance,of) - forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + forall (i=1:3,j=1:3) & F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! calculating deformation relaxations due to interface relaxation enddo F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! resulting relaxed deformation gradient #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0) then write(6,'(1x,a32,1x,i3)')'Deformation gradient of grain: ',iGrain - do i = 1_pInt,3_pInt - write(6,'(1x,3(e15.8,1x))')(F(i,j,iGrain), j = 1_pInt,3_pInt) + do i = 1,3 + write(6,'(1x,3(e15.8,1x))')(F(i,j,iGrain), j = 1,3) enddo write(6,*)' ' flush(6) @@ -340,32 +339,32 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) implicit none - real(pReal), dimension (:,:,:), intent(in) :: & + real(pReal), dimension(:,:,:), intent(in) :: & P,& !< array of P F,& !< array of F F0 !< array of initial F - real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< array of current grain stiffness - real(pReal), dimension (3,3), intent(in) :: avgF !< average F - real(pReal), intent(in) :: dt !< time increment - integer(pInt), intent(in) :: & + real(pReal), dimension(:,:,:,:,:), intent(in) :: dPdF !< array of current grain stiffness + real(pReal), dimension(3,3), intent(in) :: avgF !< average F + real(pReal), intent(in) :: dt !< time increment + integer, intent(in) :: & ip, & !< integration point number el !< element number - logical, dimension(2) :: homogenization_RGC_updateState + logical, dimension(2) :: homogenization_RGC_updateState - integer(pInt), dimension (4) :: intFaceN,intFaceP,faceID - integer(pInt), dimension (3) :: nGDim,iGr3N,iGr3P - integer(pInt) :: instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain, of - real(pReal), dimension (3,3,size(P,3)) :: R,pF,pR,D,pD - real(pReal), dimension (3,size(P,3)) :: NN,devNull - real(pReal), dimension (3) :: normP,normN,mornP,mornN + integer, dimension(4) :: intFaceN,intFaceP,faceID + integer, dimension(3) :: nGDim,iGr3N,iGr3P + integer :: instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain, of + real(pReal), dimension(3,3,size(P,3)) :: R,pF,pR,D,pD + real(pReal), dimension(3,size(P,3)) :: NN,devNull + real(pReal), dimension(3) :: normP,normN,mornP,mornN real(pReal) :: residMax,stresMax logical :: error real(pReal), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix real(pReal), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax #ifdef DEBUG - integer(pInt), dimension (3) :: stresLoc - integer(pInt), dimension (2) :: residLoc + integer, dimension(3) :: stresLoc + integer, dimension(2) :: residLoc #endif zeroTimeStep: if(dEq0(dt)) then @@ -382,21 +381,21 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! get the dimension of the cluster (grains and interfaces) nGDim = prm%Nconstituents nGrain = product(nGDim) - nIntFaceTot = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) & - + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) & - + nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) + nIntFaceTot = (nGDim(1)-1)*nGDim(2)*nGDim(3) & + + nGDim(1)*(nGDim(2)-1)*nGDim(3) & + + nGDim(1)*nGDim(2)*(nGDim(3)-1) !-------------------------------------------------------------------------------------------------- ! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster - allocate(resid(3_pInt*nIntFaceTot), source=0.0_pReal) + allocate(resid(3*nIntFaceTot), source=0.0_pReal) allocate(tract(nIntFaceTot,3), source=0.0_pReal) relax = stt%relaxationVector(:,of) drelax = stt%relaxationVector(:,of) - st0%relaxationVector(:,of) #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Obtained state: ' - do i = 1_pInt,size(stt%relaxationVector(:,of)) + do i = 1,size(stt%relaxationVector(:,of)) write(6,'(1x,2(e15.8,1x))') stt%relaxationVector(i,of) enddo write(6,*)' ' @@ -412,15 +411,15 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) call volumePenalty(D,dst%volumeDiscrepancy(of),avgF,F,nGrain,instance,of) #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then - do iGrain = 1_pInt,nGrain + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0) then + do iGrain = 1,nGrain write(6,'(1x,a30,1x,i3,1x,a4,3(1x,e15.8))')'Mismatch magnitude of grain(',iGrain,') :',& NN(1,iGrain),NN(2,iGrain),NN(3,iGrain) write(6,'(/,1x,a30,1x,i3)')'Stress and penalties of grain: ',iGrain - do i = 1_pInt,3_pInt - write(6,'(1x,3(e15.8,1x),1x,3(e15.8,1x),1x,3(e15.8,1x))')(P(i,j,iGrain), j = 1_pInt,3_pInt), & - (R(i,j,iGrain), j = 1_pInt,3_pInt), & - (D(i,j,iGrain), j = 1_pInt,3_pInt) + do i = 1,3 + write(6,'(1x,3(e15.8,1x),1x,3(e15.8,1x),1x,3(e15.8,1x))')(P(i,j,iGrain), j = 1,3), & + (R(i,j,iGrain), j = 1,3), & + (D(i,j,iGrain), j = 1,3) enddo write(6,*)' ' enddo @@ -429,40 +428,40 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !------------------------------------------------------------------------------------------------ ! computing the residual stress from the balance of traction at all (interior) interfaces - do iNum = 1_pInt,nIntFaceTot - faceID = interface1to4(iNum,param(instance)%Nconstituents) ! identifying the interface ID in local coordinate system (4-dimensional index) + do iNum = 1,nIntFaceTot + faceID = interface1to4(iNum,param(instance)%Nconstituents) ! identifying the interface ID in local coordinate system (4-dimensional index) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceN = getInterface(2_pInt*faceID(1),iGr3N) + iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceN = getInterface(2*faceID(1),iGr3N) normN = interfaceNormal(intFaceN,instance,of) !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) iGr3P = iGr3N - iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) + iGr3P(faceID(1)) = iGr3N(faceID(1))+1 ! identifying the grain ID in local coordinate system (3-dimensional index) + iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceP = getInterface(2*faceID(1)-1,iGr3P) normP = interfaceNormal(intFaceP,instance,of) !-------------------------------------------------------------------------------------------------- ! compute the residual of traction at the interface (in local system, 4-dimensional index) - do i = 1_pInt,3_pInt - tract(iNum,i) = sign(viscModus_RGC*(abs(drelax(i+3*(iNum-1_pInt)))/(refRelaxRate_RGC*dt))**viscPower_RGC, & - drelax(i+3*(iNum-1_pInt))) ! contribution from the relaxation viscosity - do j = 1_pInt,3_pInt + do i = 1,3 + tract(iNum,i) = sign(viscModus_RGC*(abs(drelax(i+3*(iNum-1)))/(refRelaxRate_RGC*dt))**viscPower_RGC, & + drelax(i+3*(iNum-1))) ! contribution from the relaxation viscosity + do j = 1,3 tract(iNum,i) = tract(iNum,i) + (P(i,j,iGrP) + R(i,j,iGrP) + D(i,j,iGrP))*normP(j) & ! contribution from material stress P, mismatch penalty R, and volume penalty D projected into the interface + (P(i,j,iGrN) + R(i,j,iGrN) + D(i,j,iGrN))*normN(j) - resid(i+3_pInt*(iNum-1_pInt)) = tract(iNum,i) ! translate the local residual into global 1-dimensional residual array + resid(i+3*(iNum-1)) = tract(iNum,i) ! translate the local residual into global 1-dimensional residual array enddo enddo #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0) then write(6,'(1x,a30,1x,i3)')'Traction at interface: ',iNum - write(6,'(1x,3(e15.8,1x))')(tract(iNum,j), j = 1_pInt,3_pInt) + write(6,'(1x,3(e15.8,1x))')(tract(iNum,j), j = 1,3) write(6,*)' ' endif #endif @@ -474,10 +473,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) residMax = maxval(abs(tract)) ! get the maximum of the residual #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of) then - stresLoc = int(maxloc(abs(P)),pInt) ! get the location of the maximum stress - residLoc = int(maxloc(abs(tract)),pInt) ! get the position of the maximum residual + stresLoc = maxloc(abs(P)) + residLoc = maxloc(abs(tract)) write(6,'(1x,a)')' ' write(6,'(1x,a,1x,i2,1x,i4)')'RGC residual check ...',ip,el write(6,'(1x,a15,1x,e15.8,1x,a7,i3,1x,a12,i2,i2)')'Max stress: ',stresMax, & @@ -495,15 +494,15 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) if (residMax < relTol_RGC*stresMax .or. residMax < absTol_RGC) then homogenization_RGC_updateState = .true. #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of) write(6,'(1x,a55,/)')'... done and happy' flush(6) #endif !-------------------------------------------------------------------------------------------------- ! compute/update the state for postResult, i.e., all energy densities computed by time-integration - do iGrain = 1_pInt,product(prm%Nconstituents) - do i = 1_pInt,3_pInt;do j = 1_pInt,3_pInt + do iGrain = 1,product(prm%Nconstituents) + do i = 1,3;do j = 1,3 stt%work(of) = stt%work(of) & + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) stt%penaltyEnergy(of) = stt%penaltyEnergy(of) & @@ -512,11 +511,11 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo dst%mismatch(1:3,of) = sum(NN,2)/real(nGrain,pReal) - dst%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) + dst%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3*nIntFaceTot,pReal) dst%relaxationRate_max(of) = maxval(abs(drelax))/dt #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of) then write(6,'(1x,a30,1x,e15.8)') 'Constitutive work: ',stt%work(of) write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',dst%mismatch(1,of), & @@ -538,7 +537,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) homogenization_RGC_updateState = [.true.,.false.] ! with direct cut-back #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of) write(6,'(1x,a,/)') '... broken' flush(6) #endif @@ -547,7 +546,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) else ! proceed with computing the Jacobian and state update #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of) write(6,'(1x,a,/)') '... not yet done' flush(6) #endif @@ -561,21 +560,21 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix" allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) - do iNum = 1_pInt,nIntFaceTot + do iNum = 1,nIntFaceTot faceID = interface1to4(iNum,param(instance)%Nconstituents) ! assembling of local dPdF into global Jacobian matrix !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate sytem iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate into global grain ID - intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system + intFaceN = getInterface(2*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system normN = interfaceNormal(intFaceN,instance,of) - do iFace = 1_pInt,6_pInt + do iFace = 1,6 intFaceN = getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface mornN = interfaceNormal(intFaceN,instance,of) iMun = interface4to1(intFaceN,param(instance)%Nconstituents) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0) then ! get the corresponding tangent - do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt + do i=1,3; do j=1,3; do k=1,3; do l=1,3 smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) & + dPdF(i,k,j,l,iGrN)*normN(k)*mornN(l) enddo;enddo;enddo;enddo @@ -587,16 +586,16 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) iGr3P = iGr3N - iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate sytem + iGr3P(faceID(1)) = iGr3N(faceID(1))+1 ! identifying the grain ID in local coordinate sytem iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate into global grain ID - intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system + intFaceP = getInterface(2*faceID(1)-1,iGr3P) ! identifying the connecting interface in local coordinate system normP = interfaceNormal(intFaceP,instance,of) - do iFace = 1_pInt,6_pInt + do iFace = 1,6 intFaceP = getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface mornP = interfaceNormal(intFaceP,instance,of) iMun = interface4to1(intFaceP,param(instance)%Nconstituents) ! translate the interfaces ID into local 4-dimensional index - if (iMun > 0_pInt) then ! get the corresponding tangent - do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt + if (iMun > 0) then ! get the corresponding tangent + do i=1,3; do j=1,3; do k=1,3; do l=1,3 smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) & + dPdF(i,k,j,l,iGrP)*normP(k)*mornP(l) enddo;enddo;enddo;enddo @@ -605,10 +604,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Jacobian matrix of stress' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,100(e11.4,1x))')(smatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) + do i = 1,3*nIntFaceTot + write(6,'(1x,100(e11.4,1x))')(smatrix(i,j), j = 1,3*nIntFaceTot) enddo write(6,*)' ' flush(6) @@ -622,7 +621,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) allocate(p_relax(3*nIntFaceTot), source=0.0_pReal) allocate(p_resid(3*nIntFaceTot), source=0.0_pReal) - do ipert = 1_pInt,3_pInt*nIntFaceTot + do ipert = 1,3*nIntFaceTot p_relax = relax p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector stt%relaxationVector(:,of) = p_relax @@ -633,28 +632,28 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing the global stress residual array from the perturbed state p_resid = 0.0_pReal - do iNum = 1_pInt,nIntFaceTot + do iNum = 1,nIntFaceTot faceID = interface1to4(iNum,param(instance)%Nconstituents) ! identifying the interface ID in local coordinate system (4-dimensional index) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identify the grain ID in local coordinate system (3-dimensional index) iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identify the interface ID of the grain + intFaceN = getInterface(2*faceID(1),iGr3N) ! identify the interface ID of the grain normN = interfaceNormal(intFaceN,instance,of) !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) iGr3P = iGr3N - iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identify the grain ID in local coordinate system (3-dimensional index) + iGr3P(faceID(1)) = iGr3N(faceID(1))+1 ! identify the grain ID in local coordinate system (3-dimensional index) iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identify the interface ID of the grain + intFaceP = getInterface(2*faceID(1)-1,iGr3P) ! identify the interface ID of the grain normP = interfaceNormal(intFaceP,instance,of) !-------------------------------------------------------------------------------------------------- ! compute the residual stress (contribution of mismatch and volume penalties) from perturbed state ! at all interfaces - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt + do i = 1,3; do j = 1,3 p_resid(i+3*(iNum-1)) = p_resid(i+3*(iNum-1)) + (pR(i,j,iGrP) - R(i,j,iGrP))*normP(j) & + (pR(i,j,iGrN) - R(i,j,iGrN))*normN(j) & + (pD(i,j,iGrP) - D(i,j,iGrP))*normP(j) & @@ -665,10 +664,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Jacobian matrix of penalty' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,100(e11.4,1x))')(pmatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) + do i = 1,3*nIntFaceTot + write(6,'(1x,100(e11.4,1x))')(pmatrix(i,j), j = 1,3*nIntFaceTot) enddo write(6,*)' ' flush(6) @@ -678,15 +677,15 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! ... of the numerical viscosity traction "rmatrix" allocate(rmatrix(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pReal) - forall (i=1_pInt:3_pInt*nIntFaceTot) & + forall (i=1:3*nIntFaceTot) & rmatrix(i,i) = viscModus_RGC*viscPower_RGC/(refRelaxRate_RGC*dt)* & ! tangent due to numerical viscosity traction appears (abs(drelax(i))/(refRelaxRate_RGC*dt))**(viscPower_RGC - 1.0_pReal) ! only in the main diagonal term #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Jacobian matrix of penalty' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,100(e11.4,1x))')(rmatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) + do i = 1,3*nIntFaceTot + write(6,'(1x,100(e11.4,1x))')(rmatrix(i,j), j = 1,3*nIntFaceTot) enddo write(6,*)' ' flush(6) @@ -698,10 +697,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) allocate(jmatrix(3*nIntFaceTot,3*nIntFaceTot)); jmatrix = smatrix + pmatrix + rmatrix #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Jacobian matrix (total)' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,100(e11.4,1x))')(jmatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) + do i = 1,3*nIntFaceTot + write(6,'(1x,100(e11.4,1x))')(jmatrix(i,j), j = 1,3*nIntFaceTot) enddo write(6,*)' ' flush(6) @@ -710,14 +709,14 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing the update of the state variable (relaxation vectors) using the Jacobian matrix - allocate(jnverse(3_pInt*nIntFaceTot,3_pInt*nIntFaceTot),source=0.0_pReal) + allocate(jnverse(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pReal) call math_invert2(jnverse,error,jmatrix) #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Jacobian inverse' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,100(e11.4,1x))')(jnverse(i,j), j = 1_pInt,3_pInt*nIntFaceTot) + do i = 1,3*nIntFaceTot + write(6,'(1x,100(e11.4,1x))')(jnverse(i,j), j = 1,3*nIntFaceTot) enddo write(6,*)' ' flush(6) @@ -727,7 +726,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! calculate the state update (global relaxation vectors) for the next Newton-Raphson iteration drelax = 0.0_pReal - do i = 1_pInt,3_pInt*nIntFaceTot;do j = 1_pInt,3_pInt*nIntFaceTot + do i = 1,3*nIntFaceTot;do j = 1,3*nIntFaceTot drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable enddo; enddo stt%relaxationVector(:,of) = relax + drelax ! Updateing the state variable for the next iteration @@ -741,9 +740,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) endif #ifdef DEBUG - if (iand(debug_homogenization, debug_levelExtensive) > 0_pInt) then + if (iand(debug_homogenization, debug_levelExtensive) > 0) then write(6,'(1x,a30)')'Returned state: ' - do i = 1_pInt,size(stt%relaxationVector(:,of)) + do i = 1,size(stt%relaxationVector(:,of)) write(6,'(1x,2(e15.8,1x))') stt%relaxationVector(i,of) enddo write(6,*)' ' @@ -769,14 +768,14 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) real(pReal), dimension (:,:,:), intent(in) :: fDef !< deformation gradients real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor - integer(pInt), intent(in) :: ip,el,instance,of + integer, intent(in) :: ip,el,instance,of - integer(pInt), dimension (4) :: intFace - integer(pInt), dimension (3) :: iGrain3,iGNghb3,nGDim + integer, dimension (4) :: intFace + integer, dimension (3) :: iGrain3,iGNghb3,nGDim real(pReal), dimension (3,3) :: gDef,nDef real(pReal), dimension (3) :: nVect,surfCorr real(pReal), dimension (2) :: Gmoduli - integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l + integer :: iGrain,iGNghb,iFace,i,j,k,l real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb real(pReal), parameter :: nDefToler = 1.0e-10_pReal #ifdef DEBUG @@ -796,7 +795,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) associate(prm => param(instance)) #ifdef DEBUG - debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of if (debugActive) then @@ -807,20 +806,20 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing the mismatch and penalty stress tensor of all grains - grainLoop: do iGrain = 1_pInt,product(prm%Nconstituents) + grainLoop: do iGrain = 1,product(prm%Nconstituents) Gmoduli = equivalentModuli(iGrain,ip,el) muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector iGrain3 = grain1to3(iGrain,prm%Nconstituents) ! get the grain ID in local 3-dimensional index (x,y,z)-position - interfaceLoop: do iFace = 1_pInt,6_pInt + interfaceLoop: do iFace = 1,6 intFace = getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain nVect = interfaceNormal(intFace,instance,of) iGNghb3 = iGrain3 ! identify the neighboring grain across the interface iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) & - + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) + + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal)) where(iGNghb3 < 1) iGNghb3 = nGDim - where(iGNghb3 >nGDim) iGNghb3 = 1_pInt + where(iGNghb3 >nGDim) iGNghb3 = 1 iGNghb = grain3to1(iGNghb3,prm%Nconstituents) ! get the ID of the neighboring grain Gmoduli = equivalentModuli(iGNghb,ip,el) ! collect the shear modulus and Burgers vector of the neighbor muGNghb = Gmoduli(1) @@ -831,8 +830,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! compute the mismatch tensor of all interfaces nDefNorm = 0.0_pReal nDef = 0.0_pReal - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt - do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt + do i = 1,3; do j = 1,3 + do k = 1,3; do l = 1,3 nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_civita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient enddo; enddo nDefNorm = nDefNorm + nDef(i,j)**2.0_pReal ! compute the norm of the mismatch tensor @@ -849,7 +848,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! compute the stress penalty of all interfaces - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt; do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt + do i = 1,3; do j = 1,3; do k = 1,3; do l = 1,3 rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*prm%xiAlpha & *surfCorr(abs(intFace(1)))/prm%dAlpha(abs(intFace(1))) & *cosh(prm%ciAlpha*nDefNorm) & @@ -889,18 +888,18 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) real(pReal), dimension (:,:,:), intent(in) :: fDef ! deformation gradients real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient - integer(pInt), intent(in) :: & + integer, intent(in) :: & Ngrain, & instance, & of real(pReal), dimension(size(vPen,3)) :: gVol - integer(pInt) :: i + integer :: i !-------------------------------------------------------------------------------------------------- ! compute the volumes of grains and of cluster vDiscrep = math_det33(fAvg) ! compute the volume of the cluster - do i = 1_pInt,nGrain + do i = 1,nGrain gVol(i) = math_det33(fDef(1:3,1:3,i)) ! compute the volume of individual grains vDiscrep = vDiscrep - gVol(i)/real(nGrain,pReal) ! calculate the difference/dicrepancy between ! the volume of the cluster and the the total volume of grains @@ -909,13 +908,13 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! calculate the stress and penalty due to volume discrepancy vPen = 0.0_pReal - do i = 1_pInt,nGrain + do i = 1,nGrain vPen(:,:,i) = -1.0_pReal/real(nGrain,pReal)*volDiscrMod_RGC*volDiscrPow_RGC/maxVolDiscr_RGC* & sign((abs(vDiscrep)/maxVolDiscr_RGC)**(volDiscrPow_RGC - 1.0),vDiscrep)* & gVol(i)*transpose(math_inv33(fDef(:,:,i))) #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. param(instance)%of_debug == of) then write(6,'(1x,a30,i2)')'Volume penalty of grain: ',i write(6,*) transpose(vPen(:,:,i)) @@ -936,22 +935,23 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) implicit none real(pReal), dimension(3) :: surfaceCorrection + real(pReal), dimension(3,3), intent(in) :: avgF !< average F - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of real(pReal), dimension(3,3) :: invC real(pReal), dimension(3) :: nVect real(pReal) :: detF - integer(pInt) :: i,j,iBase + integer :: i,j,iBase logical :: error call math_invert33(matmul(transpose(avgF),avgF),invC,detF,error) surfaceCorrection = 0.0_pReal - do iBase = 1_pInt,3_pInt - nVect = interfaceNormal([iBase,1_pInt,1_pInt,1_pInt],instance,of) - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt + do iBase = 1,3 + nVect = interfaceNormal([iBase,1,1,1],instance,of) + do i = 1,3; do j = 1,3 surfaceCorrection(iBase) = surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) ! compute the component of (the inverse of) the stretch in the direction of the normal enddo; enddo surfaceCorrection(iBase) = sqrt(surfaceCorrection(iBase))*detF ! get the surface correction factor (area contraction/enlargement) @@ -969,7 +969,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) implicit none real(pReal), dimension(2) :: equivalentModuli - integer(pInt), intent(in) :: & + + integer, intent(in) :: & grainID,& ip, & !< integration point number el !< element number @@ -1003,17 +1004,17 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) subroutine grainDeformation(F, avgF, instance, of) implicit none - real(pReal), dimension (:,:,:), intent(out) :: F !< partioned F per grain + real(pReal), dimension(:,:,:), intent(out) :: F !< partioned F per grain - real(pReal), dimension (:,:), intent(in) :: avgF !< averaged F - integer(pInt), intent(in) :: & + real(pReal), dimension(:,:), intent(in) :: avgF !< averaged F + integer, intent(in) :: & instance, & of - real(pReal), dimension (3) :: aVect,nVect - integer(pInt), dimension (4) :: intFace - integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: iGrain,iFace,i,j + real(pReal), dimension(3) :: aVect,nVect + integer, dimension(4) :: intFace + integer, dimension(3) :: iGrain3 + integer :: iGrain,iFace,i,j !------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations @@ -1021,13 +1022,13 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) associate(prm => param(instance)) F = 0.0_pReal - do iGrain = 1_pInt,product(prm%Nconstituents) + do iGrain = 1,product(prm%Nconstituents) iGrain3 = grain1to3(iGrain,prm%Nconstituents) - do iFace = 1_pInt,6_pInt + do iFace = 1,6 intFace = getInterface(iFace,iGrain3) aVect = relaxationVector(intFace,instance,of) nVect = interfaceNormal(intFace,instance,of) - forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + forall (i=1:3,j=1:3) & F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations enddo F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! relaxed deformation gradient @@ -1046,12 +1047,12 @@ end function homogenization_RGC_updateState subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) implicit none - real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point - real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point + real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point + real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point - real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses - real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses - integer(pInt), intent(in) :: instance + real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses + real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses + integer, intent(in) :: instance avgP = sum(P,3) /real(product(param(instance)%Nconstituents),pReal) dAvgPdAvgF = sum(dPdF,5)/real(product(param(instance)%Nconstituents),pReal) @@ -1065,40 +1066,40 @@ end subroutine homogenization_RGC_averageStressAndItsTangent pure function homogenization_RGC_postResults(instance,of) result(postResults) implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of - integer(pInt) :: & + integer :: & o,c real(pReal), dimension(sum(homogenization_RGC_sizePostResult(:,instance))) :: & postResults associate(stt => state(instance), dst => dependentState(instance), prm => param(instance)) - c = 0_pInt + c = 0 - outputsLoop: do o = 1_pInt,size(prm%outputID) + outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) case (constitutivework_ID) postResults(c+1) = stt%work(of) - c = c + 1_pInt + c = c + 1 case (magnitudemismatch_ID) postResults(c+1:c+3) = dst%mismatch(1:3,of) - c = c + 3_pInt + c = c + 3 case (penaltyenergy_ID) postResults(c+1) = stt%penaltyEnergy(of) - c = c + 1_pInt + c = c + 1 case (volumediscrepancy_ID) postResults(c+1) = dst%volumeDiscrepancy(of) - c = c + 1_pInt + c = c + 1 case (averagerelaxrate_ID) postResults(c+1) = dst%relaxationrate_avg(of) - c = c + 1_pInt + c = c + 1 case (maximumrelaxrate_ID) postResults(c+1) = dst%relaxationrate_max(of) - c = c + 1_pInt + c = c + 1 end select enddo outputsLoop @@ -1114,18 +1115,20 @@ end function homogenization_RGC_postResults pure function relaxationVector(intFace,instance,of) implicit none - integer(pInt), intent(in) :: instance,of + real(pReal), dimension (3) :: relaxationVector + + integer, intent(in) :: instance,of + integer, dimension(4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) - real(pReal), dimension (3) :: relaxationVector - integer(pInt), dimension (4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) - integer(pInt) :: & - iNum + integer :: iNum + + !-------------------------------------------------------------------------------------------------- ! collect the interface relaxation vector from the global state array iNum = interface4to1(intFace,param(instance)%Nconstituents) ! identify the position of the interface in global state array - if (iNum > 0_pInt) then + if (iNum > 0) then relaxationVector = state(instance)%relaxationVector((3*iNum-2):(3*iNum),of) else relaxationVector = 0.0_pReal @@ -1140,12 +1143,14 @@ end function relaxationVector pure function interfaceNormal(intFace,instance,of) implicit none - real(pReal), dimension (3) :: interfaceNormal - integer(pInt), dimension (4), intent(in) :: intFace !< interface ID in 4D array (normal and position) - integer(pInt), intent(in) :: & + real(pReal), dimension(3) :: interfaceNormal + + integer, dimension(4), intent(in) :: intFace !< interface ID in 4D array (normal and position) + integer, intent(in) :: & instance, & of - integer(pInt) :: nPos + + integer :: nPos !-------------------------------------------------------------------------------------------------- ! get the normal of the interface, identified from the value of intFace(1) @@ -1153,7 +1158,7 @@ pure function interfaceNormal(intFace,instance,of) nPos = abs(intFace(1)) ! identify the position of the interface in global state array interfaceNormal(nPos) = real(intFace(1)/abs(intFace(1)),pReal) ! get the normal vector w.r.t. cluster axis - interfaceNormal = matmul(dependentState(instance)%orientation(1:3,1:3,of),interfaceNormal) ! map the normal vector into sample coordinate system (basis) + interfaceNormal = matmul(dependentState(instance)%orientation(1:3,1:3,of),interfaceNormal) ! map the normal vector into sample coordinate system (basis) end function interfaceNormal @@ -1164,19 +1169,21 @@ end function interfaceNormal pure function getInterface(iFace,iGrain3) implicit none - integer(pInt), dimension (4) :: getInterface - integer(pInt), dimension (3), intent(in) :: iGrain3 !< grain ID in 3D array - integer(pInt), intent(in) :: iFace !< face index (1..6) mapped like (-e1,-e2,-e3,+e1,+e2,+e3) or iDir = (-1,-2,-3,1,2,3) - integer(pInt) :: iDir + integer, dimension(4) :: getInterface + + integer, dimension(3), intent(in) :: iGrain3 !< grain ID in 3D array + integer, intent(in) :: iFace !< face index (1..6) mapped like (-e1,-e2,-e3,+e1,+e2,+e3) or iDir = (-1,-2,-3,1,2,3) + + integer :: iDir !* Direction of interface normal - iDir = (int(real(iFace-1_pInt,pReal)/2.0_pReal,pInt)+1_pInt)*(-1_pInt)**iFace + iDir = (int(real(iFace-1,pReal)/2.0_pReal)+1)*(-1)**iFace getInterface(1) = iDir !-------------------------------------------------------------------------------------------------- ! identify the interface position by the direction of its normal getInterface(2:4) = iGrain3 - if (iDir < 0_pInt) getInterface(1_pInt-iDir) = getInterface(1_pInt-iDir)-1_pInt ! to have a correlation with coordinate/position in real space + if (iDir < 0) getInterface(1-iDir) = getInterface(1-iDir)-1 ! to have a correlation with coordinate/position in real space end function getInterface @@ -1187,13 +1194,14 @@ end function getInterface pure function grain1to3(grain1,nGDim) implicit none - integer(pInt), dimension(3) :: grain1to3 - integer(pInt), intent(in) :: grain1 !< grain ID in 1D array - integer(pInt), dimension(3), intent(in) :: nGDim + integer, dimension(3) :: grain1to3 - grain1to3 = 1_pInt + [mod((grain1-1_pInt),nGDim(1)), & - mod((grain1-1_pInt)/nGDim(1),nGDim(2)), & - (grain1-1_pInt)/(nGDim(1)*nGDim(2))] + integer, intent(in) :: grain1 !< grain ID in 1D array + integer, dimension(3), intent(in) :: nGDim + + grain1to3 = 1 + [mod((grain1-1),nGDim(1)), & + mod((grain1-1)/nGDim(1),nGDim(2)), & + (grain1-1)/(nGDim(1)*nGDim(2))] end function grain1to3 @@ -1201,15 +1209,15 @@ end function grain1to3 !-------------------------------------------------------------------------------------------------- !> @brief map grain ID from in 3D (local position) to in 1D (global array) !-------------------------------------------------------------------------------------------------- -integer(pInt) pure function grain3to1(grain3,nGDim) +integer pure function grain3to1(grain3,nGDim) implicit none - integer(pInt), dimension(3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) - integer(pInt), dimension(3), intent(in) :: nGDim + integer, dimension(3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) + integer, dimension(3), intent(in) :: nGDim grain3to1 = grain3(1) & - + nGDim(1)*(grain3(2)-1_pInt) & - + nGDim(1)*nGDim(2)*(grain3(3)-1_pInt) + + nGDim(1)*(grain3(2)-1) & + + nGDim(1)*nGDim(2)*(grain3(3)-1) end function grain3to1 @@ -1217,44 +1225,44 @@ end function grain3to1 !-------------------------------------------------------------------------------------------------- !> @brief maps interface ID from 4D (normal and local position) into 1D (global array) !-------------------------------------------------------------------------------------------------- -integer(pInt) pure function interface4to1(iFace4D, nGDim) +integer pure function interface4to1(iFace4D, nGDim) implicit none - integer(pInt), dimension(4), intent(in) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z) - integer(pInt), dimension(3), intent(in) :: nGDim + integer, dimension(4), intent(in) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z) + integer, dimension(3), intent(in) :: nGDim select case(abs(iFace4D(1))) - case(1_pInt) - if ((iFace4D(2) == 0_pInt) .or. (iFace4D(2) == nGDim(1))) then - interface4to1 = 0_pInt + case(1) + if ((iFace4D(2) == 0) .or. (iFace4D(2) == nGDim(1))) then + interface4to1 = 0 else - interface4to1 = iFace4D(3) + nGDim(2)*(iFace4D(4)-1_pInt) & - + nGDim(2)*nGDim(3)*(iFace4D(2)-1_pInt) + interface4to1 = iFace4D(3) + nGDim(2)*(iFace4D(4)-1) & + + nGDim(2)*nGDim(3)*(iFace4D(2)-1) endif - case(2_pInt) - if ((iFace4D(3) == 0_pInt) .or. (iFace4D(3) == nGDim(2))) then - interface4to1 = 0_pInt + case(2) + if ((iFace4D(3) == 0) .or. (iFace4D(3) == nGDim(2))) then + interface4to1 = 0 else - interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1_pInt) & - + nGDim(3)*nGDim(1)*(iFace4D(3)-1_pInt) & - + (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) ! total number of interfaces normal //e1 + interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1) & + + nGDim(3)*nGDim(1)*(iFace4D(3)-1) & + + (nGDim(1)-1)*nGDim(2)*nGDim(3) ! total number of interfaces normal //e1 endif - case(3_pInt) - if ((iFace4D(4) == 0_pInt) .or. (iFace4D(4) == nGDim(3))) then - interface4to1 = 0_pInt + case(3) + if ((iFace4D(4) == 0) .or. (iFace4D(4) == nGDim(3))) then + interface4to1 = 0 else - interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1_pInt) & - + nGDim(1)*nGDim(2)*(iFace4D(4)-1_pInt) & - + (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) & ! total number of interfaces normal //e1 - + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) ! total number of interfaces normal //e2 + interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1) & + + nGDim(1)*nGDim(2)*(iFace4D(4)-1) & + + (nGDim(1)-1)*nGDim(2)*nGDim(3) & ! total number of interfaces normal //e1 + + nGDim(1)*(nGDim(2)-1)*nGDim(3) ! total number of interfaces normal //e2 endif case default - interface4to1 = -1_pInt + interface4to1 = -1 end select @@ -1267,64 +1275,38 @@ end function interface4to1 pure function interface1to4(iFace1D, nGDim) implicit none - integer(pInt), dimension(4) :: interface1to4 - integer(pInt), intent(in) :: iFace1D !< interface ID in 1D array - integer(pInt), dimension(3), intent(in) :: nGDim - integer(pInt), dimension(3) :: nIntFace + integer, dimension(4) :: interface1to4 + + integer, intent(in) :: iFace1D !< interface ID in 1D array + integer, dimension(3), intent(in) :: nGDim + integer, dimension(3) :: nIntFace !-------------------------------------------------------------------------------------------------- ! compute the total number of interfaces, which ... - nIntFace = [(nGDim(1)-1_pInt)*nGDim(2)*nGDim(3), & ! ... normal //e1 - nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3), & ! ... normal //e2 - nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt)] ! ... normal //e3 + nIntFace = [(nGDim(1)-1)*nGDim(2)*nGDim(3), & ! ... normal //e1 + nGDim(1)*(nGDim(2)-1)*nGDim(3), & ! ... normal //e2 + nGDim(1)*nGDim(2)*(nGDim(3)-1)] ! ... normal //e3 !-------------------------------------------------------------------------------------------------- ! get the corresponding interface ID in 4D (normal and local position) if (iFace1D > 0 .and. iFace1D <= nIntFace(1)) then ! interface with normal //e1 - interface1to4(1) = 1_pInt - interface1to4(3) = mod((iFace1D-1_pInt),nGDim(2))+1_pInt - interface1to4(4) = mod(& - int(& - real(iFace1D-1_pInt,pReal)/& - real(nGDim(2),pReal)& - ,pInt)& - ,nGDim(3))+1_pInt - interface1to4(2) = int(& - real(iFace1D-1_pInt,pReal)/& - real(nGDim(2),pReal)/& - real(nGDim(3),pReal)& - ,pInt)+1_pInt + interface1to4(1) = 1 + interface1to4(3) = mod((iFace1D-1),nGDim(2))+1 + interface1to4(4) = mod(int(real(iFace1D-1,pReal)/real(nGDim(2),pReal)),nGDim(3))+1 + interface1to4(2) = int(real(iFace1D-1,pReal)/real(nGDim(2),pReal)/real(nGDim(3),pReal))+1 elseif (iFace1D > nIntFace(1) .and. iFace1D <= (nIntFace(2) + nIntFace(1))) then ! interface with normal //e2 - interface1to4(1) = 2_pInt - interface1to4(4) = mod((iFace1D-nIntFace(1)-1_pInt),nGDim(3))+1_pInt - interface1to4(2) = mod(& - int(& - real(iFace1D-nIntFace(1)-1_pInt,pReal)/& - real(nGDim(3),pReal)& - ,pInt)& - ,nGDim(1))+1_pInt - interface1to4(3) = int(& - real(iFace1D-nIntFace(1)-1_pInt,pReal)/& - real(nGDim(3),pReal)/& - real(nGDim(1),pReal)& - ,pInt)+1_pInt + interface1to4(1) = 2 + interface1to4(4) = mod((iFace1D-nIntFace(1)-1),nGDim(3))+1 + interface1to4(2) = mod(int(real(iFace1D-nIntFace(1)-1,pReal)/real(nGDim(3),pReal)),nGDim(1))+1 + interface1to4(3) = int(real(iFace1D-nIntFace(1)-1,pReal)/real(nGDim(3),pReal)/real(nGDim(1),pReal))+1 elseif (iFace1D > nIntFace(2) + nIntFace(1) .and. iFace1D <= (nIntFace(3) + nIntFace(2) + nIntFace(1))) then ! interface with normal //e3 - interface1to4(1) = 3_pInt - interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1_pInt),nGDim(1))+1_pInt - interface1to4(3) = mod(& - int(& - real(iFace1D-nIntFace(2)-nIntFace(1)-1_pInt,pReal)/& - real(nGDim(1),pReal)& - ,pInt)& - ,nGDim(2))+1_pInt - interface1to4(4) = int(& - real(iFace1D-nIntFace(2)-nIntFace(1)-1_pInt,pReal)/& - real(nGDim(1),pReal)/& - real(nGDim(2),pReal)& - ,pInt)+1_pInt + interface1to4(1) = 3 + interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1),nGDim(1))+1 + interface1to4(3) = mod(int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pReal)/real(nGDim(1),pReal)),nGDim(2))+1 + interface1to4(4) = int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pReal)/real(nGDim(1),pReal)/real(nGDim(2),pReal))+1 endif end function interface1to4 -end module homogenization_RGC +end module homogenization_mech_RGC diff --git a/src/homogenization_mech_isostrain.f90 b/src/homogenization_mech_isostrain.f90 new file mode 100644 index 000000000..1fdf5435c --- /dev/null +++ b/src/homogenization_mech_isostrain.f90 @@ -0,0 +1,139 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Isostrain (full constraint Taylor assuption) homogenization scheme +!-------------------------------------------------------------------------------------------------- +submodule(homogenization) homogenization_mech_isostrain + + implicit none + + enum, bind(c) + enumerator :: & + parallel_ID, & + average_ID + end enum + + type :: tParameters !< container type for internal constitutive parameters + integer :: & + Nconstituents + integer(kind(average_ID)) :: & + mapping + end type + + type(tParameters), dimension(:), allocatable :: param !< containers of constitutive parameters (len Ninstance) + + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, reads information from material configuration file +!-------------------------------------------------------------------------------------------------- +module subroutine mech_isostrain_init + use debug, only: & + debug_HOMOGENIZATION, & + debug_level, & + debug_levelBasic + use IO, only: & + IO_error + use material, only: & + homogenization_type, & + material_homogenizationAt, & + homogState, & + HOMOGENIZATION_ISOSTRAIN_ID, & + HOMOGENIZATION_ISOSTRAIN_LABEL, & + homogenization_typeInstance + use config, only: & + config_homogenization + + implicit none + integer :: & + Ninstance, & + h, & + NofMyHomog + character(len=65536) :: & + tag = '' + + write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_ISOSTRAIN_label//' init -+>>>' + + Ninstance = count(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID) + if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0) & + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + + allocate(param(Ninstance)) ! one container of parameters per instance + + do h = 1, size(homogenization_type) + if (homogenization_type(h) /= HOMOGENIZATION_ISOSTRAIN_ID) cycle + + associate(prm => param(homogenization_typeInstance(h)),& + config => config_homogenization(h)) + + prm%Nconstituents = config_homogenization(h)%getInt('nconstituents') + tag = 'sum' + select case(trim(config%getString('mapping',defaultVal = tag))) + case ('sum') + prm%mapping = parallel_ID + case ('avg') + prm%mapping = average_ID + case default + call IO_error(211,ext_msg=trim(tag)//' ('//HOMOGENIZATION_isostrain_label//')') + end select + + NofMyHomog = count(material_homogenizationAt == h) + homogState(h)%sizeState = 0 + homogState(h)%sizePostResults = 0 + allocate(homogState(h)%state0 (0,NofMyHomog)) + allocate(homogState(h)%subState0(0,NofMyHomog)) + allocate(homogState(h)%state (0,NofMyHomog)) + + end associate + + enddo + +end subroutine mech_isostrain_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief partitions the deformation gradient onto the constituents +!-------------------------------------------------------------------------------------------------- +module subroutine mech_isostrain_partitionDeformation(F,avgF) + + implicit none + real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient + + real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point + + F = spread(avgF,3,size(F,3)) + +end subroutine mech_isostrain_partitionDeformation + + +!-------------------------------------------------------------------------------------------------- +!> @brief derive average stress and stiffness from constituent quantities +!-------------------------------------------------------------------------------------------------- +module subroutine mech_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) + + implicit none + real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point + real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point + + real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses + real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses + integer, intent(in) :: instance + + associate(prm => param(instance)) + + select case (prm%mapping) + case (parallel_ID) + avgP = sum(P,3) + dAvgPdAvgF = sum(dPdF,5) + case (average_ID) + avgP = sum(P,3) /real(prm%Nconstituents,pReal) + dAvgPdAvgF = sum(dPdF,5)/real(prm%Nconstituents,pReal) + end select + + end associate + +end subroutine mech_isostrain_averageStressAndItsTangent + +end submodule homogenization_mech_isostrain diff --git a/src/homogenization_none.f90 b/src/homogenization_mech_none.f90 similarity index 90% rename from src/homogenization_none.f90 rename to src/homogenization_mech_none.f90 index cbbfa4cac..4ac509363 100644 --- a/src/homogenization_none.f90 +++ b/src/homogenization_mech_none.f90 @@ -4,20 +4,16 @@ !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @brief dummy homogenization homogenization scheme for 1 constituent per material point !-------------------------------------------------------------------------------------------------- -module homogenization_none +submodule(homogenization) homogenization_mech_none implicit none - private - - public :: & - homogenization_none_init contains !-------------------------------------------------------------------------------------------------- !> @brief allocates all neccessary fields, reads information from material configuration file !-------------------------------------------------------------------------------------------------- -subroutine homogenization_none_init() +module subroutine mech_none_init use debug, only: & debug_HOMOGENIZATION, & debug_level, & @@ -55,6 +51,6 @@ subroutine homogenization_none_init() enddo -end subroutine homogenization_none_init +end subroutine mech_none_init -end module homogenization_none +end submodule homogenization_mech_none diff --git a/src/lattice.f90 b/src/lattice.f90 index 1b844c31f..1a7508984 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -7,1286 +7,1278 @@ ! and cleavage as well as interaction among the various systems !-------------------------------------------------------------------------------------------------- module lattice - use prec, only: & - pReal - use future - - implicit none - private - + use prec, only: & + pReal + use future + + implicit none + private + ! BEGIN DEPRECATED - integer, parameter, public :: & - LATTICE_maxNcleavageFamily = 3 !< max # of transformation system families over lattice structures - - integer, allocatable, dimension(:,:), protected, public :: & - lattice_NcleavageSystem !< total # of transformation systems in each family - - real(pReal), allocatable, dimension(:,:,:,:,:), protected, public :: & - lattice_Scleavage !< Schmid matrices for cleavage systems + integer, parameter, public :: & + LATTICE_maxNcleavageFamily = 3 !< max # of transformation system families over lattice structures + + integer, allocatable, dimension(:,:), protected, public :: & + lattice_NcleavageSystem !< total # of transformation systems in each family + + real(pReal), allocatable, dimension(:,:,:,:,:), protected, public :: & + lattice_Scleavage !< Schmid matrices for cleavage systems ! END DEPRECATED !-------------------------------------------------------------------------------------------------- ! face centered cubic - integer, dimension(2), parameter, private :: & - LATTICE_FCC_NSLIPSYSTEM = [12, 6] !< # of slip systems per family for fcc - - integer, dimension(1), parameter, private :: & - LATTICE_FCC_NTWINSYSTEM = [12] !< # of twin systems per family for fcc - - integer, dimension(1), parameter, private :: & - LATTICE_FCC_NTRANSSYSTEM = [12] !< # of transformation systems per family for fcc - - integer, dimension(2), parameter, private :: & - LATTICE_FCC_NCLEAVAGESYSTEM = [3, 4] !< # of cleavage systems per family for fcc - - integer, parameter, private :: & - LATTICE_FCC_NSLIP = sum(LATTICE_FCC_NSLIPSYSTEM), & !< total # of slip systems for fcc - LATTICE_FCC_NTWIN = sum(LATTICE_FCC_NTWINSYSTEM), & !< total # of twin systems for fcc - LATTICE_FCC_NTRANS = sum(LATTICE_FCC_NTRANSSYSTEM), & !< total # of transformation systems for fcc - LATTICE_FCC_NCLEAVAGE = sum(LATTICE_FCC_NCLEAVAGESYSTEM) !< total # of cleavage systems for fcc - - real(pReal), dimension(3+3,LATTICE_FCC_NSLIP), parameter, private :: & - LATTICE_FCC_SYSTEMSLIP = reshape(real([& - ! Slip direction Plane normal ! SCHMID-BOAS notation - 0, 1,-1, 1, 1, 1, & ! B2 - -1, 0, 1, 1, 1, 1, & ! B4 - 1,-1, 0, 1, 1, 1, & ! B5 - 0,-1,-1, -1,-1, 1, & ! C1 - 1, 0, 1, -1,-1, 1, & ! C3 - -1, 1, 0, -1,-1, 1, & ! C5 - 0,-1, 1, 1,-1,-1, & ! A2 - -1, 0,-1, 1,-1,-1, & ! A3 - 1, 1, 0, 1,-1,-1, & ! A6 - 0, 1, 1, -1, 1,-1, & ! D1 - 1, 0,-1, -1, 1,-1, & ! D4 - -1,-1, 0, -1, 1,-1, & ! D6 - ! Slip system <110>{110} - 1, 1, 0, 1,-1, 0, & - 1,-1, 0, 1, 1, 0, & - 1, 0, 1, 1, 0,-1, & - 1, 0,-1, 1, 0, 1, & - 0, 1, 1, 0, 1,-1, & - 0, 1,-1, 0, 1, 1 & - ],pReal),shape(LATTICE_FCC_SYSTEMSLIP)) !< Slip system <110>{111} directions. Sorted according to Eisenlohr & Hantcherli - - character(len=*), dimension(2), parameter, private :: LATTICE_FCC_SLIPFAMILY_NAME = & - ['<0 1 -1>{1 1 1}', & - '<0 1 -1>{0 1 1}'] - - real(pReal), dimension(3+3,LATTICE_FCC_NTWIN), parameter, private :: & - LATTICE_FCC_SYSTEMTWIN = reshape(real( [& - -2, 1, 1, 1, 1, 1, & - 1,-2, 1, 1, 1, 1, & - 1, 1,-2, 1, 1, 1, & - 2,-1, 1, -1,-1, 1, & - -1, 2, 1, -1,-1, 1, & - -1,-1,-2, -1,-1, 1, & - -2,-1,-1, 1,-1,-1, & - 1, 2,-1, 1,-1,-1, & - 1,-1, 2, 1,-1,-1, & - 2, 1,-1, -1, 1,-1, & - -1,-2,-1, -1, 1,-1, & - -1, 1, 2, -1, 1,-1 & - ],pReal),shape(LATTICE_FCC_SYSTEMTWIN)) !< Twin system <112>{111} directions. Sorted according to Eisenlohr & Hantcherli - - character(len=*), dimension(1), parameter, private :: LATTICE_FCC_TWINFAMILY_NAME = & - ['<-2 1 1>{1 1 1}'] - - - integer, dimension(2,LATTICE_FCC_NTWIN), parameter, public :: & - LATTICE_FCC_TWINNUCLEATIONSLIPPAIR = reshape( [& - 2,3, & - 1,3, & - 1,2, & - 5,6, & - 4,6, & - 4,5, & - 8,9, & - 7,9, & - 7,8, & - 11,12, & - 10,12, & - 10,11 & - ],shape(LATTICE_FCC_TWINNUCLEATIONSLIPPAIR)) - - real(pReal), dimension(3+3,LATTICE_FCC_NCLEAVAGE), parameter, private :: & - LATTICE_FCC_SYSTEMCLEAVAGE = reshape(real([& - ! Cleavage direction Plane normal - 0, 1, 0, 1, 0, 0, & - 0, 0, 1, 0, 1, 0, & - 1, 0, 0, 0, 0, 1, & - 0, 1,-1, 1, 1, 1, & - 0,-1,-1, -1,-1, 1, & - -1, 0,-1, 1,-1,-1, & - 0, 1, 1, -1, 1,-1 & - ],pReal),shape(LATTICE_FCC_SYSTEMCLEAVAGE)) - + integer, dimension(2), parameter, private :: & + LATTICE_FCC_NSLIPSYSTEM = [12, 6] !< # of slip systems per family for fcc + + integer, dimension(1), parameter, private :: & + LATTICE_FCC_NTWINSYSTEM = [12] !< # of twin systems per family for fcc + + integer, dimension(1), parameter, private :: & + LATTICE_FCC_NTRANSSYSTEM = [12] !< # of transformation systems per family for fcc + + integer, dimension(2), parameter, private :: & + LATTICE_FCC_NCLEAVAGESYSTEM = [3, 4] !< # of cleavage systems per family for fcc + + integer, parameter, private :: & + LATTICE_FCC_NSLIP = sum(LATTICE_FCC_NSLIPSYSTEM), & !< total # of slip systems for fcc + LATTICE_FCC_NTWIN = sum(LATTICE_FCC_NTWINSYSTEM), & !< total # of twin systems for fcc + LATTICE_FCC_NTRANS = sum(LATTICE_FCC_NTRANSSYSTEM), & !< total # of transformation systems for fcc + LATTICE_FCC_NCLEAVAGE = sum(LATTICE_FCC_NCLEAVAGESYSTEM) !< total # of cleavage systems for fcc + + real(pReal), dimension(3+3,LATTICE_FCC_NSLIP), parameter, private :: & + LATTICE_FCC_SYSTEMSLIP = reshape(real([& + ! Slip direction Plane normal ! SCHMID-BOAS notation + 0, 1,-1, 1, 1, 1, & ! B2 + -1, 0, 1, 1, 1, 1, & ! B4 + 1,-1, 0, 1, 1, 1, & ! B5 + 0,-1,-1, -1,-1, 1, & ! C1 + 1, 0, 1, -1,-1, 1, & ! C3 + -1, 1, 0, -1,-1, 1, & ! C5 + 0,-1, 1, 1,-1,-1, & ! A2 + -1, 0,-1, 1,-1,-1, & ! A3 + 1, 1, 0, 1,-1,-1, & ! A6 + 0, 1, 1, -1, 1,-1, & ! D1 + 1, 0,-1, -1, 1,-1, & ! D4 + -1,-1, 0, -1, 1,-1, & ! D6 + ! Slip system <110>{110} + 1, 1, 0, 1,-1, 0, & + 1,-1, 0, 1, 1, 0, & + 1, 0, 1, 1, 0,-1, & + 1, 0,-1, 1, 0, 1, & + 0, 1, 1, 0, 1,-1, & + 0, 1,-1, 0, 1, 1 & + ],pReal),shape(LATTICE_FCC_SYSTEMSLIP)) !< Slip system <110>{111} directions. Sorted according to Eisenlohr & Hantcherli + + character(len=*), dimension(2), parameter, private :: LATTICE_FCC_SLIPFAMILY_NAME = & + ['<0 1 -1>{1 1 1}', & + '<0 1 -1>{0 1 1}'] + + real(pReal), dimension(3+3,LATTICE_FCC_NTWIN), parameter, private :: & + LATTICE_FCC_SYSTEMTWIN = reshape(real( [& + -2, 1, 1, 1, 1, 1, & + 1,-2, 1, 1, 1, 1, & + 1, 1,-2, 1, 1, 1, & + 2,-1, 1, -1,-1, 1, & + -1, 2, 1, -1,-1, 1, & + -1,-1,-2, -1,-1, 1, & + -2,-1,-1, 1,-1,-1, & + 1, 2,-1, 1,-1,-1, & + 1,-1, 2, 1,-1,-1, & + 2, 1,-1, -1, 1,-1, & + -1,-2,-1, -1, 1,-1, & + -1, 1, 2, -1, 1,-1 & + ],pReal),shape(LATTICE_FCC_SYSTEMTWIN)) !< Twin system <112>{111} directions. Sorted according to Eisenlohr & Hantcherli + + character(len=*), dimension(1), parameter, private :: LATTICE_FCC_TWINFAMILY_NAME = & + ['<-2 1 1>{1 1 1}'] + + + integer, dimension(2,LATTICE_FCC_NTWIN), parameter, public :: & + LATTICE_FCC_TWINNUCLEATIONSLIPPAIR = reshape( [& + 2,3, & + 1,3, & + 1,2, & + 5,6, & + 4,6, & + 4,5, & + 8,9, & + 7,9, & + 7,8, & + 11,12, & + 10,12, & + 10,11 & + ],shape(LATTICE_FCC_TWINNUCLEATIONSLIPPAIR)) + + real(pReal), dimension(3+3,LATTICE_FCC_NCLEAVAGE), parameter, private :: & + LATTICE_FCC_SYSTEMCLEAVAGE = reshape(real([& + ! Cleavage direction Plane normal + 0, 1, 0, 1, 0, 0, & + 0, 0, 1, 0, 1, 0, & + 1, 0, 0, 0, 0, 1, & + 0, 1,-1, 1, 1, 1, & + 0,-1,-1, -1,-1, 1, & + -1, 0,-1, 1,-1,-1, & + 0, 1, 1, -1, 1,-1 & + ],pReal),shape(LATTICE_FCC_SYSTEMCLEAVAGE)) + !-------------------------------------------------------------------------------------------------- ! body centered cubic - integer, dimension(2), parameter, private :: & - LATTICE_BCC_NSLIPSYSTEM = [12, 12] !< # of slip systems per family for bcc - - integer, dimension(1), parameter, private :: & - LATTICE_BCC_NTWINSYSTEM = [12] !< # of twin systems per family for bcc - - integer, dimension(2), parameter, private :: & - LATTICE_BCC_NCLEAVAGESYSTEM = [3, 6] !< # of cleavage systems per family for bcc - - integer, parameter, private :: & - LATTICE_BCC_NSLIP = sum(LATTICE_BCC_NSLIPSYSTEM), & !< total # of slip systems for bcc - LATTICE_BCC_NTWIN = sum(LATTICE_BCC_NTWINSYSTEM), & !< total # of twin systems for bcc - LATTICE_BCC_NCLEAVAGE = sum(LATTICE_BCC_NCLEAVAGESYSTEM) !< total # of cleavage systems for bcc - - real(pReal), dimension(3+3,LATTICE_BCC_NSLIP), parameter, private :: & - LATTICE_BCC_SYSTEMSLIP = reshape(real([& - ! Slip direction Plane normal - ! Slip system <111>{110} - 1,-1, 1, 0, 1, 1, & - -1,-1, 1, 0, 1, 1, & - 1, 1, 1, 0,-1, 1, & - -1, 1, 1, 0,-1, 1, & - -1, 1, 1, 1, 0, 1, & - -1,-1, 1, 1, 0, 1, & - 1, 1, 1, -1, 0, 1, & - 1,-1, 1, -1, 0, 1, & - -1, 1, 1, 1, 1, 0, & - -1, 1,-1, 1, 1, 0, & - 1, 1, 1, -1, 1, 0, & - 1, 1,-1, -1, 1, 0, & - ! Slip system <111>{112} - -1, 1, 1, 2, 1, 1, & - 1, 1, 1, -2, 1, 1, & - 1, 1,-1, 2,-1, 1, & - 1,-1, 1, 2, 1,-1, & - 1,-1, 1, 1, 2, 1, & - 1, 1,-1, -1, 2, 1, & - 1, 1, 1, 1,-2, 1, & - -1, 1, 1, 1, 2,-1, & - 1, 1,-1, 1, 1, 2, & - 1,-1, 1, -1, 1, 2, & - -1, 1, 1, 1,-1, 2, & - 1, 1, 1, 1, 1,-2 & - ],pReal),shape(LATTICE_BCC_SYSTEMSLIP)) - - character(len=*), dimension(2), parameter, private :: LATTICE_BCC_SLIPFAMILY_NAME = & - ['<1 -1 1>{0 1 1}', & - '<1 -1 1>{2 1 1}'] - - real(pReal), dimension(3+3,LATTICE_BCC_NTWIN), parameter, private :: & - LATTICE_BCC_SYSTEMTWIN = reshape(real([& - ! Twin system <111>{112} - -1, 1, 1, 2, 1, 1, & - 1, 1, 1, -2, 1, 1, & - 1, 1,-1, 2,-1, 1, & - 1,-1, 1, 2, 1,-1, & - 1,-1, 1, 1, 2, 1, & - 1, 1,-1, -1, 2, 1, & - 1, 1, 1, 1,-2, 1, & - -1, 1, 1, 1, 2,-1, & - 1, 1,-1, 1, 1, 2, & - 1,-1, 1, -1, 1, 2, & - -1, 1, 1, 1,-1, 2, & - 1, 1, 1, 1, 1,-2 & - ],pReal),shape(LATTICE_BCC_SYSTEMTWIN)) - - character(len=*), dimension(1), parameter, private :: LATTICE_BCC_TWINFAMILY_NAME = & - ['<1 1 1>{2 1 1}'] - - real(pReal), dimension(3+3,LATTICE_BCC_NCLEAVAGE), parameter, private :: & - LATTICE_BCC_SYSTEMCLEAVAGE = reshape(real([& - ! Cleavage direction Plane normal - 0, 1, 0, 1, 0, 0, & - 0, 0, 1, 0, 1, 0, & - 1, 0, 0, 0, 0, 1, & - 1,-1, 1, 0, 1, 1, & - 1, 1, 1, 0,-1, 1, & - -1, 1, 1, 1, 0, 1, & - 1, 1, 1, -1, 0, 1, & - -1, 1, 1, 1, 1, 0, & - 1, 1, 1, -1, 1, 0 & - ],pReal),shape(LATTICE_BCC_SYSTEMCLEAVAGE)) - + integer, dimension(2), parameter, private :: & + LATTICE_BCC_NSLIPSYSTEM = [12, 12] !< # of slip systems per family for bcc + + integer, dimension(1), parameter, private :: & + LATTICE_BCC_NTWINSYSTEM = [12] !< # of twin systems per family for bcc + + integer, dimension(2), parameter, private :: & + LATTICE_BCC_NCLEAVAGESYSTEM = [3, 6] !< # of cleavage systems per family for bcc + + integer, parameter, private :: & + LATTICE_BCC_NSLIP = sum(LATTICE_BCC_NSLIPSYSTEM), & !< total # of slip systems for bcc + LATTICE_BCC_NTWIN = sum(LATTICE_BCC_NTWINSYSTEM), & !< total # of twin systems for bcc + LATTICE_BCC_NCLEAVAGE = sum(LATTICE_BCC_NCLEAVAGESYSTEM) !< total # of cleavage systems for bcc + + real(pReal), dimension(3+3,LATTICE_BCC_NSLIP), parameter, private :: & + LATTICE_BCC_SYSTEMSLIP = reshape(real([& + ! Slip direction Plane normal + ! Slip system <111>{110} + 1,-1, 1, 0, 1, 1, & + -1,-1, 1, 0, 1, 1, & + 1, 1, 1, 0,-1, 1, & + -1, 1, 1, 0,-1, 1, & + -1, 1, 1, 1, 0, 1, & + -1,-1, 1, 1, 0, 1, & + 1, 1, 1, -1, 0, 1, & + 1,-1, 1, -1, 0, 1, & + -1, 1, 1, 1, 1, 0, & + -1, 1,-1, 1, 1, 0, & + 1, 1, 1, -1, 1, 0, & + 1, 1,-1, -1, 1, 0, & + ! Slip system <111>{112} + -1, 1, 1, 2, 1, 1, & + 1, 1, 1, -2, 1, 1, & + 1, 1,-1, 2,-1, 1, & + 1,-1, 1, 2, 1,-1, & + 1,-1, 1, 1, 2, 1, & + 1, 1,-1, -1, 2, 1, & + 1, 1, 1, 1,-2, 1, & + -1, 1, 1, 1, 2,-1, & + 1, 1,-1, 1, 1, 2, & + 1,-1, 1, -1, 1, 2, & + -1, 1, 1, 1,-1, 2, & + 1, 1, 1, 1, 1,-2 & + ],pReal),shape(LATTICE_BCC_SYSTEMSLIP)) + + character(len=*), dimension(2), parameter, private :: LATTICE_BCC_SLIPFAMILY_NAME = & + ['<1 -1 1>{0 1 1}', & + '<1 -1 1>{2 1 1}'] + + real(pReal), dimension(3+3,LATTICE_BCC_NTWIN), parameter, private :: & + LATTICE_BCC_SYSTEMTWIN = reshape(real([& + ! Twin system <111>{112} + -1, 1, 1, 2, 1, 1, & + 1, 1, 1, -2, 1, 1, & + 1, 1,-1, 2,-1, 1, & + 1,-1, 1, 2, 1,-1, & + 1,-1, 1, 1, 2, 1, & + 1, 1,-1, -1, 2, 1, & + 1, 1, 1, 1,-2, 1, & + -1, 1, 1, 1, 2,-1, & + 1, 1,-1, 1, 1, 2, & + 1,-1, 1, -1, 1, 2, & + -1, 1, 1, 1,-1, 2, & + 1, 1, 1, 1, 1,-2 & + ],pReal),shape(LATTICE_BCC_SYSTEMTWIN)) + + character(len=*), dimension(1), parameter, private :: LATTICE_BCC_TWINFAMILY_NAME = & + ['<1 1 1>{2 1 1}'] + + real(pReal), dimension(3+3,LATTICE_BCC_NCLEAVAGE), parameter, private :: & + LATTICE_BCC_SYSTEMCLEAVAGE = reshape(real([& + ! Cleavage direction Plane normal + 0, 1, 0, 1, 0, 0, & + 0, 0, 1, 0, 1, 0, & + 1, 0, 0, 0, 0, 1, & + 1,-1, 1, 0, 1, 1, & + 1, 1, 1, 0,-1, 1, & + -1, 1, 1, 1, 0, 1, & + 1, 1, 1, -1, 0, 1, & + -1, 1, 1, 1, 1, 0, & + 1, 1, 1, -1, 1, 0 & + ],pReal),shape(LATTICE_BCC_SYSTEMCLEAVAGE)) + !-------------------------------------------------------------------------------------------------- ! hexagonal - integer, dimension(6), parameter, private :: & - LATTICE_HEX_NSLIPSYSTEM = [3, 3, 3, 6, 12, 6] !< # of slip systems per family for hex - - integer, dimension(4), parameter, private :: & - LATTICE_HEX_NTWINSYSTEM = [6, 6, 6, 6] !< # of slip systems per family for hex - - integer, dimension(1), parameter, private :: & - LATTICE_HEX_NCLEAVAGESYSTEM = [3] !< # of cleavage systems per family for hex - - integer, parameter, private :: & - LATTICE_HEX_NSLIP = sum(LATTICE_HEX_NSLIPSYSTEM), & !< total # of slip systems for hex - LATTICE_HEX_NTWIN = sum(LATTICE_HEX_NTWINSYSTEM), & !< total # of twin systems for hex - LATTICE_HEX_NCLEAVAGE = sum(LATTICE_HEX_NCLEAVAGESYSTEM) !< total # of cleavage systems for hex - - real(pReal), dimension(4+4,LATTICE_HEX_NSLIP), parameter, private :: & - LATTICE_HEX_SYSTEMSLIP = reshape(real([& - ! Slip direction Plane normal - ! Basal systems <11.0>{00.1} (independent of c/a-ratio, Bravais notation (4 coordinate base)) - 2, -1, -1, 0, 0, 0, 0, 1, & - -1, 2, -1, 0, 0, 0, 0, 1, & - -1, -1, 2, 0, 0, 0, 0, 1, & - ! 1st type prismatic systems <11.0>{10.0} (independent of c/a-ratio) - 2, -1, -1, 0, 0, 1, -1, 0, & - -1, 2, -1, 0, -1, 0, 1, 0, & - -1, -1, 2, 0, 1, -1, 0, 0, & - ! 2nd type prismatic systems <10.0>{11.0} -- a slip; plane normals independent of c/a-ratio - 0, 1, -1, 0, 2, -1, -1, 0, & - -1, 0, 1, 0, -1, 2, -1, 0, & - 1, -1, 0, 0, -1, -1, 2, 0, & - ! 1st type 1st order pyramidal systems <11.0>{-11.1} -- plane normals depend on the c/a-ratio - 2, -1, -1, 0, 0, 1, -1, 1, & - -1, 2, -1, 0, -1, 0, 1, 1, & - -1, -1, 2, 0, 1, -1, 0, 1, & - 1, 1, -2, 0, -1, 1, 0, 1, & - -2, 1, 1, 0, 0, -1, 1, 1, & - 1, -2, 1, 0, 1, 0, -1, 1, & - ! pyramidal system: c+a slip <11.3>{-10.1} -- plane normals depend on the c/a-ratio - 2, -1, -1, 3, -1, 1, 0, 1, & - 1, -2, 1, 3, -1, 1, 0, 1, & - -1, -1, 2, 3, 1, 0, -1, 1, & - -2, 1, 1, 3, 1, 0, -1, 1, & - -1, 2, -1, 3, 0, -1, 1, 1, & - 1, 1, -2, 3, 0, -1, 1, 1, & - -2, 1, 1, 3, 1, -1, 0, 1, & - -1, 2, -1, 3, 1, -1, 0, 1, & - 1, 1, -2, 3, -1, 0, 1, 1, & - 2, -1, -1, 3, -1, 0, 1, 1, & - 1, -2, 1, 3, 0, 1, -1, 1, & - -1, -1, 2, 3, 0, 1, -1, 1, & - ! pyramidal system: c+a slip <11.3>{-1-1.2} -- as for hexagonal ice (Castelnau et al. 1996, similar to twin system found below) - 2, -1, -1, 3, -2, 1, 1, 2, & ! sorted according to similar twin system - -1, 2, -1, 3, 1, -2, 1, 2, & ! <11.3>{-1-1.2} shear = 2((c/a)^2-2)/(3 c/a) - -1, -1, 2, 3, 1, 1, -2, 2, & - -2, 1, 1, 3, 2, -1, -1, 2, & - 1, -2, 1, 3, -1, 2, -1, 2, & - 1, 1, -2, 3, -1, -1, 2, 2 & - ],pReal),shape(LATTICE_HEX_SYSTEMSLIP)) !< slip systems for hex sorted by A. Alankar & P. Eisenlohr - - character(len=*), dimension(6), parameter, private :: LATTICE_HEX_SLIPFAMILY_NAME = & - ['<1 1 . 1>{0 0 . 1} ', & - '<1 1 . 1>{1 0 . 0} ', & - '<1 0 . 0>{1 1 . 0} ', & - '<1 1 . 0>{-1 1 . 1} ', & - '<1 1 . 3>{-1 0 . 1} ', & - '<1 1 . 3>{-1 -1 . 2}'] - - real(pReal), dimension(4+4,LATTICE_HEX_NTWIN), parameter, private :: & - LATTICE_HEX_SYSTEMTWIN = reshape(real([& - ! Compression or Tension =f(twinning shear=f(c/a)) for each metal ! (according to Yoo 1981) - 1, -1, 0, 1, -1, 1, 0, 2, & ! <-10.1>{10.2} shear = (3-(c/a)^2)/(sqrt(3) c/a) - -1, 0, 1, 1, 1, 0, -1, 2, & - 0, 1, -1, 1, 0, -1, 1, 2, & - -1, 1, 0, 1, 1, -1, 0, 2, & - 1, 0, -1, 1, -1, 0, 1, 2, & - 0, -1, 1, 1, 0, 1, -1, 2, & + integer, dimension(6), parameter, private :: & + LATTICE_HEX_NSLIPSYSTEM = [3, 3, 3, 6, 12, 6] !< # of slip systems per family for hex + + integer, dimension(4), parameter, private :: & + LATTICE_HEX_NTWINSYSTEM = [6, 6, 6, 6] !< # of slip systems per family for hex + + integer, dimension(1), parameter, private :: & + LATTICE_HEX_NCLEAVAGESYSTEM = [3] !< # of cleavage systems per family for hex + + integer, parameter, private :: & + LATTICE_HEX_NSLIP = sum(LATTICE_HEX_NSLIPSYSTEM), & !< total # of slip systems for hex + LATTICE_HEX_NTWIN = sum(LATTICE_HEX_NTWINSYSTEM), & !< total # of twin systems for hex + LATTICE_HEX_NCLEAVAGE = sum(LATTICE_HEX_NCLEAVAGESYSTEM) !< total # of cleavage systems for hex + + real(pReal), dimension(4+4,LATTICE_HEX_NSLIP), parameter, private :: & + LATTICE_HEX_SYSTEMSLIP = reshape(real([& + ! Slip direction Plane normal + ! Basal systems <11.0>{00.1} (independent of c/a-ratio, Bravais notation (4 coordinate base)) + 2, -1, -1, 0, 0, 0, 0, 1, & + -1, 2, -1, 0, 0, 0, 0, 1, & + -1, -1, 2, 0, 0, 0, 0, 1, & + ! 1st type prismatic systems <11.0>{10.0} (independent of c/a-ratio) + 2, -1, -1, 0, 0, 1, -1, 0, & + -1, 2, -1, 0, -1, 0, 1, 0, & + -1, -1, 2, 0, 1, -1, 0, 0, & + ! 2nd type prismatic systems <10.0>{11.0} -- a slip; plane normals independent of c/a-ratio + 0, 1, -1, 0, 2, -1, -1, 0, & + -1, 0, 1, 0, -1, 2, -1, 0, & + 1, -1, 0, 0, -1, -1, 2, 0, & + ! 1st type 1st order pyramidal systems <11.0>{-11.1} -- plane normals depend on the c/a-ratio + 2, -1, -1, 0, 0, 1, -1, 1, & + -1, 2, -1, 0, -1, 0, 1, 1, & + -1, -1, 2, 0, 1, -1, 0, 1, & + 1, 1, -2, 0, -1, 1, 0, 1, & + -2, 1, 1, 0, 0, -1, 1, 1, & + 1, -2, 1, 0, 1, 0, -1, 1, & + ! pyramidal system: c+a slip <11.3>{-10.1} -- plane normals depend on the c/a-ratio + 2, -1, -1, 3, -1, 1, 0, 1, & + 1, -2, 1, 3, -1, 1, 0, 1, & + -1, -1, 2, 3, 1, 0, -1, 1, & + -2, 1, 1, 3, 1, 0, -1, 1, & + -1, 2, -1, 3, 0, -1, 1, 1, & + 1, 1, -2, 3, 0, -1, 1, 1, & + -2, 1, 1, 3, 1, -1, 0, 1, & + -1, 2, -1, 3, 1, -1, 0, 1, & + 1, 1, -2, 3, -1, 0, 1, 1, & + 2, -1, -1, 3, -1, 0, 1, 1, & + 1, -2, 1, 3, 0, 1, -1, 1, & + -1, -1, 2, 3, 0, 1, -1, 1, & + ! pyramidal system: c+a slip <11.3>{-1-1.2} -- as for hexagonal ice (Castelnau et al. 1996, similar to twin system found below) + 2, -1, -1, 3, -2, 1, 1, 2, & ! sorted according to similar twin system + -1, 2, -1, 3, 1, -2, 1, 2, & ! <11.3>{-1-1.2} shear = 2((c/a)^2-2)/(3 c/a) + -1, -1, 2, 3, 1, 1, -2, 2, & + -2, 1, 1, 3, 2, -1, -1, 2, & + 1, -2, 1, 3, -1, 2, -1, 2, & + 1, 1, -2, 3, -1, -1, 2, 2 & + ],pReal),shape(LATTICE_HEX_SYSTEMSLIP)) !< slip systems for hex sorted by A. Alankar & P. Eisenlohr + + character(len=*), dimension(6), parameter, private :: LATTICE_HEX_SLIPFAMILY_NAME = & + ['<1 1 . 1>{0 0 . 1} ', & + '<1 1 . 1>{1 0 . 0} ', & + '<1 0 . 0>{1 1 . 0} ', & + '<1 1 . 0>{-1 1 . 1} ', & + '<1 1 . 3>{-1 0 . 1} ', & + '<1 1 . 3>{-1 -1 . 2}'] + + real(pReal), dimension(4+4,LATTICE_HEX_NTWIN), parameter, private :: & + LATTICE_HEX_SYSTEMTWIN = reshape(real([& + ! Compression or Tension =f(twinning shear=f(c/a)) for each metal ! (according to Yoo 1981) + 1, -1, 0, 1, -1, 1, 0, 2, & ! <-10.1>{10.2} shear = (3-(c/a)^2)/(sqrt(3) c/a) + -1, 0, 1, 1, 1, 0, -1, 2, & + 0, 1, -1, 1, 0, -1, 1, 2, & + -1, 1, 0, 1, 1, -1, 0, 2, & + 1, 0, -1, 1, -1, 0, 1, 2, & + 0, -1, 1, 1, 0, 1, -1, 2, & ! - 2, -1, -1, 6, -2, 1, 1, 1, & ! <11.6>{-1-1.1} shear = 1/(c/a) - -1, 2, -1, 6, 1, -2, 1, 1, & - -1, -1, 2, 6, 1, 1, -2, 1, & - -2, 1, 1, 6, 2, -1, -1, 1, & - 1, -2, 1, 6, -1, 2, -1, 1, & - 1, 1, -2, 6, -1, -1, 2, 1, & + 2, -1, -1, 6, -2, 1, 1, 1, & ! <11.6>{-1-1.1} shear = 1/(c/a) + -1, 2, -1, 6, 1, -2, 1, 1, & + -1, -1, 2, 6, 1, 1, -2, 1, & + -2, 1, 1, 6, 2, -1, -1, 1, & + 1, -2, 1, 6, -1, 2, -1, 1, & + 1, 1, -2, 6, -1, -1, 2, 1, & ! - -1, 1, 0, -2, -1, 1, 0, 1, & !! <10.-2>{10.1} shear = (4(c/a)^2-9)/(4 sqrt(3) c/a) - 1, 0, -1, -2, 1, 0, -1, 1, & - 0, -1, 1, -2, 0, -1, 1, 1, & - 1, -1, 0, -2, 1, -1, 0, 1, & - -1, 0, 1, -2, -1, 0, 1, 1, & - 0, 1, -1, -2, 0, 1, -1, 1, & + -1, 1, 0, -2, -1, 1, 0, 1, & !! <10.-2>{10.1} shear = (4(c/a)^2-9)/(4 sqrt(3) c/a) + 1, 0, -1, -2, 1, 0, -1, 1, & + 0, -1, 1, -2, 0, -1, 1, 1, & + 1, -1, 0, -2, 1, -1, 0, 1, & + -1, 0, 1, -2, -1, 0, 1, 1, & + 0, 1, -1, -2, 0, 1, -1, 1, & ! - 2, -1, -1, -3, 2, -1, -1, 2, & ! <11.-3>{11.2} shear = 2((c/a)^2-2)/(3 c/a) - -1, 2, -1, -3, -1, 2, -1, 2, & - -1, -1, 2, -3, -1, -1, 2, 2, & - -2, 1, 1, -3, -2, 1, 1, 2, & - 1, -2, 1, -3, 1, -2, 1, 2, & - 1, 1, -2, -3, 1, 1, -2, 2 & - ],pReal),shape(LATTICE_HEX_SYSTEMTWIN)) !< twin systems for hex, order follows Prof. Tom Bieler's scheme - - character(len=*), dimension(4), parameter, private :: LATTICE_HEX_TWINFAMILY_NAME = & - ['<-1 0 . 1>{1 0 . 2} ', & - '<1 1 . 6>{-1 -1 . 1}', & - '<1 0 . -2>{1 0 . 1} ', & - '<1 1 . -3>{1 1 . 2} '] - - real(pReal), dimension(4+4,LATTICE_HEX_NCLEAVAGE), parameter, private :: & - LATTICE_HEX_SYSTEMCLEAVAGE = reshape(real([& - ! Cleavage direction Plane normal - 2,-1,-1, 0, 0, 0, 0, 1, & - 0, 0, 0, 1, 2,-1,-1, 0, & - 0, 0, 0, 1, 0, 1,-1, 0 & - ],pReal),shape(LATTICE_HEX_SYSTEMCLEAVAGE)) - - + 2, -1, -1, -3, 2, -1, -1, 2, & ! <11.-3>{11.2} shear = 2((c/a)^2-2)/(3 c/a) + -1, 2, -1, -3, -1, 2, -1, 2, & + -1, -1, 2, -3, -1, -1, 2, 2, & + -2, 1, 1, -3, -2, 1, 1, 2, & + 1, -2, 1, -3, 1, -2, 1, 2, & + 1, 1, -2, -3, 1, 1, -2, 2 & + ],pReal),shape(LATTICE_HEX_SYSTEMTWIN)) !< twin systems for hex, order follows Prof. Tom Bieler's scheme + + character(len=*), dimension(4), parameter, private :: LATTICE_HEX_TWINFAMILY_NAME = & + ['<-1 0 . 1>{1 0 . 2} ', & + '<1 1 . 6>{-1 -1 . 1}', & + '<1 0 . -2>{1 0 . 1} ', & + '<1 1 . -3>{1 1 . 2} '] + + real(pReal), dimension(4+4,LATTICE_HEX_NCLEAVAGE), parameter, private :: & + LATTICE_HEX_SYSTEMCLEAVAGE = reshape(real([& + ! Cleavage direction Plane normal + 2,-1,-1, 0, 0, 0, 0, 1, & + 0, 0, 0, 1, 2,-1,-1, 0, & + 0, 0, 0, 1, 0, 1,-1, 0 & + ],pReal),shape(LATTICE_HEX_SYSTEMCLEAVAGE)) + + !-------------------------------------------------------------------------------------------------- ! body centered tetragonal - integer, dimension(13), parameter, private :: & - LATTICE_BCT_NSLIPSYSTEM = [2, 2, 2, 4, 2, 4, 2, 2, 4, 8, 4, 8, 8 ] !< # of slip systems per family for bct (Sn) Bieler J. Electr Mater 2009 - - integer, parameter, private :: & - LATTICE_BCT_NSLIP = sum(LATTICE_BCT_NSLIPSYSTEM) !< total # of slip systems for bct - - real(pReal), dimension(3+3,LATTICE_BCT_NSLIP), parameter, private :: & - LATTICE_BCT_SYSTEMSLIP = reshape(real([& - ! Slip direction Plane normal - ! Slip family 1 {100)<001] (Bravais notation {hkl) @brief Module initialization !-------------------------------------------------------------------------------------------------- subroutine lattice_init - use IO, only: & - IO_error - use config, only: & - config_phase - - implicit none - integer :: Nphases - character(len=65536) :: & - tag = '' - integer :: i,p - real(pReal), dimension(:), allocatable :: & - temp, & - CoverA !< c/a ratio for low symmetry type lattice - - write(6,'(/,a)') ' <<<+- lattice init -+>>>' - - Nphases = size(config_phase) - - allocate(lattice_structure(Nphases),source = LATTICE_undefined_ID) - allocate(trans_lattice_structure(Nphases),source = LATTICE_undefined_ID) - allocate(lattice_C66(6,6,Nphases), source=0.0_pReal) - allocate(lattice_C3333(3,3,3,3,Nphases), source=0.0_pReal) + use IO, only: & + IO_error + use config, only: & + config_phase + + integer :: Nphases + character(len=65536) :: & + tag = '' + integer :: i,p + real(pReal), dimension(:), allocatable :: & + temp, & + CoverA !< c/a ratio for low symmetry type lattice + + write(6,'(/,a)') ' <<<+- lattice init -+>>>' + + Nphases = size(config_phase) + + allocate(lattice_structure(Nphases),source = LATTICE_undefined_ID) + allocate(trans_lattice_structure(Nphases),source = LATTICE_undefined_ID) + allocate(lattice_C66(6,6,Nphases), source=0.0_pReal) + allocate(lattice_C3333(3,3,3,3,Nphases), source=0.0_pReal) + + allocate(lattice_thermalExpansion33 (3,3,3,Nphases), source=0.0_pReal) ! constant, linear, quadratic coefficients + allocate(lattice_thermalConductivity33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_damageDiffusion33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_damageMobility ( Nphases), source=0.0_pReal) + allocate(lattice_massDensity ( Nphases), source=0.0_pReal) + allocate(lattice_specificHeat ( Nphases), source=0.0_pReal) + allocate(lattice_referenceTemperature ( Nphases), source=300.0_pReal) + + allocate(lattice_mu(Nphases), source=0.0_pReal) + allocate(lattice_nu(Nphases), source=0.0_pReal) + + + allocate(lattice_Scleavage(3,3,3,lattice_maxNcleavage,Nphases),source=0.0_pReal) + allocate(lattice_NcleavageSystem(lattice_maxNcleavageFamily,Nphases),source=0) + + allocate(CoverA(Nphases),source=0.0_pReal) + + do p = 1, size(config_phase) + tag = config_phase(p)%getString('lattice_structure') + select case(trim(tag(1:3))) + case('iso') + lattice_structure(p) = LATTICE_iso_ID + case('fcc') + lattice_structure(p) = LATTICE_fcc_ID + case('bcc') + lattice_structure(p) = LATTICE_bcc_ID + case('hex') + lattice_structure(p) = LATTICE_hex_ID + case('bct') + lattice_structure(p) = LATTICE_bct_ID + case('ort') + lattice_structure(p) = LATTICE_ort_ID + end select + + tag = 'undefined' + tag = config_phase(p)%getString('trans_lattice_structure',defaultVal=tag) + select case(trim(tag)) + case('bcc') + trans_lattice_structure(p) = LATTICE_bcc_ID + case('hex','hexagonal') + trans_lattice_structure(p) = LATTICE_hex_ID + end select + + lattice_C66(1,1,p) = config_phase(p)%getFloat('c11',defaultVal=0.0_pReal) + lattice_C66(1,2,p) = config_phase(p)%getFloat('c12',defaultVal=0.0_pReal) + lattice_C66(1,3,p) = config_phase(p)%getFloat('c13',defaultVal=0.0_pReal) + lattice_C66(2,2,p) = config_phase(p)%getFloat('c22',defaultVal=0.0_pReal) + lattice_C66(2,3,p) = config_phase(p)%getFloat('c23',defaultVal=0.0_pReal) + lattice_C66(3,3,p) = config_phase(p)%getFloat('c33',defaultVal=0.0_pReal) + lattice_C66(4,4,p) = config_phase(p)%getFloat('c44',defaultVal=0.0_pReal) + lattice_C66(5,5,p) = config_phase(p)%getFloat('c55',defaultVal=0.0_pReal) + lattice_C66(6,6,p) = config_phase(p)%getFloat('c66',defaultVal=0.0_pReal) + + + CoverA(p) = config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal) + + lattice_thermalConductivity33(1,1,p) = config_phase(p)%getFloat('thermal_conductivity11',defaultVal=0.0_pReal) + lattice_thermalConductivity33(2,2,p) = config_phase(p)%getFloat('thermal_conductivity22',defaultVal=0.0_pReal) + lattice_thermalConductivity33(3,3,p) = config_phase(p)%getFloat('thermal_conductivity33',defaultVal=0.0_pReal) + + temp = config_phase(p)%getFloats('thermal_expansion11',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) + lattice_thermalExpansion33(1,1,1:size(temp),p) = temp + temp = config_phase(p)%getFloats('thermal_expansion22',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) + lattice_thermalExpansion33(2,2,1:size(temp),p) = temp + temp = config_phase(p)%getFloats('thermal_expansion33',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) + lattice_thermalExpansion33(3,3,1:size(temp),p) = temp + + lattice_specificHeat(p) = config_phase(p)%getFloat( 'specific_heat',defaultVal=0.0_pReal) + lattice_massDensity(p) = config_phase(p)%getFloat( 'mass_density',defaultVal=0.0_pReal) + lattice_referenceTemperature(p) = config_phase(p)%getFloat( 'reference_temperature',defaultVal=0.0_pReal) + lattice_DamageDiffusion33(1,1,p) = config_phase(p)%getFloat( 'damage_diffusion11',defaultVal=0.0_pReal) + lattice_DamageDiffusion33(2,2,p) = config_phase(p)%getFloat( 'damage_diffusion22',defaultVal=0.0_pReal) + lattice_DamageDiffusion33(3,3,p) = config_phase(p)%getFloat( 'damage_diffusion33',defaultVal=0.0_pReal) + lattice_DamageMobility(p) = config_phase(p)%getFloat( 'damage_mobility',defaultVal=0.0_pReal) + enddo + + do i = 1,Nphases + if ((CoverA(i) < 1.0_pReal .or. CoverA(i) > 2.0_pReal) & + .and. lattice_structure(i) == LATTICE_hex_ID) call IO_error(131,el=i) ! checking physical significance of c/a + if ((CoverA(i) > 2.0_pReal) & + .and. lattice_structure(i) == LATTICE_bct_ID) call IO_error(131,el=i) ! checking physical significance of c/a + call lattice_initializeStructure(i, CoverA(i)) + enddo - allocate(lattice_thermalExpansion33 (3,3,3,Nphases), source=0.0_pReal) ! constant, linear, quadratic coefficients - allocate(lattice_thermalConductivity33 (3,3,Nphases), source=0.0_pReal) - allocate(lattice_damageDiffusion33 (3,3,Nphases), source=0.0_pReal) - allocate(lattice_damageMobility ( Nphases), source=0.0_pReal) - allocate(lattice_massDensity ( Nphases), source=0.0_pReal) - allocate(lattice_specificHeat ( Nphases), source=0.0_pReal) - allocate(lattice_referenceTemperature ( Nphases), source=300.0_pReal) - - allocate(lattice_mu(Nphases), source=0.0_pReal) - allocate(lattice_nu(Nphases), source=0.0_pReal) - - - allocate(lattice_Scleavage(3,3,3,lattice_maxNcleavage,Nphases),source=0.0_pReal) - allocate(lattice_NcleavageSystem(lattice_maxNcleavageFamily,Nphases),source=0) - - allocate(CoverA(Nphases),source=0.0_pReal) - - do p = 1, size(config_phase) - tag = config_phase(p)%getString('lattice_structure') - select case(trim(tag)) - case('iso','isotropic') - lattice_structure(p) = LATTICE_iso_ID - case('fcc') - lattice_structure(p) = LATTICE_fcc_ID - case('bcc') - lattice_structure(p) = LATTICE_bcc_ID - case('hex','hexagonal') - lattice_structure(p) = LATTICE_hex_ID - case('bct') - lattice_structure(p) = LATTICE_bct_ID - case('ort','orthorhombic') - lattice_structure(p) = LATTICE_ort_ID - end select - - tag = 'undefined' - tag = config_phase(p)%getString('trans_lattice_structure',defaultVal=tag) - select case(trim(tag)) - case('bcc') - trans_lattice_structure(p) = LATTICE_bcc_ID - case('hex','hexagonal') - trans_lattice_structure(p) = LATTICE_hex_ID - end select - - lattice_C66(1,1,p) = config_phase(p)%getFloat('c11',defaultVal=0.0_pReal) - lattice_C66(1,2,p) = config_phase(p)%getFloat('c12',defaultVal=0.0_pReal) - lattice_C66(1,3,p) = config_phase(p)%getFloat('c13',defaultVal=0.0_pReal) - lattice_C66(2,2,p) = config_phase(p)%getFloat('c22',defaultVal=0.0_pReal) - lattice_C66(2,3,p) = config_phase(p)%getFloat('c23',defaultVal=0.0_pReal) - lattice_C66(3,3,p) = config_phase(p)%getFloat('c33',defaultVal=0.0_pReal) - lattice_C66(4,4,p) = config_phase(p)%getFloat('c44',defaultVal=0.0_pReal) - lattice_C66(5,5,p) = config_phase(p)%getFloat('c55',defaultVal=0.0_pReal) - lattice_C66(6,6,p) = config_phase(p)%getFloat('c66',defaultVal=0.0_pReal) - - - CoverA(p) = config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal) - - lattice_thermalConductivity33(1,1,p) = config_phase(p)%getFloat('thermal_conductivity11',defaultVal=0.0_pReal) - lattice_thermalConductivity33(2,2,p) = config_phase(p)%getFloat('thermal_conductivity22',defaultVal=0.0_pReal) - lattice_thermalConductivity33(3,3,p) = config_phase(p)%getFloat('thermal_conductivity33',defaultVal=0.0_pReal) - - temp = config_phase(p)%getFloats('thermal_expansion11',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) - lattice_thermalExpansion33(1,1,1:size(temp),p) = temp - temp = config_phase(p)%getFloats('thermal_expansion22',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) - lattice_thermalExpansion33(2,2,1:size(temp),p) = temp - temp = config_phase(p)%getFloats('thermal_expansion33',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) - lattice_thermalExpansion33(3,3,1:size(temp),p) = temp - - lattice_specificHeat(p) = config_phase(p)%getFloat( 'specific_heat',defaultVal=0.0_pReal) - lattice_massDensity(p) = config_phase(p)%getFloat( 'mass_density',defaultVal=0.0_pReal) - lattice_referenceTemperature(p) = config_phase(p)%getFloat( 'reference_temperature',defaultVal=0.0_pReal) - lattice_DamageDiffusion33(1,1,p) = config_phase(p)%getFloat( 'damage_diffusion11',defaultVal=0.0_pReal) - lattice_DamageDiffusion33(2,2,p) = config_phase(p)%getFloat( 'damage_diffusion22',defaultVal=0.0_pReal) - lattice_DamageDiffusion33(3,3,p) = config_phase(p)%getFloat( 'damage_diffusion33',defaultVal=0.0_pReal) - lattice_DamageMobility(p) = config_phase(p)%getFloat( 'damage_mobility',defaultVal=0.0_pReal) - enddo - - do i = 1,Nphases - if ((CoverA(i) < 1.0_pReal .or. CoverA(i) > 2.0_pReal) & - .and. lattice_structure(i) == LATTICE_hex_ID) call IO_error(131,el=i) ! checking physical significance of c/a - if ((CoverA(i) > 2.0_pReal) & - .and. lattice_structure(i) == LATTICE_bct_ID) call IO_error(131,el=i) ! checking physical significance of c/a - call lattice_initializeStructure(i, CoverA(i)) - enddo - end subroutine lattice_init - - + + !-------------------------------------------------------------------------------------------------- !> @brief !!!!!!!DEPRECTATED!!!!!! !-------------------------------------------------------------------------------------------------- subroutine lattice_initializeStructure(myPhase,CoverA) - use prec, only: & - tol_math_check - use math, only: & - math_sym3333to66, & - math_Voigt66to3333, & - math_cross - use IO, only: & - IO_error - - implicit none - integer, intent(in) :: myPhase - real(pReal), intent(in) :: & - CoverA - - integer :: & - i, & - myNcleavage - - lattice_C66(1:6,1:6,myPhase) = lattice_symmetrizeC66(lattice_structure(myPhase),& - lattice_C66(1:6,1:6,myPhase)) - - lattice_mu(myPhase) = 0.2_pReal *( lattice_C66(1,1,myPhase) & - - lattice_C66(1,2,myPhase) & - + 3.0_pReal*lattice_C66(4,4,myPhase)) ! (C11iso-C12iso)/2 with C11iso=(3*C11+2*C12+4*C44)/5 and C12iso=(C11+4*C12-2*C44)/5 - lattice_nu(myPhase) = ( lattice_C66(1,1,myPhase) & - + 4.0_pReal*lattice_C66(1,2,myPhase) & - - 2.0_pReal*lattice_C66(4,4,myPhase)) & - /( 4.0_pReal*lattice_C66(1,1,myPhase) & - + 6.0_pReal*lattice_C66(1,2,myPhase) & - + 2.0_pReal*lattice_C66(4,4,myPhase))! C12iso/(C11iso+C12iso) with C11iso=(3*C11+2*C12+4*C44)/5 and C12iso=(C11+4*C12-2*C44)/5 - lattice_C3333(1:3,1:3,1:3,1:3,myPhase) = math_Voigt66to3333(lattice_C66(1:6,1:6,myPhase)) ! Literature data is Voigt - lattice_C66(1:6,1:6,myPhase) = math_sym3333to66(lattice_C3333(1:3,1:3,1:3,1:3,myPhase)) ! DAMASK uses Mandel-weighting - do i = 1, 6 - if (abs(lattice_C66(i,i,myPhase)) @brief Symmetrizes stiffness matrix according to lattice type !> @details J. A. Rayne and B. S. Chandrasekhar Phys. Rev. 120, 1658 Erratum Phys. Rev. 122, 1962 !-------------------------------------------------------------------------------------------------- pure function lattice_symmetrizeC66(struct,C66) - - implicit none - integer(kind(LATTICE_undefined_ID)), intent(in) :: struct - real(pReal), dimension(6,6), intent(in) :: C66 - real(pReal), dimension(6,6) :: lattice_symmetrizeC66 - integer :: j,k - - lattice_symmetrizeC66 = 0.0_pReal - - select case(struct) - case (LATTICE_iso_ID) - forall(k=1:3) - forall(j=1:3) lattice_symmetrizeC66(k,j) = C66(1,2) - lattice_symmetrizeC66(k,k) = C66(1,1) - lattice_symmetrizeC66(k+3,k+3) = 0.5_pReal*(C66(1,1)-C66(1,2)) - end forall - case (LATTICE_fcc_ID,LATTICE_bcc_ID) - forall(k=1:3) - forall(j=1:3) lattice_symmetrizeC66(k,j) = C66(1,2) - lattice_symmetrizeC66(k,k) = C66(1,1) - lattice_symmetrizeC66(k+3,k+3) = C66(4,4) - end forall - case (LATTICE_hex_ID) - lattice_symmetrizeC66(1,1) = C66(1,1) - lattice_symmetrizeC66(2,2) = C66(1,1) - lattice_symmetrizeC66(3,3) = C66(3,3) - lattice_symmetrizeC66(1,2) = C66(1,2) - lattice_symmetrizeC66(2,1) = C66(1,2) - lattice_symmetrizeC66(1,3) = C66(1,3) - lattice_symmetrizeC66(3,1) = C66(1,3) - lattice_symmetrizeC66(2,3) = C66(1,3) - lattice_symmetrizeC66(3,2) = C66(1,3) - lattice_symmetrizeC66(4,4) = C66(4,4) - lattice_symmetrizeC66(5,5) = C66(4,4) - lattice_symmetrizeC66(6,6) = 0.5_pReal*(C66(1,1)-C66(1,2)) - case (LATTICE_ort_ID) - lattice_symmetrizeC66(1,1) = C66(1,1) - lattice_symmetrizeC66(2,2) = C66(2,2) - lattice_symmetrizeC66(3,3) = C66(3,3) - lattice_symmetrizeC66(1,2) = C66(1,2) - lattice_symmetrizeC66(2,1) = C66(1,2) - lattice_symmetrizeC66(1,3) = C66(1,3) - lattice_symmetrizeC66(3,1) = C66(1,3) - lattice_symmetrizeC66(2,3) = C66(2,3) - lattice_symmetrizeC66(3,2) = C66(2,3) - lattice_symmetrizeC66(4,4) = C66(4,4) - lattice_symmetrizeC66(5,5) = C66(5,5) - lattice_symmetrizeC66(6,6) = C66(6,6) - case (LATTICE_bct_ID) - lattice_symmetrizeC66(1,1) = C66(1,1) - lattice_symmetrizeC66(2,2) = C66(1,1) - lattice_symmetrizeC66(3,3) = C66(3,3) - lattice_symmetrizeC66(1,2) = C66(1,2) - lattice_symmetrizeC66(2,1) = C66(1,2) - lattice_symmetrizeC66(1,3) = C66(1,3) - lattice_symmetrizeC66(3,1) = C66(1,3) - lattice_symmetrizeC66(2,3) = C66(1,3) - lattice_symmetrizeC66(3,2) = C66(1,3) - lattice_symmetrizeC66(4,4) = C66(4,4) - lattice_symmetrizeC66(5,5) = C66(4,4) - lattice_symmetrizeC66(6,6) = C66(6,6) - case default - lattice_symmetrizeC66 = C66 - end select - - end function lattice_symmetrizeC66 - - + + integer(kind(LATTICE_undefined_ID)), intent(in) :: struct + real(pReal), dimension(6,6), intent(in) :: C66 + real(pReal), dimension(6,6) :: lattice_symmetrizeC66 + integer :: j,k + + lattice_symmetrizeC66 = 0.0_pReal + + select case(struct) + case (LATTICE_iso_ID) + forall(k=1:3) + forall(j=1:3) lattice_symmetrizeC66(k,j) = C66(1,2) + lattice_symmetrizeC66(k,k) = C66(1,1) + lattice_symmetrizeC66(k+3,k+3) = 0.5_pReal*(C66(1,1)-C66(1,2)) + end forall + case (LATTICE_fcc_ID,LATTICE_bcc_ID) + forall(k=1:3) + forall(j=1:3) lattice_symmetrizeC66(k,j) = C66(1,2) + lattice_symmetrizeC66(k,k) = C66(1,1) + lattice_symmetrizeC66(k+3,k+3) = C66(4,4) + end forall + case (LATTICE_hex_ID) + lattice_symmetrizeC66(1,1) = C66(1,1) + lattice_symmetrizeC66(2,2) = C66(1,1) + lattice_symmetrizeC66(3,3) = C66(3,3) + lattice_symmetrizeC66(1,2) = C66(1,2) + lattice_symmetrizeC66(2,1) = C66(1,2) + lattice_symmetrizeC66(1,3) = C66(1,3) + lattice_symmetrizeC66(3,1) = C66(1,3) + lattice_symmetrizeC66(2,3) = C66(1,3) + lattice_symmetrizeC66(3,2) = C66(1,3) + lattice_symmetrizeC66(4,4) = C66(4,4) + lattice_symmetrizeC66(5,5) = C66(4,4) + lattice_symmetrizeC66(6,6) = 0.5_pReal*(C66(1,1)-C66(1,2)) + case (LATTICE_ort_ID) + lattice_symmetrizeC66(1,1) = C66(1,1) + lattice_symmetrizeC66(2,2) = C66(2,2) + lattice_symmetrizeC66(3,3) = C66(3,3) + lattice_symmetrizeC66(1,2) = C66(1,2) + lattice_symmetrizeC66(2,1) = C66(1,2) + lattice_symmetrizeC66(1,3) = C66(1,3) + lattice_symmetrizeC66(3,1) = C66(1,3) + lattice_symmetrizeC66(2,3) = C66(2,3) + lattice_symmetrizeC66(3,2) = C66(2,3) + lattice_symmetrizeC66(4,4) = C66(4,4) + lattice_symmetrizeC66(5,5) = C66(5,5) + lattice_symmetrizeC66(6,6) = C66(6,6) + case (LATTICE_bct_ID) + lattice_symmetrizeC66(1,1) = C66(1,1) + lattice_symmetrizeC66(2,2) = C66(1,1) + lattice_symmetrizeC66(3,3) = C66(3,3) + lattice_symmetrizeC66(1,2) = C66(1,2) + lattice_symmetrizeC66(2,1) = C66(1,2) + lattice_symmetrizeC66(1,3) = C66(1,3) + lattice_symmetrizeC66(3,1) = C66(1,3) + lattice_symmetrizeC66(2,3) = C66(1,3) + lattice_symmetrizeC66(3,2) = C66(1,3) + lattice_symmetrizeC66(4,4) = C66(4,4) + lattice_symmetrizeC66(5,5) = C66(4,4) + lattice_symmetrizeC66(6,6) = C66(6,6) + case default + lattice_symmetrizeC66 = C66 + end select + +end function lattice_symmetrizeC66 + + !-------------------------------------------------------------------------------------------------- !> @brief Symmetrizes 2nd order tensor according to lattice type !-------------------------------------------------------------------------------------------------- pure function lattice_symmetrize33(struct,T33) - - implicit none - integer(kind(LATTICE_undefined_ID)), intent(in) :: struct - real(pReal), dimension(3,3), intent(in) :: T33 - real(pReal), dimension(3,3) :: lattice_symmetrize33 - integer :: k - - lattice_symmetrize33 = 0.0_pReal - - select case(struct) - case (LATTICE_iso_ID,LATTICE_fcc_ID,LATTICE_bcc_ID) - forall(k=1:3) lattice_symmetrize33(k,k) = T33(1,1) - case (LATTICE_hex_ID) - lattice_symmetrize33(1,1) = T33(1,1) - lattice_symmetrize33(2,2) = T33(1,1) - lattice_symmetrize33(3,3) = T33(3,3) - case (LATTICE_ort_ID,lattice_bct_ID) - lattice_symmetrize33(1,1) = T33(1,1) - lattice_symmetrize33(2,2) = T33(2,2) - lattice_symmetrize33(3,3) = T33(3,3) - case default - lattice_symmetrize33 = T33 - end select - - end function lattice_symmetrize33 - - + + integer(kind(LATTICE_undefined_ID)), intent(in) :: struct + real(pReal), dimension(3,3), intent(in) :: T33 + real(pReal), dimension(3,3) :: lattice_symmetrize33 + integer :: k + + lattice_symmetrize33 = 0.0_pReal + + select case(struct) + case (LATTICE_iso_ID,LATTICE_fcc_ID,LATTICE_bcc_ID) + forall(k=1:3) lattice_symmetrize33(k,k) = T33(1,1) + case (LATTICE_hex_ID) + lattice_symmetrize33(1,1) = T33(1,1) + lattice_symmetrize33(2,2) = T33(1,1) + lattice_symmetrize33(3,3) = T33(3,3) + case (LATTICE_ort_ID,lattice_bct_ID) + lattice_symmetrize33(1,1) = T33(1,1) + lattice_symmetrize33(2,2) = T33(2,2) + lattice_symmetrize33(3,3) = T33(3,3) + case default + lattice_symmetrize33 = T33 + end select + +end function lattice_symmetrize33 + + !-------------------------------------------------------------------------------------------------- !> @brief figures whether unit quat falls into stereographic standard triangle !-------------------------------------------------------------------------------------------------- logical pure function lattice_qInSST(Q, struct) - use, intrinsic :: & - IEEE_arithmetic - use math, only: & - math_qToRodrig - - implicit none - real(pReal), dimension(4), intent(in) :: Q ! orientation - integer(kind(LATTICE_undefined_ID)), intent(in) :: struct ! lattice structure - real(pReal), dimension(3) :: Rodrig ! Rodrigues vector of Q - - Rodrig = math_qToRodrig(Q) - if (any(IEEE_is_NaN(Rodrig))) then - lattice_qInSST = .false. - else - select case (struct) - case (LATTICE_bcc_ID,LATTICE_fcc_ID) - lattice_qInSST = Rodrig(1) > Rodrig(2) .and. & - Rodrig(2) > Rodrig(3) .and. & - Rodrig(3) > 0.0_pReal - case (LATTICE_hex_ID) - lattice_qInSST = Rodrig(1) > sqrt(3.0_pReal)*Rodrig(2) .and. & - Rodrig(2) > 0.0_pReal .and. & - Rodrig(3) > 0.0_pReal - case default - lattice_qInSST = .true. - end select - endif - + use, intrinsic :: & + IEEE_arithmetic + use math, only: & + math_qToRodrig + + real(pReal), dimension(4), intent(in) :: Q ! orientation + integer(kind(LATTICE_undefined_ID)), intent(in) :: struct ! lattice structure + real(pReal), dimension(3) :: Rodrig ! Rodrigues vector of Q + + Rodrig = math_qToRodrig(Q) + if (any(IEEE_is_NaN(Rodrig))) then + lattice_qInSST = .false. + else + select case (struct) + case (LATTICE_bcc_ID,LATTICE_fcc_ID) + lattice_qInSST = Rodrig(1) > Rodrig(2) .and. & + Rodrig(2) > Rodrig(3) .and. & + Rodrig(3) > 0.0_pReal + case (LATTICE_hex_ID) + lattice_qInSST = Rodrig(1) > sqrt(3.0_pReal)*Rodrig(2) .and. & + Rodrig(2) > 0.0_pReal .and. & + Rodrig(3) > 0.0_pReal + case default + lattice_qInSST = .true. + end select + endif + end function lattice_qInSST - - + + !-------------------------------------------------------------------------------------------------- !> @brief calculates the disorientation for 2 unit quaternions !-------------------------------------------------------------------------------------------------- pure function lattice_qDisorientation(Q1, Q2, struct) - use prec, only: & - tol_math_check - use math, only: & - math_qMul, & - math_qConj - - implicit none - real(pReal), dimension(4) :: lattice_qDisorientation - real(pReal), dimension(4), intent(in) :: & - Q1, & ! 1st orientation - Q2 ! 2nd orientation - integer(kind(LATTICE_undefined_ID)), optional, intent(in) :: & ! if given, symmetries between the two orientation will be considered - struct - - real(pReal), dimension(4) :: dQ,dQsymA,mis - integer :: i,j,k,s,symmetry - integer(kind(LATTICE_undefined_ID)) :: myStruct - - integer, dimension(2), parameter :: & - NsymOperations = [24,12] - -real(pReal), dimension(4,36), parameter :: & - symOperations = reshape([& - 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! cubic symmetry operations - 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), & ! 2-fold symmetry - 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & ! 3-fold symmetry - -0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & - 0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & - -0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & - 0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & - -0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & - 0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & - -0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & - 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & ! 4-fold symmetry - 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & - -1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & - 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & - -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal, & - -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & -! - 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! hexagonal symmetry operations - 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & ! 2-fold symmetry - 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & - 0.0_pReal, 0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & - 0.0_pReal, -0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & - 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & - 0.0_pReal, -2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & - 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & ! 6-fold symmetry - -2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & - 0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & - -0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & - 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal & - ],[4,36]) !< Symmetry operations as quaternions 24 for cubic, 12 for hexagonal = 36 - + use prec, only: & + tol_math_check + use math, only: & + math_qMul, & + math_qConj + + real(pReal), dimension(4) :: lattice_qDisorientation + real(pReal), dimension(4), intent(in) :: & + Q1, & !< 1st orientation + Q2 !< 2nd orientation + integer(kind(LATTICE_undefined_ID)), optional, intent(in) :: & !< if given, symmetries between the two orientation will be considered + struct + + real(pReal), dimension(4) :: dQ,dQsymA,mis + integer :: i,j,k,s,symmetry + integer(kind(LATTICE_undefined_ID)) :: myStruct + + integer, dimension(2), parameter :: & + NsymOperations = [24,12] + + real(pReal), dimension(4,36), parameter :: & + symOperations = reshape([& + 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! cubic symmetry operations + 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), & ! 2-fold symmetry + 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & ! 3-fold symmetry + -0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & + 0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & + -0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & + 0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & + -0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & + 0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & + -0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & + 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & ! 4-fold symmetry + 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & + -1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & + 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & + -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal, & + -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + ! + 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! hexagonal symmetry operations + 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & ! 2-fold symmetry + 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & + 0.0_pReal, 0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & + 0.0_pReal, -0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & + 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & + 0.0_pReal, -2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & + 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & ! 6-fold symmetry + -2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & + 0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & + -0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & + 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal & + ],[4,36]) !< Symmetry operations as quaternions 24 for cubic, 12 for hexagonal = 36 + !-------------------------------------------------------------------------------------------------- ! check if a structure with known symmetries is given - if (present(struct)) then - myStruct = struct - select case (struct) - case(LATTICE_fcc_ID,LATTICE_bcc_ID) - symmetry = 1 - case(LATTICE_hex_ID) - symmetry = 2 - case default - symmetry = 0 - end select - else - symmetry = 0 - myStruct = LATTICE_undefined_ID - endif - - + if (present(struct)) then + myStruct = struct + select case (struct) + case(LATTICE_fcc_ID,LATTICE_bcc_ID) + symmetry = 1 + case(LATTICE_hex_ID) + symmetry = 2 + case default + symmetry = 0 + end select + else + symmetry = 0 + myStruct = LATTICE_undefined_ID + endif + + !-------------------------------------------------------------------------------------------------- ! calculate misorientation, for cubic and hexagonal structure find symmetries - dQ = math_qMul(math_qConj(Q1),Q2) - lattice_qDisorientation = dQ - - select case(symmetry) - - case (1,2) - s = sum(NsymOperations(1:symmetry-1)) - do i = 1,2 - dQ = math_qConj(dQ) ! switch order of "from -- to" - do j = 1,NsymOperations(symmetry) ! run through first crystal's symmetries - dQsymA = math_qMul(symOperations(1:4,s+j),dQ) ! apply sym - do k = 1,NsymOperations(symmetry) ! run through 2nd crystal's symmetries - mis = math_qMul(dQsymA,symOperations(1:4,s+k)) ! apply sym - if (mis(1) < 0.0_pReal) & ! want positive angle - mis = -mis - if (mis(1)-lattice_qDisorientation(1) > -tol_math_check & - .and. lattice_qInSST(mis,LATTICE_undefined_ID)) lattice_qDisorientation = mis ! found better one - enddo; enddo; enddo - case (0) - if (lattice_qDisorientation(1) < 0.0_pReal) lattice_qDisorientation = -lattice_qDisorientation ! keep omega within 0 to 180 deg - end select - + dQ = math_qMul(math_qConj(Q1),Q2) + lattice_qDisorientation = dQ + + select case(symmetry) + + case (1,2) + s = sum(NsymOperations(1:symmetry-1)) + do i = 1,2 + dQ = math_qConj(dQ) ! switch order of "from -- to" + do j = 1,NsymOperations(symmetry) ! run through first crystal's symmetries + dQsymA = math_qMul(symOperations(1:4,s+j),dQ) ! apply sym + do k = 1,NsymOperations(symmetry) ! run through 2nd crystal's symmetries + mis = math_qMul(dQsymA,symOperations(1:4,s+k)) ! apply sym + if (mis(1) < 0.0_pReal) & ! want positive angle + mis = -mis + if (mis(1)-lattice_qDisorientation(1) > -tol_math_check & + .and. lattice_qInSST(mis,LATTICE_undefined_ID)) lattice_qDisorientation = mis ! found better one + enddo; enddo; enddo + case (0) + if (lattice_qDisorientation(1) < 0.0_pReal) lattice_qDisorientation = -lattice_qDisorientation ! keep omega within 0 to 180 deg + end select + end function lattice_qDisorientation - - + + !-------------------------------------------------------------------------------------------------- !> @brief Characteristic shear for twinning !-------------------------------------------------------------------------------------------------- function lattice_characteristicShear_Twin(Ntwin,structure,CoverA) result(characteristicShear) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(sum(Ntwin)) :: characteristicShear + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(sum(Ntwin)) :: characteristicShear + + integer :: & + a, & !< index of active system + c, & !< index in complete system list + mf, & !< index of my family + ms !< index of my system in current family + + integer, dimension(LATTICE_HEX_NTWIN), parameter :: & + HEX_SHEARTWIN = reshape( [& + 1, & ! <-10.1>{10.2} + 1, & + 1, & + 1, & + 1, & + 1, & + 2, & ! <11.6>{-1-1.1} + 2, & + 2, & + 2, & + 2, & + 2, & + 3, & ! <10.-2>{10.1} + 3, & + 3, & + 3, & + 3, & + 3, & + 4, & ! <11.-3>{11.2} + 4, & + 4, & + 4, & + 4, & + 4 & + ],[LATTICE_HEX_NTWIN]) ! indicator to formulas below + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure)) + + a = 0 + myFamilies: do mf = 1,size(Ntwin,1) + mySystems: do ms = 1,Ntwin(mf) + a = a + 1 + select case(structure(1:3)) + case('fcc','bcc') + characteristicShear(a) = 0.5_pReal*sqrt(2.0_pReal) + case('hex') + if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & + call IO_error(131,ext_msg='lattice_characteristicShear_Twin') + c = sum(LATTICE_HEX_NTWINSYSTEM(1:mf-1))+ms + select case(HEX_SHEARTWIN(c)) ! from Christian & Mahajan 1995 p.29 + case (1) ! <-10.1>{10.2} + characteristicShear(a) = (3.0_pReal-cOverA**2.0_pReal)/sqrt(3.0_pReal)/CoverA + case (2) ! <11.6>{-1-1.1} + characteristicShear(a) = 1.0_pReal/cOverA + case (3) ! <10.-2>{10.1} + characteristicShear(a) = (4.0_pReal*cOverA**2.0_pReal-9.0_pReal)/sqrt(48.0_pReal)/cOverA + case (4) ! <11.-3>{11.2} + characteristicShear(a) = 2.0_pReal*(cOverA**2.0_pReal-2.0_pReal)/3.0_pReal/cOverA + end select + case default + call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure)) + end select + enddo mySystems + enddo myFamilies - integer :: & - a, & !< index of active system - c, & !< index in complete system list - mf, & !< index of my family - ms !< index of my system in current family - - integer, dimension(LATTICE_HEX_NTWIN), parameter :: & - HEX_SHEARTWIN = reshape( [& - 1, & ! <-10.1>{10.2} - 1, & - 1, & - 1, & - 1, & - 1, & - 2, & ! <11.6>{-1-1.1} - 2, & - 2, & - 2, & - 2, & - 2, & - 3, & ! <10.-2>{10.1} - 3, & - 3, & - 3, & - 3, & - 3, & - 4, & ! <11.-3>{11.2} - 4, & - 4, & - 4, & - 4, & - 4 & - ],[LATTICE_HEX_NTWIN]) ! indicator to formulas below - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure)) - - a = 0 - myFamilies: do mf = 1,size(Ntwin,1) - mySystems: do ms = 1,Ntwin(mf) - a = a + 1 - select case(structure(1:3)) - case('fcc','bcc') - characteristicShear(a) = 0.5_pReal*sqrt(2.0_pReal) - case('hex') - if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & - call IO_error(131,ext_msg='lattice_characteristicShear_Twin') - c = sum(LATTICE_HEX_NTWINSYSTEM(1:mf-1))+ms - select case(HEX_SHEARTWIN(c)) ! from Christian & Mahajan 1995 p.29 - case (1) ! <-10.1>{10.2} - characteristicShear(a) = (3.0_pReal-cOverA**2.0_pReal)/sqrt(3.0_pReal)/CoverA - case (2) ! <11.6>{-1-1.1} - characteristicShear(a) = 1.0_pReal/cOverA - case (3) ! <10.-2>{10.1} - characteristicShear(a) = (4.0_pReal*cOverA**2.0_pReal-9.0_pReal)/sqrt(48.0_pReal)/cOverA - case (4) ! <11.-3>{11.2} - characteristicShear(a) = 2.0_pReal*(cOverA**2.0_pReal-2.0_pReal)/3.0_pReal/cOverA - end select - case default - call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure)) - end select - enddo mySystems - enddo myFamilies - end function lattice_characteristicShear_Twin - - + + !-------------------------------------------------------------------------------------------------- !> @brief Rotated elasticity matrices for twinning in 66-vector notation !-------------------------------------------------------------------------------------------------- function lattice_C66_twin(Ntwin,C66,structure,CoverA) - use IO, only: & - IO_error - use math, only: & - PI, & - math_axisAngleToR, & - math_sym3333to66, & - math_66toSym3333, & - math_rotate_forward3333 - - implicit none - integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin - - real(pReal),dimension(3,3,sum(Ntwin)) :: coordinateSystem - real(pReal), dimension(3,3) :: R - integer :: i + use IO, only: & + IO_error + use math, only: & + PI, & + math_axisAngleToR, & + math_sym3333to66, & + math_66toSym3333, & + math_rotate_forward3333 - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_C66_twin: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_FCC_NSLIPSYSTEM,LATTICE_FCC_SYSTEMTWIN,& - trim(structure),0.0_pReal) - case('bcc') - coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMTWIN,& - trim(structure),0.0_pReal) - case('hex') - coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_HEX_NSLIPSYSTEM,LATTICE_HEX_SYSTEMTWIN,& - 'hex',cOverA) - case default - call IO_error(137,ext_msg='lattice_C66_twin: '//trim(structure)) - end select - - do i = 1, sum(Ntwin) - R = math_axisAngleToR(coordinateSystem(1:3,2,i), PI) ! ToDo: Why always 180 deg? - lattice_C66_twin(1:6,1:6,i) = math_sym3333to66(math_rotate_forward3333(math_66toSym3333(C66),R)) - enddo + integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin + + real(pReal),dimension(3,3,sum(Ntwin)) :: coordinateSystem + real(pReal), dimension(3,3) :: R + integer :: i + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_C66_twin: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_FCC_NSLIPSYSTEM,LATTICE_FCC_SYSTEMTWIN,& + trim(structure),0.0_pReal) + case('bcc') + coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMTWIN,& + trim(structure),0.0_pReal) + case('hex') + coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_HEX_NSLIPSYSTEM,LATTICE_HEX_SYSTEMTWIN,& + 'hex',cOverA) + case default + call IO_error(137,ext_msg='lattice_C66_twin: '//trim(structure)) + end select + + do i = 1, sum(Ntwin) + R = math_axisAngleToR(coordinateSystem(1:3,2,i), PI) ! ToDo: Why always 180 deg? + lattice_C66_twin(1:6,1:6,i) = math_sym3333to66(math_rotate_forward3333(math_66toSym3333(C66),R)) + enddo end function lattice_C66_twin - - + + !-------------------------------------------------------------------------------------------------- !> @brief Rotated elasticity matrices for transformation in 66-vector notation !-------------------------------------------------------------------------------------------------- function lattice_C66_trans(Ntrans,C_parent66,structure_target, & CoverA_trans,a_bcc,a_fcc) - use prec, only: & - tol_math_check - use IO, only: & - IO_error - use math, only: & - INRAD, & - MATH_I3, & - math_axisAngleToR, & - math_sym3333to66, & - math_66toSym3333, & - math_rotate_forward3333 - - implicit none - integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family - character(len=*), intent(in) :: structure_target !< lattice structure - real(pReal), dimension(6,6), intent(in) :: C_parent66 - real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans - - real(pReal), dimension(6,6) :: C_bar66, C_target_unrotated66 - real(pReal), dimension(3,3,3,3) :: C_target_unrotated - real(pReal), dimension(3,3,sum(Ntrans)) :: Q,S - real(pReal) :: a_bcc, a_fcc, CoverA_trans - integer :: i - - if (len_trim(structure_target) /= 3) & - call IO_error(137,ext_msg='lattice_C66_trans (target): '//trim(structure_target)) - - !ToDo: add checks for CoverA_trans,a_fcc,a_bcc + use prec, only: & + tol_math_check + use IO, only: & + IO_error + use math, only: & + INRAD, & + MATH_I3, & + math_axisAngleToR, & + math_sym3333to66, & + math_66toSym3333, & + math_rotate_forward3333 + + integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family + character(len=*), intent(in) :: structure_target !< lattice structure + real(pReal), dimension(6,6), intent(in) :: C_parent66 + real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans -!-------------------------------------------------------------------------------------------------- -! elasticity matrix of the target phase in cube orientation - if (structure_target(1:3) == 'hex') then - C_bar66(1,1) = (C_parent66(1,1) + C_parent66(1,2) + 2.0_pReal*C_parent66(4,4))/2.0_pReal - C_bar66(1,2) = (C_parent66(1,1) + 5.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/6.0_pReal - C_bar66(3,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) + 4.0_pReal*C_parent66(4,4))/3.0_pReal - C_bar66(1,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/3.0_pReal - C_bar66(4,4) = (C_parent66(1,1) - C_parent66(1,2) + C_parent66(4,4))/3.0_pReal - C_bar66(1,4) = (C_parent66(1,1) - C_parent66(1,2) - 2.0_pReal*C_parent66(4,4)) /(3.0_pReal*sqrt(2.0_pReal)) - - C_target_unrotated66 = 0.0_pReal - C_target_unrotated66(1,1) = C_bar66(1,1) - C_bar66(1,4)**2.0_pReal/C_bar66(4,4) - C_target_unrotated66(1,2) = C_bar66(1,2) + C_bar66(1,4)**2.0_pReal/C_bar66(4,4) - C_target_unrotated66(1,3) = C_bar66(1,3) - C_target_unrotated66(3,3) = C_bar66(3,3) - C_target_unrotated66(4,4) = C_bar66(4,4) - C_bar66(1,4)**2.0_pReal/(0.5_pReal*(C_bar66(1,1) - C_bar66(1,2))) - C_target_unrotated66 = lattice_symmetrizeC66(LATTICE_HEX_ID,C_target_unrotated66) - elseif (structure_target(1:3) == 'bcc') then - C_target_unrotated66 = C_parent66 - else - call IO_error(137,ext_msg='lattice_C66_trans (target): '//trim(structure_target)) - endif - - - do i = 1, 6 - if (abs(C_target_unrotated66(i,i)) @brief Non-schmid projections for bcc with up to 6 coefficients ! Koester et al. 2012, Acta Materialia 60 (2012) 3894–3901, eq. (17) ! Gröger et al. 2008, Acta Materialia 56 (2008) 5412–5425, table 1 !-------------------------------------------------------------------------------------------------- function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSchmidMatrix) - use IO, only: & - IO_error - use math, only: & - INRAD, & - math_outer, & - math_cross, & - math_axisAngleToR - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: nonSchmidCoefficients !< non-Schmid coefficients for projections - integer, intent(in) :: sense !< sense (-1,+1) - real(pReal), dimension(1:3,1:3,sum(Nslip)) :: nonSchmidMatrix + use IO, only: & + IO_error + use math, only: & + INRAD, & + math_outer, & + math_cross, & + math_axisAngleToR - real(pReal), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem !< coordinate system of slip system - real(pReal), dimension(:), allocatable :: direction, normal, np - integer :: i - - if (abs(sense) /= 1) call IO_error(0,ext_msg='lattice_nonSchmidMatrix') - - coordinateSystem = buildCoordinateSystem(Nslip,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMSLIP,& - 'bcc',0.0_pReal) - coordinateSystem(1:3,1,1:sum(Nslip)) = coordinateSystem(1:3,1,1:sum(Nslip)) *real(sense,pReal) ! convert unidirectional coordinate system - nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'bcc',0.0_pReal) ! Schmid contribution - - do i = 1,sum(Nslip) - direction = coordinateSystem(1:3,1,i) - normal = coordinateSystem(1:3,2,i) - np = matmul(math_axisAngleToR(direction,60.0_pReal*INRAD), normal) - if (size(nonSchmidCoefficients)>0) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(1) * math_outer(direction, np) - if (size(nonSchmidCoefficients)>1) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(2) * math_outer(math_cross(normal, direction), normal) - if (size(nonSchmidCoefficients)>2) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(3) * math_outer(math_cross(np, direction), np) - if (size(nonSchmidCoefficients)>3) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(4) * math_outer(normal, normal) - if (size(nonSchmidCoefficients)>4) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(5) * math_outer(math_cross(normal, direction), & - math_cross(normal, direction)) - if (size(nonSchmidCoefficients)>5) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(6) * math_outer(direction, direction) - enddo + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + real(pReal), dimension(:), intent(in) :: nonSchmidCoefficients !< non-Schmid coefficients for projections + integer, intent(in) :: sense !< sense (-1,+1) + real(pReal), dimension(1:3,1:3,sum(Nslip)) :: nonSchmidMatrix + + real(pReal), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem !< coordinate system of slip system + real(pReal), dimension(:), allocatable :: direction, normal, np + integer :: i + + if (abs(sense) /= 1) call IO_error(0,ext_msg='lattice_nonSchmidMatrix') + + coordinateSystem = buildCoordinateSystem(Nslip,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMSLIP,& + 'bcc',0.0_pReal) + coordinateSystem(1:3,1,1:sum(Nslip)) = coordinateSystem(1:3,1,1:sum(Nslip)) *real(sense,pReal) ! convert unidirectional coordinate system + nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'bcc',0.0_pReal) ! Schmid contribution + + do i = 1,sum(Nslip) + direction = coordinateSystem(1:3,1,i) + normal = coordinateSystem(1:3,2,i) + np = matmul(math_axisAngleToR(direction,60.0_pReal*INRAD), normal) + if (size(nonSchmidCoefficients)>0) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(1) * math_outer(direction, np) + if (size(nonSchmidCoefficients)>1) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(2) * math_outer(math_cross(normal, direction), normal) + if (size(nonSchmidCoefficients)>2) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(3) * math_outer(math_cross(np, direction), np) + if (size(nonSchmidCoefficients)>3) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(4) * math_outer(normal, normal) + if (size(nonSchmidCoefficients)>4) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(5) * math_outer(math_cross(normal, direction), & + math_cross(normal, direction)) + if (size(nonSchmidCoefficients)>5) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(6) * math_outer(direction, direction) + enddo end function lattice_nonSchmidMatrix - - + + !-------------------------------------------------------------------------------------------------- !> @brief Slip-slip interaction matrix !> details only active slip systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_SlipBySlip(Nslip,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-slip interaction - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix - - integer, dimension(:), allocatable :: NslipMax - integer, dimension(:,:), allocatable :: interactionTypes + use IO, only: & + IO_error - integer, dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NSLIP), parameter :: & - FCC_INTERACTIONSLIPSLIP = reshape( [& - 1, 2, 2, 4, 6, 5, 3, 5, 5, 4, 5, 6, 9,10, 9,10,11,12, & - 2, 1, 2, 6, 4, 5, 5, 4, 6, 5, 3, 5, 9,10,11,12, 9,10, & - 2, 2, 1, 5, 5, 3, 5, 6, 4, 6, 5, 4, 11,12, 9,10, 9,10, & - 4, 6, 5, 1, 2, 2, 4, 5, 6, 3, 5, 5, 9,10,10, 9,12,11, & - 6, 4, 5, 2, 1, 2, 5, 3, 5, 5, 4, 6, 9,10,12,11,10, 9, & - 5, 5, 3, 2, 2, 1, 6, 5, 4, 5, 6, 4, 11,12,10, 9,10, 9, & - 3, 5, 5, 4, 5, 6, 1, 2, 2, 4, 6, 5, 10, 9,10, 9,11,12, & - 5, 4, 6, 5, 3, 5, 2, 1, 2, 6, 4, 5, 10, 9,12,11, 9,10, & - 5, 6, 4, 6, 5, 4, 2, 2, 1, 5, 5, 3, 12,11,10, 9, 9,10, & - 4, 5, 6, 3, 5, 5, 4, 6, 5, 1, 2, 2, 10, 9, 9,10,12,11, & - 5, 3, 5, 5, 4, 6, 6, 4, 5, 2, 1, 2, 10, 9,11,12,10, 9, & - 6, 5, 4, 5, 6, 4, 5, 5, 3, 2, 2, 1, 12,11, 9,10,10, 9, & - - 9, 9,11, 9, 9,11,10,10,12,10,10,12, 1, 7, 8, 8, 8, 8, & - 10,10,12,10,10,12, 9, 9,11, 9, 9,11, 7, 1, 8, 8, 8, 8, & - 9,11, 9,10,12,10,10,12,10, 9,11, 9, 8, 8, 1, 7, 8, 8, & - 10,12,10, 9,11, 9, 9,11, 9,10,12,10, 8, 8, 7, 1, 8, 8, & - 11, 9, 9,12,10,10,11, 9, 9,12,10,10, 8, 8, 8, 8, 1, 7, & - 12,10,10,11, 9, 9,12,10,10,11, 9, 9, 8, 8, 8, 8, 7, 1 & - ],shape(FCC_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for fcc + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-slip interaction + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix + + integer, dimension(:), allocatable :: NslipMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NSLIP), parameter :: & + FCC_INTERACTIONSLIPSLIP = reshape( [& + 1, 2, 2, 4, 6, 5, 3, 5, 5, 4, 5, 6, 9,10, 9,10,11,12, & ! -----> acting + 2, 1, 2, 6, 4, 5, 5, 4, 6, 5, 3, 5, 9,10,11,12, 9,10, & ! | + 2, 2, 1, 5, 5, 3, 5, 6, 4, 6, 5, 4, 11,12, 9,10, 9,10, & ! | + 4, 6, 5, 1, 2, 2, 4, 5, 6, 3, 5, 5, 9,10,10, 9,12,11, & ! v + 6, 4, 5, 2, 1, 2, 5, 3, 5, 5, 4, 6, 9,10,12,11,10, 9, & ! reacting + 5, 5, 3, 2, 2, 1, 6, 5, 4, 5, 6, 4, 11,12,10, 9,10, 9, & + 3, 5, 5, 4, 5, 6, 1, 2, 2, 4, 6, 5, 10, 9,10, 9,11,12, & + 5, 4, 6, 5, 3, 5, 2, 1, 2, 6, 4, 5, 10, 9,12,11, 9,10, & + 5, 6, 4, 6, 5, 4, 2, 2, 1, 5, 5, 3, 12,11,10, 9, 9,10, & + 4, 5, 6, 3, 5, 5, 4, 6, 5, 1, 2, 2, 10, 9, 9,10,12,11, & + 5, 3, 5, 5, 4, 6, 6, 4, 5, 2, 1, 2, 10, 9,11,12,10, 9, & + 6, 5, 4, 5, 6, 4, 5, 5, 3, 2, 2, 1, 12,11, 9,10,10, 9, & + + 9, 9,11, 9, 9,11,10,10,12,10,10,12, 1, 7, 8, 8, 8, 8, & + 10,10,12,10,10,12, 9, 9,11, 9, 9,11, 7, 1, 8, 8, 8, 8, & + 9,11, 9,10,12,10,10,12,10, 9,11, 9, 8, 8, 1, 7, 8, 8, & + 10,12,10, 9,11, 9, 9,11, 9,10,12,10, 8, 8, 7, 1, 8, 8, & + 11, 9, 9,12,10,10,11, 9, 9,12,10,10, 8, 8, 8, 8, 1, 7, & + 12,10,10,11, 9, 9,12,10,10,11, 9, 9, 8, 8, 8, 8, 7, 1 & + ],shape(FCC_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for fcc !< 1: self interaction !< 2: coplanar interaction !< 3: collinear interaction @@ -1299,1094 +1291,1078 @@ function lattice_interaction_SlipBySlip(Nslip,interactionValues,structure) resul !<10: similar to glissile junctions in <110>{111} btw one {110} and one {111} plane !<11: crossing btw one {110} and one {111} plane !<12: collinear btw one {110} and one {111} plane - - integer, dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NSLIP), parameter :: & - BCC_INTERACTIONSLIPSLIP = reshape( [& - 1,2,6,6,5,4,4,3,4,3,5,4, 6,6,4,3,3,4,6,6,4,3,6,6, & - 2,1,6,6,4,3,5,4,5,4,4,3, 6,6,3,4,4,3,6,6,3,4,6,6, & - 6,6,1,2,4,5,3,4,4,5,3,4, 4,3,6,6,6,6,3,4,6,6,4,3, & - 6,6,2,1,3,4,4,5,3,4,4,5, 3,4,6,6,6,6,4,3,6,6,3,4, & - 5,4,4,3,1,2,6,6,3,4,5,4, 3,6,4,6,6,4,6,3,4,6,3,6, & - 4,3,5,4,2,1,6,6,4,5,4,3, 4,6,3,6,6,3,6,4,3,6,4,6, & - 4,5,3,4,6,6,1,2,5,4,3,4, 6,3,6,4,4,6,3,6,6,4,6,3, & - 3,4,4,5,6,6,2,1,4,3,4,5, 6,4,6,3,3,6,4,6,6,3,6,4, & - 4,5,4,3,3,4,5,4,1,2,6,6, 3,6,6,4,4,6,6,3,6,4,3,6, & - 3,4,5,4,4,5,4,3,2,1,6,6, 4,6,6,3,3,6,6,4,6,3,4,6, & - 5,4,3,4,5,4,3,4,6,6,1,2, 6,3,4,6,6,4,3,6,4,6,6,3, & - 4,3,4,5,4,3,4,5,6,6,2,1, 6,4,3,6,6,3,4,6,3,6,6,4, & - ! - 6,6,4,3,3,4,6,6,3,4,6,6, 1,5,6,6,5,6,6,3,5,6,3,6, & - 6,6,3,4,6,6,3,4,6,6,3,4, 5,1,6,6,6,5,3,6,6,5,6,3, & - 4,3,6,6,4,3,6,6,6,6,4,3, 6,6,1,5,6,3,5,6,3,6,5,6, & - 3,4,6,6,6,6,4,3,4,3,6,6, 6,6,5,1,3,6,6,5,6,3,6,5, & - 3,4,6,6,6,6,4,3,4,3,6,6, 5,6,6,3,1,6,5,6,5,3,6,6, & - 4,3,6,6,4,3,6,6,6,6,4,3, 6,5,3,6,6,1,6,5,3,5,6,6, & - 6,6,3,4,6,6,3,4,6,6,3,4, 6,3,5,6,5,6,1,6,6,6,5,3, & - 6,6,4,3,3,4,6,6,3,4,6,6, 3,6,6,5,6,5,6,1,6,6,3,5, & - 4,3,6,6,4,3,6,6,6,6,4,3, 5,6,3,6,5,3,6,6,1,6,6,5, & - 3,4,6,6,6,6,4,3,4,3,6,6, 6,5,6,3,3,5,6,6,6,1,5,6, & - 6,6,4,3,3,4,6,6,3,4,6,6, 3,6,5,6,6,6,5,3,6,5,1,6, & - 6,6,3,4,6,6,3,4,6,6,3,4, 6,3,6,5,6,6,3,5,5,6,6,1 & - ],shape(BCC_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for bcc from Queyreau et al. Int J Plast 25 (2009) 361–377 + + integer, dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NSLIP), parameter :: & + BCC_INTERACTIONSLIPSLIP = reshape( [& + 1,2,6,6,5,4,4,3,4,3,5,4, 6,6,4,3,3,4,6,6,4,3,6,6, & ! -----> acting + 2,1,6,6,4,3,5,4,5,4,4,3, 6,6,3,4,4,3,6,6,3,4,6,6, & ! | + 6,6,1,2,4,5,3,4,4,5,3,4, 4,3,6,6,6,6,3,4,6,6,4,3, & ! | + 6,6,2,1,3,4,4,5,3,4,4,5, 3,4,6,6,6,6,4,3,6,6,3,4, & ! v + 5,4,4,3,1,2,6,6,3,4,5,4, 3,6,4,6,6,4,6,3,4,6,3,6, & ! reacting + 4,3,5,4,2,1,6,6,4,5,4,3, 4,6,3,6,6,3,6,4,3,6,4,6, & + 4,5,3,4,6,6,1,2,5,4,3,4, 6,3,6,4,4,6,3,6,6,4,6,3, & + 3,4,4,5,6,6,2,1,4,3,4,5, 6,4,6,3,3,6,4,6,6,3,6,4, & + 4,5,4,3,3,4,5,4,1,2,6,6, 3,6,6,4,4,6,6,3,6,4,3,6, & + 3,4,5,4,4,5,4,3,2,1,6,6, 4,6,6,3,3,6,6,4,6,3,4,6, & + 5,4,3,4,5,4,3,4,6,6,1,2, 6,3,4,6,6,4,3,6,4,6,6,3, & + 4,3,4,5,4,3,4,5,6,6,2,1, 6,4,3,6,6,3,4,6,3,6,6,4, & + ! + 6,6,4,3,3,4,6,6,3,4,6,6, 1,5,6,6,5,6,6,3,5,6,3,6, & + 6,6,3,4,6,6,3,4,6,6,3,4, 5,1,6,6,6,5,3,6,6,5,6,3, & + 4,3,6,6,4,3,6,6,6,6,4,3, 6,6,1,5,6,3,5,6,3,6,5,6, & + 3,4,6,6,6,6,4,3,4,3,6,6, 6,6,5,1,3,6,6,5,6,3,6,5, & + 3,4,6,6,6,6,4,3,4,3,6,6, 5,6,6,3,1,6,5,6,5,3,6,6, & + 4,3,6,6,4,3,6,6,6,6,4,3, 6,5,3,6,6,1,6,5,3,5,6,6, & + 6,6,3,4,6,6,3,4,6,6,3,4, 6,3,5,6,5,6,1,6,6,6,5,3, & + 6,6,4,3,3,4,6,6,3,4,6,6, 3,6,6,5,6,5,6,1,6,6,3,5, & + 4,3,6,6,4,3,6,6,6,6,4,3, 5,6,3,6,5,3,6,6,1,6,6,5, & + 3,4,6,6,6,6,4,3,4,3,6,6, 6,5,6,3,3,5,6,6,6,1,5,6, & + 6,6,4,3,3,4,6,6,3,4,6,6, 3,6,5,6,6,6,5,3,6,5,1,6, & + 6,6,3,4,6,6,3,4,6,6,3,4, 6,3,6,5,6,6,3,5,5,6,6,1 & + ],shape(BCC_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for bcc from Queyreau et al. Int J Plast 25 (2009) 361–377 !< 1: self interaction !< 2: coplanar interaction !< 3: collinear interaction !< 4: mixed-asymmetrical junction !< 5: mixed-symmetrical junction !< 6: edge junction - - integer, dimension(LATTICE_HEX_NSLIP,LATTICE_HEX_NSLIP), parameter :: & - HEX_INTERACTIONSLIPSLIP = reshape( [& - 1, 2, 2, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & - 2, 1, 2, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & - 2, 2, 1, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & - ! - 6, 6, 6, 4, 5, 5, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & - 6, 6, 6, 5, 4, 5, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & - 6, 6, 6, 5, 5, 4, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & - ! - 12,12,12, 11,11,11, 9,10,10, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & - 12,12,12, 11,11,11, 10, 9,10, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & - 12,12,12, 11,11,11, 10,10, 9, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & - ! - 20,20,20, 19,19,19, 18,18,18, 16,17,17,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - 20,20,20, 19,19,19, 18,18,18, 17,16,17,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - 20,20,20, 19,19,19, 18,18,18, 17,17,16,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - 20,20,20, 19,19,19, 18,18,18, 17,17,17,16,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - 20,20,20, 19,19,19, 18,18,18, 17,17,17,17,16,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - 20,20,20, 19,19,19, 18,18,18, 17,17,17,17,17,16, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - ! - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 25,26,26,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,25,26,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,25,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,25,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,25,26,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,25,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,25,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,25,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,25,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,25,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,26,25,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,26,26,25, 35,35,35,35,35,35, & - ! - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 36,37,37,37,37,37, & - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,36,37,37,37,37, & - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,36,37,37,37, & - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,36,37,37, & - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,36,37, & - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,37,36 & - ],shape(HEX_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for hex (onion peel naming scheme) - - integer, dimension(LATTICE_BCT_NSLIP,LATTICE_BCT_NSLIP), parameter :: & - BCT_INTERACTIONSLIPSLIP = reshape( [& - 1, 2, 3, 3, 7, 7, 13, 13, 13, 13, 21, 21, 31, 31, 31, 31, 43, 43, 57, 57, 73, 73, 73, 73, 91, 91, 91, 91, 91, 91, 91, 91, 111, 111, 111, 111, 133,133,133,133,133,133,133,133, 157,157,157,157,157,157,157,157, & - 2, 1, 3, 3, 7, 7, 13, 13, 13, 13, 21, 21, 31, 31, 31, 31, 43, 43, 57, 57, 73, 73, 73, 73, 91, 91, 91, 91, 91, 91, 91, 91, 111, 111, 111, 111, 133,133,133,133,133,133,133,133, 157,157,157,157,157,157,157,157, & - ! - 6, 6, 4, 5, 8, 8, 14, 14, 14, 14, 22, 22, 32, 32, 32, 32, 44, 44, 58, 58, 74, 74, 74, 74, 92, 92, 92, 92, 92, 92, 92, 92, 112, 112, 112, 112, 134,134,134,134,134,134,134,134, 158,158,158,158,158,158,158,158, & - 6, 6, 5, 4, 8, 8, 14, 14, 14, 14, 22, 22, 32, 32, 32, 32, 44, 44, 58, 58, 74, 74, 74, 74, 92, 92, 92, 92, 92, 92, 92, 92, 112, 112, 112, 112, 134,134,134,134,134,134,134,134, 158,158,158,158,158,158,158,158, & - ! - 12, 12, 11, 11, 9, 10, 15, 15, 15, 15, 23, 23, 33, 33, 33, 33, 45, 45, 59, 59, 75, 75, 75, 75, 93, 93, 93, 93, 93, 93, 93, 93, 113, 113, 113, 113, 135,135,135,135,135,135,135,135, 159,159,159,159,159,159,159,159, & - 12, 12, 11, 11, 10, 9, 15, 15, 15, 15, 23, 23, 33, 33, 33, 33, 45, 45, 59, 59, 75, 75, 75, 75, 93, 93, 93, 93, 93, 93, 93, 93, 113, 113, 113, 113, 135,135,135,135,135,135,135,135, 159,159,159,159,159,159,159,159, & - ! - 20, 20, 19, 19, 18, 18, 16, 17, 17, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & - 20, 20, 19, 19, 18, 18, 17, 16, 17, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & - 20, 20, 19, 19, 18, 18, 17, 17, 16, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & - 20, 20, 19, 19, 18, 18, 17, 17, 17, 16, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & - ! - 30, 30, 29, 29, 28, 28, 27, 27, 27, 27, 25, 26, 35, 35, 35, 35, 47, 47, 61, 61, 77, 77, 77, 77, 95, 95, 95, 95, 95, 95, 95, 95, 115, 115, 115, 115, 137,137,137,137,137,137,137,137, 161,161,161,161,161,161,161,161, & - 30, 30, 29, 29, 28, 28, 27, 27, 27, 27, 26, 25, 35, 35, 35, 35, 47, 47, 61, 61, 77, 77, 77, 77, 95, 95, 95, 95, 95, 95, 95, 95, 115, 115, 115, 115, 137,137,137,137,137,137,137,137, 161,161,161,161,161,161,161,161, & - ! - 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 36, 37, 37, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & - 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 36, 37, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & - 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 37, 36, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & - 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 37, 37, 36, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & - ! - 56, 56, 55, 55, 54, 54, 53, 53, 53, 53, 52, 52, 51, 51, 51, 51, 49, 50, 63, 63, 79, 79, 79, 79, 97, 97, 97, 97, 97, 97, 97, 97, 117, 117, 117, 117, 139,139,139,139,139,139,139,139, 163,163,163,163,163,163,163,163, & - 56, 56, 55, 55, 54, 54, 53, 53, 53, 53, 52, 52, 51, 51, 51, 51, 50, 49, 63, 63, 79, 79, 79, 79, 97, 97, 97, 97, 97, 97, 97, 97, 117, 117, 117, 117, 139,139,139,139,139,139,139,139, 163,163,163,163,163,163,163,163, & - ! - 72, 72, 71, 71, 70, 70, 69, 69, 69, 69, 68, 68, 67, 67, 67, 67, 66, 66, 64, 65, 80, 80, 80, 80, 98, 98, 98, 98, 98, 98, 98, 98, 118, 118, 118, 118, 140,140,140,140,140,140,140,140, 164,164,164,164,164,164,164,164, & - 72, 72, 71, 71, 70, 70, 69, 69, 69, 69, 68, 68, 67, 67, 67, 67, 66, 66, 65, 64, 80, 80, 80, 80, 98, 98, 98, 98, 98, 98, 98, 98, 118, 118, 118, 118, 140,140,140,140,140,140,140,140, 164,164,164,164,164,164,164,164, & - ! - 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 81, 82, 82, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & - 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 81, 82, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & - 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 82, 81, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & - 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 82, 82, 81, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & - ! - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 100,101,101,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,100,101,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,100,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,100,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,100,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,100,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,101,100,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,101,101,100, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - ! - 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 122, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & - 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 121, 122, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & - 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 121, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & - 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 122, 121, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & - ! - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 144,145,145,145,145,145,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,144,145,145,145,145,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,144,145,145,145,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,144,145,145,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,144,145,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,144,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,145,144,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,145,145,144, 168,168,168,168,168,168,168,168, & - ! - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,169,170,170,170,170,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,169,170,170,170,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,170,169,170,170,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,170,170,169,170,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,169,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,169,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,169 & - ],shape(BCT_INTERACTIONSLIPSLIP)) - - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_SlipBySlip: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - interactionTypes = FCC_INTERACTIONSLIPSLIP - NslipMax = LATTICE_FCC_NSLIPSYSTEM - case('bcc') - interactionTypes = BCC_INTERACTIONSLIPSLIP - NslipMax = LATTICE_BCC_NSLIPSYSTEM - case('hex') - interactionTypes = HEX_INTERACTIONSLIPSLIP - NslipMax = LATTICE_HEX_NSLIPSYSTEM - case('bct') - interactionTypes = BCT_INTERACTIONSLIPSLIP - NslipMax = LATTICE_BCT_NSLIPSYSTEM - case default - call IO_error(137,ext_msg='lattice_interaction_SlipBySlip: '//trim(structure)) - end select - - interactionMatrix = buildInteraction(Nslip,Nslip,NslipMax,NslipMax,interactionValues,interactionTypes) - + + integer, dimension(LATTICE_HEX_NSLIP,LATTICE_HEX_NSLIP), parameter :: & + HEX_INTERACTIONSLIPSLIP = reshape( [& + 1, 2, 2, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & ! -----> acting + 2, 1, 2, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & ! | + 2, 2, 1, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & ! | + ! ! v + 6, 6, 6, 4, 5, 5, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & ! reacting + 6, 6, 6, 5, 4, 5, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & + 6, 6, 6, 5, 5, 4, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & + ! + 12,12,12, 11,11,11, 9,10,10, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & + 12,12,12, 11,11,11, 10, 9,10, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & + 12,12,12, 11,11,11, 10,10, 9, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & + ! + 20,20,20, 19,19,19, 18,18,18, 16,17,17,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + 20,20,20, 19,19,19, 18,18,18, 17,16,17,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + 20,20,20, 19,19,19, 18,18,18, 17,17,16,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + 20,20,20, 19,19,19, 18,18,18, 17,17,17,16,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + 20,20,20, 19,19,19, 18,18,18, 17,17,17,17,16,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + 20,20,20, 19,19,19, 18,18,18, 17,17,17,17,17,16, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + ! + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 25,26,26,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,25,26,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,25,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,25,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,25,26,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,25,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,25,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,25,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,25,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,25,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,26,25,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,26,26,25, 35,35,35,35,35,35, & + ! + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 36,37,37,37,37,37, & + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,36,37,37,37,37, & + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,36,37,37,37, & + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,36,37,37, & + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,36,37, & + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,37,36 & + ],shape(HEX_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for hex (onion peel naming scheme) + + integer, dimension(LATTICE_BCT_NSLIP,LATTICE_BCT_NSLIP), parameter :: & + BCT_INTERACTIONSLIPSLIP = reshape( [& + 1, 2, 3, 3, 7, 7, 13, 13, 13, 13, 21, 21, 31, 31, 31, 31, 43, 43, 57, 57, 73, 73, 73, 73, 91, 91, 91, 91, 91, 91, 91, 91, 111, 111, 111, 111, 133,133,133,133,133,133,133,133, 157,157,157,157,157,157,157,157, & ! -----> acting + 2, 1, 3, 3, 7, 7, 13, 13, 13, 13, 21, 21, 31, 31, 31, 31, 43, 43, 57, 57, 73, 73, 73, 73, 91, 91, 91, 91, 91, 91, 91, 91, 111, 111, 111, 111, 133,133,133,133,133,133,133,133, 157,157,157,157,157,157,157,157, & ! | + ! | + 6, 6, 4, 5, 8, 8, 14, 14, 14, 14, 22, 22, 32, 32, 32, 32, 44, 44, 58, 58, 74, 74, 74, 74, 92, 92, 92, 92, 92, 92, 92, 92, 112, 112, 112, 112, 134,134,134,134,134,134,134,134, 158,158,158,158,158,158,158,158, & ! v + 6, 6, 5, 4, 8, 8, 14, 14, 14, 14, 22, 22, 32, 32, 32, 32, 44, 44, 58, 58, 74, 74, 74, 74, 92, 92, 92, 92, 92, 92, 92, 92, 112, 112, 112, 112, 134,134,134,134,134,134,134,134, 158,158,158,158,158,158,158,158, & ! reacting + ! + 12, 12, 11, 11, 9, 10, 15, 15, 15, 15, 23, 23, 33, 33, 33, 33, 45, 45, 59, 59, 75, 75, 75, 75, 93, 93, 93, 93, 93, 93, 93, 93, 113, 113, 113, 113, 135,135,135,135,135,135,135,135, 159,159,159,159,159,159,159,159, & + 12, 12, 11, 11, 10, 9, 15, 15, 15, 15, 23, 23, 33, 33, 33, 33, 45, 45, 59, 59, 75, 75, 75, 75, 93, 93, 93, 93, 93, 93, 93, 93, 113, 113, 113, 113, 135,135,135,135,135,135,135,135, 159,159,159,159,159,159,159,159, & + ! + 20, 20, 19, 19, 18, 18, 16, 17, 17, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & + 20, 20, 19, 19, 18, 18, 17, 16, 17, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & + 20, 20, 19, 19, 18, 18, 17, 17, 16, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & + 20, 20, 19, 19, 18, 18, 17, 17, 17, 16, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & + ! + 30, 30, 29, 29, 28, 28, 27, 27, 27, 27, 25, 26, 35, 35, 35, 35, 47, 47, 61, 61, 77, 77, 77, 77, 95, 95, 95, 95, 95, 95, 95, 95, 115, 115, 115, 115, 137,137,137,137,137,137,137,137, 161,161,161,161,161,161,161,161, & + 30, 30, 29, 29, 28, 28, 27, 27, 27, 27, 26, 25, 35, 35, 35, 35, 47, 47, 61, 61, 77, 77, 77, 77, 95, 95, 95, 95, 95, 95, 95, 95, 115, 115, 115, 115, 137,137,137,137,137,137,137,137, 161,161,161,161,161,161,161,161, & + ! + 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 36, 37, 37, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & + 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 36, 37, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & + 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 37, 36, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & + 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 37, 37, 36, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & + ! + 56, 56, 55, 55, 54, 54, 53, 53, 53, 53, 52, 52, 51, 51, 51, 51, 49, 50, 63, 63, 79, 79, 79, 79, 97, 97, 97, 97, 97, 97, 97, 97, 117, 117, 117, 117, 139,139,139,139,139,139,139,139, 163,163,163,163,163,163,163,163, & + 56, 56, 55, 55, 54, 54, 53, 53, 53, 53, 52, 52, 51, 51, 51, 51, 50, 49, 63, 63, 79, 79, 79, 79, 97, 97, 97, 97, 97, 97, 97, 97, 117, 117, 117, 117, 139,139,139,139,139,139,139,139, 163,163,163,163,163,163,163,163, & + ! + 72, 72, 71, 71, 70, 70, 69, 69, 69, 69, 68, 68, 67, 67, 67, 67, 66, 66, 64, 65, 80, 80, 80, 80, 98, 98, 98, 98, 98, 98, 98, 98, 118, 118, 118, 118, 140,140,140,140,140,140,140,140, 164,164,164,164,164,164,164,164, & + 72, 72, 71, 71, 70, 70, 69, 69, 69, 69, 68, 68, 67, 67, 67, 67, 66, 66, 65, 64, 80, 80, 80, 80, 98, 98, 98, 98, 98, 98, 98, 98, 118, 118, 118, 118, 140,140,140,140,140,140,140,140, 164,164,164,164,164,164,164,164, & + ! + 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 81, 82, 82, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & + 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 81, 82, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & + 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 82, 81, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & + 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 82, 82, 81, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & + ! + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 100,101,101,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,100,101,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,100,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,100,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,100,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,100,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,101,100,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,101,101,100, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + ! + 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 122, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & + 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 121, 122, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & + 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 121, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & + 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 122, 121, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & + ! + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 144,145,145,145,145,145,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,144,145,145,145,145,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,144,145,145,145,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,144,145,145,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,144,145,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,144,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,145,144,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,145,145,144, 168,168,168,168,168,168,168,168, & + ! + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,169,170,170,170,170,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,169,170,170,170,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,170,169,170,170,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,170,170,169,170,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,169,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,169,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,169 & + ],shape(BCT_INTERACTIONSLIPSLIP)) + + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_SlipBySlip: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + interactionTypes = FCC_INTERACTIONSLIPSLIP + NslipMax = LATTICE_FCC_NSLIPSYSTEM + case('bcc') + interactionTypes = BCC_INTERACTIONSLIPSLIP + NslipMax = LATTICE_BCC_NSLIPSYSTEM + case('hex') + interactionTypes = HEX_INTERACTIONSLIPSLIP + NslipMax = LATTICE_HEX_NSLIPSYSTEM + case('bct') + interactionTypes = BCT_INTERACTIONSLIPSLIP + NslipMax = LATTICE_BCT_NSLIPSYSTEM + case default + call IO_error(137,ext_msg='lattice_interaction_SlipBySlip: '//trim(structure)) + end select + + interactionMatrix = buildInteraction(Nslip,Nslip,NslipMax,NslipMax,interactionValues,interactionTypes) + end function lattice_interaction_SlipBySlip - - + + !-------------------------------------------------------------------------------------------------- !> @brief Twin-twin interaction matrix !> details only active twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_TwinByTwin(Ntwin,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix - - integer, dimension(:), allocatable :: NtwinMax - integer, dimension(:,:), allocatable :: interactionTypes - - integer, dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NTWIN), parameter :: & - FCC_INTERACTIONTWINTWIN = reshape( [& - 1,1,1,2,2,2,2,2,2,2,2,2, & - 1,1,1,2,2,2,2,2,2,2,2,2, & - 1,1,1,2,2,2,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1 & - ],shape(FCC_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for fcc - - integer, dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NTWIN), parameter :: & - BCC_INTERACTIONTWINTWIN = reshape( [& - 1,3,3,3,3,3,3,2,3,3,2,3, & - 3,1,3,3,3,3,2,3,3,3,3,2, & - 3,3,1,3,3,2,3,3,2,3,3,3, & - 3,3,3,1,2,3,3,3,3,2,3,3, & - 3,3,3,2,1,3,3,3,3,2,3,3, & - 3,3,2,3,3,1,3,3,2,3,3,3, & - 3,2,3,3,3,3,1,3,3,3,3,2, & - 2,3,3,3,3,3,3,1,3,3,2,3, & - 3,3,2,3,3,2,3,3,1,3,3,3, & - 3,3,3,2,2,3,3,3,3,1,3,3, & - 2,3,3,3,3,3,3,2,3,3,1,3, & - 3,2,3,3,3,3,2,3,3,3,3,1 & - ],shape(BCC_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for bcc + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix + + integer, dimension(:), allocatable :: NtwinMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NTWIN), parameter :: & + FCC_INTERACTIONTWINTWIN = reshape( [& + 1,1,1,2,2,2,2,2,2,2,2,2, & ! -----> acting + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 2,2,2,1,1,1,2,2,2,2,2,2, & ! v + 2,2,2,1,1,1,2,2,2,2,2,2, & ! reacting + 2,2,2,1,1,1,2,2,2,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1 & + ],shape(FCC_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for fcc + + integer, dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NTWIN), parameter :: & + BCC_INTERACTIONTWINTWIN = reshape( [& + 1,3,3,3,3,3,3,2,3,3,2,3, & ! -----> acting + 3,1,3,3,3,3,2,3,3,3,3,2, & ! | + 3,3,1,3,3,2,3,3,2,3,3,3, & ! | + 3,3,3,1,2,3,3,3,3,2,3,3, & ! v + 3,3,3,2,1,3,3,3,3,2,3,3, & ! reacting + 3,3,2,3,3,1,3,3,2,3,3,3, & + 3,2,3,3,3,3,1,3,3,3,3,2, & + 2,3,3,3,3,3,3,1,3,3,2,3, & + 3,3,2,3,3,2,3,3,1,3,3,3, & + 3,3,3,2,2,3,3,3,3,1,3,3, & + 2,3,3,3,3,3,3,2,3,3,1,3, & + 3,2,3,3,3,3,2,3,3,3,3,1 & + ],shape(BCC_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for bcc !< 1: self interaction !< 2: collinear interaction !< 3: other interaction - integer, dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NTWIN), parameter :: & - HEX_INTERACTIONTWINTWIN = reshape( [& - 1, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 2, 1, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 2, 2, 1, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 2, 2, 2, 1, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 2, 2, 2, 2, 1, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - ! - 6, 6, 6, 6, 6, 6, 4, 5, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 4, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 4, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 5, 4, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 4, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 5, 4, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - ! - 12,12,12,12,12,12, 11,11,11,11,11,11, 9,10,10,10,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10, 9,10,10,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10, 9,10,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10, 9,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10, 9,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10,10, 9, 15,15,15,15,15,15, & - ! - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 16,17,17,17,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,16,17,17,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,16,17,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,16,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,16,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,17,16 & - ],shape(HEX_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for hex - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_TwinByTwin: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - interactionTypes = FCC_INTERACTIONTWINTWIN - NtwinMax = LATTICE_FCC_NTWINSYSTEM - case('bcc') - interactionTypes = BCC_INTERACTIONTWINTWIN - NtwinMax = LATTICE_BCC_NTWINSYSTEM - case('hex') - interactionTypes = HEX_INTERACTIONTWINTWIN - NtwinMax = LATTICE_HEX_NTWINSYSTEM - case default - call IO_error(137,ext_msg='lattice_interaction_TwinByTwin: '//trim(structure)) - end select - - interactionMatrix = buildInteraction(Ntwin,Ntwin,NtwinMax,NtwinMax,interactionValues,interactionTypes) - + integer, dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NTWIN), parameter :: & + HEX_INTERACTIONTWINTWIN = reshape( [& + 1, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! -----> acting + 2, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! | + 2, 2, 1, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! | + 2, 2, 2, 1, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! v + 2, 2, 2, 2, 1, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! reacting + 2, 2, 2, 2, 2, 1, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & + ! + 6, 6, 6, 6, 6, 6, 4, 5, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 4, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 4, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 5, 4, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 4, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 5, 4, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + ! + 12,12,12,12,12,12, 11,11,11,11,11,11, 9,10,10,10,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10, 9,10,10,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10, 9,10,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10, 9,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10, 9,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10,10, 9, 15,15,15,15,15,15, & + ! + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 16,17,17,17,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,16,17,17,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,16,17,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,16,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,16,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,17,16 & + ],shape(HEX_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for hex + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_TwinByTwin: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + interactionTypes = FCC_INTERACTIONTWINTWIN + NtwinMax = LATTICE_FCC_NTWINSYSTEM + case('bcc') + interactionTypes = BCC_INTERACTIONTWINTWIN + NtwinMax = LATTICE_BCC_NTWINSYSTEM + case('hex') + interactionTypes = HEX_INTERACTIONTWINTWIN + NtwinMax = LATTICE_HEX_NTWINSYSTEM + case default + call IO_error(137,ext_msg='lattice_interaction_TwinByTwin: '//trim(structure)) + end select + + interactionMatrix = buildInteraction(Ntwin,Ntwin,NtwinMax,NtwinMax,interactionValues,interactionTypes) + end function lattice_interaction_TwinByTwin - - + + !-------------------------------------------------------------------------------------------------- !> @brief Trans-trans interaction matrix !> details only active trans systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_TransByTrans(Ntrans,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ntrans !< number of active trans systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for trans-trans interaction - character(len=*), intent(in) :: structure !< lattice structure (parent crystal) - real(pReal), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix - - integer, dimension(:), allocatable :: NtransMax - integer, dimension(:,:), allocatable :: interactionTypes - - integer, dimension(LATTICE_FCC_NTRANS,LATTICE_FCC_NTRANS), parameter :: & - FCC_INTERACTIONTRANSTRANS = reshape( [& - 1,1,1,2,2,2,2,2,2,2,2,2, & - 1,1,1,2,2,2,2,2,2,2,2,2, & - 1,1,1,2,2,2,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1 & - ],shape(FCC_INTERACTIONTRANSTRANS)) !< Trans-trans interaction types for fcc - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_TransByTrans: '//trim(structure)) - - if(structure(1:3) == 'fcc') then - interactionTypes = FCC_INTERACTIONTRANSTRANS - NtransMax = LATTICE_FCC_NTRANSSYSTEM - else - call IO_error(137,ext_msg='lattice_interaction_TransByTrans: '//trim(structure)) - end if - - interactionMatrix = buildInteraction(Ntrans,Ntrans,NtransMax,NtransMax,interactionValues,interactionTypes) - + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ntrans !< number of active trans systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for trans-trans interaction + character(len=*), intent(in) :: structure !< lattice structure (parent crystal) + real(pReal), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix + + integer, dimension(:), allocatable :: NtransMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NTRANS,LATTICE_FCC_NTRANS), parameter :: & + FCC_INTERACTIONTRANSTRANS = reshape( [& + 1,1,1,2,2,2,2,2,2,2,2,2, & ! -----> acting + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 2,2,2,1,1,1,2,2,2,2,2,2, & ! v + 2,2,2,1,1,1,2,2,2,2,2,2, & ! reacting + 2,2,2,1,1,1,2,2,2,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1 & + ],shape(FCC_INTERACTIONTRANSTRANS)) !< Trans-trans interaction types for fcc + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_TransByTrans: '//trim(structure)) + + if(structure(1:3) == 'fcc') then + interactionTypes = FCC_INTERACTIONTRANSTRANS + NtransMax = LATTICE_FCC_NTRANSSYSTEM + else + call IO_error(137,ext_msg='lattice_interaction_TransByTrans: '//trim(structure)) + end if + + interactionMatrix = buildInteraction(Ntrans,Ntrans,NtransMax,NtransMax,interactionValues,interactionTypes) + end function lattice_interaction_TransByTrans - - + + !-------------------------------------------------------------------------------------------------- !> @brief Slip-twin interaction matrix !> details only active slip and twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_SlipByTwin(Nslip,Ntwin,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family - Ntwin !< number of active twin systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-twin interaction - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(sum(Ntwin),sum(Nslip)) :: interactionMatrix - - integer, dimension(:), allocatable :: NslipMax, & - NtwinMax - integer, dimension(:,:), allocatable :: interactionTypes - - integer, dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NSLIP), parameter :: & - FCC_INTERACTIONSLIPTWIN = reshape( [& - 1,1,1,3,3,3,2,2,2,3,3,3, & ! -----> twin - 1,1,1,3,3,3,3,3,3,2,2,2, & ! | - 1,1,1,2,2,2,3,3,3,3,3,3, & ! | - 3,3,3,1,1,1,3,3,3,2,2,2, & ! v slip - 3,3,3,1,1,1,2,2,2,3,3,3, & - 2,2,2,1,1,1,3,3,3,3,3,3, & - 2,2,2,3,3,3,1,1,1,3,3,3, & - 3,3,3,2,2,2,1,1,1,3,3,3, & - 3,3,3,3,3,3,1,1,1,2,2,2, & - 3,3,3,2,2,2,3,3,3,1,1,1, & - 2,2,2,3,3,3,3,3,3,1,1,1, & - 3,3,3,3,3,3,2,2,2,1,1,1, & - - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4 & - ],shape(FCC_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for fcc + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family + Ntwin !< number of active twin systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-twin interaction + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(sum(Nslip),sum(Ntwin)) :: interactionMatrix + + integer, dimension(:), allocatable :: NslipMax, & + NtwinMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NSLIP), parameter :: & + FCC_INTERACTIONSLIPTWIN = reshape( [& + 1,1,1,3,3,3,2,2,2,3,3,3, & ! -----> twin (acting) + 1,1,1,3,3,3,3,3,3,2,2,2, & ! | + 1,1,1,2,2,2,3,3,3,3,3,3, & ! | + 3,3,3,1,1,1,3,3,3,2,2,2, & ! v + 3,3,3,1,1,1,2,2,2,3,3,3, & ! slip (reacting) + 2,2,2,1,1,1,3,3,3,3,3,3, & + 2,2,2,3,3,3,1,1,1,3,3,3, & + 3,3,3,2,2,2,1,1,1,3,3,3, & + 3,3,3,3,3,3,1,1,1,2,2,2, & + 3,3,3,2,2,2,3,3,3,1,1,1, & + 2,2,2,3,3,3,3,3,3,1,1,1, & + 3,3,3,3,3,3,2,2,2,1,1,1, & + + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4 & + ],shape(FCC_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for fcc !< 1: coplanar interaction !< 2: screw trace between slip system and twin habit plane (easy cross slip) !< 3: other interaction - integer, dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NSLIP), parameter :: & - BCC_INTERACTIONSLIPTWIN = reshape( [& - 3,3,3,2,2,3,3,3,3,2,3,3, & ! -----> twin - 3,3,2,3,3,2,3,3,2,3,3,3, & ! | - 3,2,3,3,3,3,2,3,3,3,3,2, & ! | - 2,3,3,3,3,3,3,2,3,3,2,3, & ! v slip - 2,3,3,3,3,3,3,2,3,3,2,3, & - 3,3,2,3,3,2,3,3,2,3,3,3, & - 3,2,3,3,3,3,2,3,3,3,3,2, & - 3,3,3,2,2,3,3,3,3,2,3,3, & - 2,3,3,3,3,3,3,2,3,3,2,3, & - 3,3,3,2,2,3,3,3,3,2,3,3, & - 3,2,3,3,3,3,2,3,3,3,3,2, & - 3,3,2,3,3,2,3,3,2,3,3,3, & + integer, dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NSLIP), parameter :: & + BCC_INTERACTIONSLIPTWIN = reshape( [& + 3,3,3,2,2,3,3,3,3,2,3,3, & ! -----> twin (acting) + 3,3,2,3,3,2,3,3,2,3,3,3, & ! | + 3,2,3,3,3,3,2,3,3,3,3,2, & ! | + 2,3,3,3,3,3,3,2,3,3,2,3, & ! v + 2,3,3,3,3,3,3,2,3,3,2,3, & ! slip (reacting) + 3,3,2,3,3,2,3,3,2,3,3,3, & + 3,2,3,3,3,3,2,3,3,3,3,2, & + 3,3,3,2,2,3,3,3,3,2,3,3, & + 2,3,3,3,3,3,3,2,3,3,2,3, & + 3,3,3,2,2,3,3,3,3,2,3,3, & + 3,2,3,3,3,3,2,3,3,3,3,2, & + 3,3,2,3,3,2,3,3,2,3,3,3, & + ! + 1,3,3,3,3,3,3,2,3,3,2,3, & + 3,1,3,3,3,3,2,3,3,3,3,2, & + 3,3,1,3,3,2,3,3,2,3,3,3, & + 3,3,3,1,2,3,3,3,3,2,3,3, & + 3,3,3,2,1,3,3,3,3,2,3,3, & + 3,3,2,3,3,1,3,3,2,3,3,3, & + 3,2,3,3,3,3,1,3,3,3,3,2, & + 2,3,3,3,3,3,3,1,3,3,2,3, & + 3,3,2,3,3,2,3,3,1,3,3,3, & + 3,3,3,2,2,3,3,3,3,1,3,3, & + 2,3,3,3,3,3,3,2,3,3,1,3, & + 3,2,3,3,3,3,2,3,3,3,3,1 & + ],shape(BCC_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for bcc + !< 1: coplanar interaction + !< 2: screw trace between slip system and twin habit plane (easy cross slip) + !< 3: other interaction + integer, dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NSLIP), parameter :: & + HEX_INTERACTIONSLIPTWIN = reshape( [& + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! ----> twin (acting) + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | + ! v + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & ! slip (reacting) + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & ! - 1,3,3,3,3,3,3,2,3,3,2,3, & - 3,1,3,3,3,3,2,3,3,3,3,2, & - 3,3,1,3,3,2,3,3,2,3,3,3, & - 3,3,3,1,2,3,3,3,3,2,3,3, & - 3,3,3,2,1,3,3,3,3,2,3,3, & - 3,3,2,3,3,1,3,3,2,3,3,3, & - 3,2,3,3,3,3,1,3,3,3,3,2, & - 2,3,3,3,3,3,3,1,3,3,2,3, & - 3,3,2,3,3,2,3,3,1,3,3,3, & - 3,3,3,2,2,3,3,3,3,1,3,3, & - 2,3,3,3,3,3,3,2,3,3,1,3, & - 3,2,3,3,3,3,2,3,3,3,3,1 & - ],shape(BCC_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for bcc - !< 1: coplanar interaction - !< 2: screw trace between slip system and twin habit plane (easy cross slip) - !< 3: other interaction - integer, dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NSLIP), parameter :: & - HEX_INTERACTIONSLIPTWIN = reshape( [& - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! ----> twin - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | - ! v - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & ! slip - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & - ! - 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & - 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & - 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & - ! - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - ! - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - ! - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24 & - ! - ],shape(HEX_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for hex - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_SlipByTwin: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - interactionTypes = FCC_INTERACTIONSLIPTWIN - NslipMax = LATTICE_FCC_NSLIPSYSTEM - NtwinMax = LATTICE_FCC_NTWINSYSTEM - case('bcc') - interactionTypes = BCC_INTERACTIONSLIPTWIN - NslipMax = LATTICE_BCC_NSLIPSYSTEM - NtwinMax = LATTICE_BCC_NTWINSYSTEM - case('hex') - interactionTypes = HEX_INTERACTIONSLIPTWIN - NslipMax = LATTICE_HEX_NSLIPSYSTEM - NtwinMax = LATTICE_HEX_NTWINSYSTEM - case default - call IO_error(137,ext_msg='lattice_interaction_SlipByTwin: '//trim(structure)) - end select - - interactionMatrix = buildInteraction(Ntwin,Nslip,NtwinMax,NslipMax,interactionValues,interactionTypes) - + 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & + 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & + 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & + ! + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + ! + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + ! + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24 & + ! + ],shape(HEX_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for hex + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_SlipByTwin: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + interactionTypes = FCC_INTERACTIONSLIPTWIN + NslipMax = LATTICE_FCC_NSLIPSYSTEM + NtwinMax = LATTICE_FCC_NTWINSYSTEM + case('bcc') + interactionTypes = BCC_INTERACTIONSLIPTWIN + NslipMax = LATTICE_BCC_NSLIPSYSTEM + NtwinMax = LATTICE_BCC_NTWINSYSTEM + case('hex') + interactionTypes = HEX_INTERACTIONSLIPTWIN + NslipMax = LATTICE_HEX_NSLIPSYSTEM + NtwinMax = LATTICE_HEX_NTWINSYSTEM + case default + call IO_error(137,ext_msg='lattice_interaction_SlipByTwin: '//trim(structure)) + end select + + interactionMatrix = buildInteraction(Nslip,Ntwin,NslipMax,NtwinMax,interactionValues,interactionTypes) + end function lattice_interaction_SlipByTwin - - + + !-------------------------------------------------------------------------------------------------- !> @brief Slip-trans interaction matrix !> details only active slip and trans systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_SlipByTrans(Nslip,Ntrans,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family - Ntrans !< number of active trans systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-trans interaction - character(len=*), intent(in) :: structure !< lattice structure (parent crystal) - real(pReal), dimension(sum(Ntrans),sum(Nslip)) :: interactionMatrix - - integer, dimension(:), allocatable :: NslipMax, & - NtransMax - integer, dimension(:,:), allocatable :: interactionTypes - - integer, dimension(LATTICE_FCC_NTRANS,LATTICE_FCC_NSLIP), parameter :: & - FCC_INTERACTIONSLIPTRANS = reshape( [& - 1,1,1,3,3,3,2,2,2,3,3,3, & ! -----> trans - 1,1,1,3,3,3,3,3,3,2,2,2, & ! | - 1,1,1,2,2,2,3,3,3,3,3,3, & ! | - 3,3,3,1,1,1,3,3,3,2,2,2, & ! v slip - 3,3,3,1,1,1,2,2,2,3,3,3, & - 2,2,2,1,1,1,3,3,3,3,3,3, & - 2,2,2,3,3,3,1,1,1,3,3,3, & - 3,3,3,2,2,2,1,1,1,3,3,3, & - 3,3,3,3,3,3,1,1,1,2,2,2, & - 3,3,3,2,2,2,3,3,3,1,1,1, & - 2,2,2,3,3,3,3,3,3,1,1,1, & - 3,3,3,3,3,3,2,2,2,1,1,1, & - - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4 & - ],shape(FCC_INTERACTIONSLIPTRANS)) !< Slip-trans interaction types for fcc - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_SlipByTrans: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - interactionTypes = FCC_INTERACTIONSLIPTRANS - NslipMax = LATTICE_FCC_NSLIPSYSTEM - NtransMax = LATTICE_FCC_NTRANSSYSTEM - case default - call IO_error(137,ext_msg='lattice_interaction_SlipByTrans: '//trim(structure)) - end select - - interactionMatrix = buildInteraction(Ntrans,Nslip,NtransMax,NslipMax,interactionValues,interactionTypes) - -end function lattice_interaction_SlipByTrans - - + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family + Ntrans !< number of active trans systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-trans interaction + character(len=*), intent(in) :: structure !< lattice structure (parent crystal) + real(pReal), dimension(sum(Nslip),sum(Ntrans)) :: interactionMatrix + + integer, dimension(:), allocatable :: NslipMax, & + NtransMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NTRANS,LATTICE_FCC_NSLIP), parameter :: & + FCC_INTERACTIONSLIPTRANS = reshape( [& + 1,1,1,3,3,3,2,2,2,3,3,3, & ! -----> trans (acting) + 1,1,1,3,3,3,3,3,3,2,2,2, & ! | + 1,1,1,2,2,2,3,3,3,3,3,3, & ! | + 3,3,3,1,1,1,3,3,3,2,2,2, & ! v + 3,3,3,1,1,1,2,2,2,3,3,3, & ! slip (reacting) + 2,2,2,1,1,1,3,3,3,3,3,3, & + 2,2,2,3,3,3,1,1,1,3,3,3, & + 3,3,3,2,2,2,1,1,1,3,3,3, & + 3,3,3,3,3,3,1,1,1,2,2,2, & + 3,3,3,2,2,2,3,3,3,1,1,1, & + 2,2,2,3,3,3,3,3,3,1,1,1, & + 3,3,3,3,3,3,2,2,2,1,1,1, & + + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4 & + ],shape(FCC_INTERACTIONSLIPTRANS)) !< Slip-trans interaction types for fcc + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_SlipByTrans: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + interactionTypes = FCC_INTERACTIONSLIPTRANS + NslipMax = LATTICE_FCC_NSLIPSYSTEM + NtransMax = LATTICE_FCC_NTRANSSYSTEM + case default + call IO_error(137,ext_msg='lattice_interaction_SlipByTrans: '//trim(structure)) + end select + + interactionMatrix = buildInteraction(Nslip,Ntrans,NslipMax,NtransMax,interactionValues,interactionTypes) + + end function lattice_interaction_SlipByTrans + + !-------------------------------------------------------------------------------------------------- !> @brief Twin-slip interaction matrix !> details only active twin and slip systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_TwinBySlip(Ntwin,Nslip,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ntwin, & !< number of active twin systems per family - Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(sum(Nslip),sum(Ntwin)) :: interactionMatrix - - integer, dimension(:), allocatable :: NtwinMax, & - NslipMax - integer, dimension(:,:), allocatable :: interactionTypes - - integer, dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NTWIN), parameter :: & - FCC_INTERACTIONTWINSLIP = 1 !< Twin-Slip interaction types for fcc - - integer, dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NTWIN), parameter :: & - BCC_INTERACTIONTWINSLIP = 1 !< Twin-slip interaction types for bcc - - integer, dimension(LATTICE_HEX_NSLIP,LATTICE_HEX_NTWIN), parameter :: & - HEX_INTERACTIONTWINSLIP = reshape( [& - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! ----> slip - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! v - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! twin - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & - ! - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - ! - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - ! - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24 & - ],shape(HEX_INTERACTIONTWINSLIP)) !< Twin-twin interaction types for hex - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_TwinBySlip: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - interactionTypes = FCC_INTERACTIONTWINSLIP - NtwinMax = LATTICE_FCC_NTWINSYSTEM - NslipMax = LATTICE_FCC_NSLIPSYSTEM - case('bcc') - interactionTypes = BCC_INTERACTIONTWINSLIP - NtwinMax = LATTICE_BCC_NTWINSYSTEM - NslipMax = LATTICE_BCC_NSLIPSYSTEM - case('hex') - interactionTypes = HEX_INTERACTIONTWINSLIP - NtwinMax = LATTICE_HEX_NTWINSYSTEM - NslipMax = LATTICE_HEX_NSLIPSYSTEM - case default - call IO_error(137,ext_msg='lattice_interaction_TwinBySlip: '//trim(structure)) - end select - - interactionMatrix = buildInteraction(Nslip,Ntwin,NslipMax,NtwinMax,interactionValues,interactionTypes) - + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ntwin, & !< number of active twin systems per family + Nslip !< number of active slip systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(sum(Ntwin),sum(Nslip)) :: interactionMatrix + + integer, dimension(:), allocatable :: NtwinMax, & + NslipMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NTWIN), parameter :: & + FCC_INTERACTIONTWINSLIP = 1 !< Twin-slip interaction types for fcc + + integer, dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NTWIN), parameter :: & + BCC_INTERACTIONTWINSLIP = 1 !< Twin-slip interaction types for bcc + + integer, dimension(LATTICE_HEX_NSLIP,LATTICE_HEX_NTWIN), parameter :: & + HEX_INTERACTIONTWINSLIP = reshape( [& + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! ----> slip (acting) + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! v + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! twin (reacting) + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & + ! + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + ! + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + ! + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24 & + ],shape(HEX_INTERACTIONTWINSLIP)) !< Twin-slip interaction types for hex + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_TwinBySlip: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + interactionTypes = FCC_INTERACTIONTWINSLIP + NtwinMax = LATTICE_FCC_NTWINSYSTEM + NslipMax = LATTICE_FCC_NSLIPSYSTEM + case('bcc') + interactionTypes = BCC_INTERACTIONTWINSLIP + NtwinMax = LATTICE_BCC_NTWINSYSTEM + NslipMax = LATTICE_BCC_NSLIPSYSTEM + case('hex') + interactionTypes = HEX_INTERACTIONTWINSLIP + NtwinMax = LATTICE_HEX_NTWINSYSTEM + NslipMax = LATTICE_HEX_NSLIPSYSTEM + case default + call IO_error(137,ext_msg='lattice_interaction_TwinBySlip: '//trim(structure)) + end select + + interactionMatrix = buildInteraction(Ntwin,Nslip,NtwinMax,NslipMax,interactionValues,interactionTypes) + end function lattice_interaction_TwinBySlip - - + + !-------------------------------------------------------------------------------------------------- !> @brief Schmid matrix for slip !> details only active slip systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_slip(Nslip,structure,cOverA) result(SchmidMatrix) - use prec, only: & - tol_math_check - use IO, only: & - IO_error - use math, only: & - math_trace33, & - math_outer - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA - real(pReal), dimension(3,3,sum(Nslip)) :: SchmidMatrix - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - real(pReal), dimension(:,:), allocatable :: slipSystems - integer, dimension(:), allocatable :: NslipMax - integer :: i + use prec, only: & + tol_math_check + use IO, only: & + IO_error + use math, only: & + math_trace33, & + math_outer + + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA + real(pReal), dimension(3,3,sum(Nslip)) :: SchmidMatrix + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + real(pReal), dimension(:,:), allocatable :: slipSystems + integer, dimension(:), allocatable :: NslipMax + integer :: i + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + NslipMax = LATTICE_FCC_NSLIPSYSTEM + slipSystems = LATTICE_FCC_SYSTEMSLIP + case('bcc') + NslipMax = LATTICE_BCC_NSLIPSYSTEM + slipSystems = LATTICE_BCC_SYSTEMSLIP + case('hex') + NslipMax = LATTICE_HEX_NSLIPSYSTEM + slipSystems = LATTICE_HEX_SYSTEMSLIP + case('bct') + NslipMax = LATTICE_BCT_NSLIPSYSTEM + slipSystems = LATTICE_BCT_SYSTEMSLIP + case default + call IO_error(137,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure)) + end select + + if (any(NslipMax(1:size(Nslip)) - Nslip < 0)) & + call IO_error(145,ext_msg='Nslip '//trim(structure)) + if (any(Nslip < 0)) & + call IO_error(144,ext_msg='Nslip '//trim(structure)) + + coordinateSystem = buildCoordinateSystem(Nslip,NslipMax,slipSystems,structure,cOverA) + + 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 - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - NslipMax = LATTICE_FCC_NSLIPSYSTEM - slipSystems = LATTICE_FCC_SYSTEMSLIP - case('bcc') - NslipMax = LATTICE_BCC_NSLIPSYSTEM - slipSystems = LATTICE_BCC_SYSTEMSLIP - case('hex') - NslipMax = LATTICE_HEX_NSLIPSYSTEM - slipSystems = LATTICE_HEX_SYSTEMSLIP - case('bct') - NslipMax = LATTICE_BCT_NSLIPSYSTEM - slipSystems = LATTICE_BCT_SYSTEMSLIP - case default - call IO_error(137,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure)) - end select - - if (any(NslipMax(1:size(Nslip)) - Nslip < 0)) & - call IO_error(145,ext_msg='Nslip '//trim(structure)) - if (any(Nslip < 0)) & - call IO_error(144,ext_msg='Nslip '//trim(structure)) - - coordinateSystem = buildCoordinateSystem(Nslip,NslipMax,slipSystems,structure,cOverA) - - 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 - end function lattice_SchmidMatrix_slip - - + + !-------------------------------------------------------------------------------------------------- !> @brief Schmid matrix for twinning !> details only active twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_twin(Ntwin,structure,cOverA) result(SchmidMatrix) - use prec, only: & - tol_math_check - use IO, only: & - IO_error - use math, only: & - math_trace33, & - math_outer - - implicit none - integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,3,sum(Ntwin)) :: SchmidMatrix - - real(pReal), dimension(3,3,sum(Ntwin)) :: coordinateSystem - real(pReal), dimension(:,:), allocatable :: twinSystems - integer, dimension(:), allocatable :: NtwinMax - integer :: i - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - NtwinMax = LATTICE_FCC_NTWINSYSTEM - twinSystems = LATTICE_FCC_SYSTEMTWIN - case('bcc') - NtwinMax = LATTICE_BCC_NTWINSYSTEM - twinSystems = LATTICE_BCC_SYSTEMTWIN - case('hex') - NtwinMax = LATTICE_HEX_NTWINSYSTEM - twinSystems = LATTICE_HEX_SYSTEMTWIN - case default - call IO_error(137,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure)) - end select - - if (any(NtwinMax(1:size(Ntwin)) - Ntwin < 0)) & - call IO_error(145,ext_msg='Ntwin '//trim(structure)) - if (any(Ntwin < 0)) & - call IO_error(144,ext_msg='Ntwin '//trim(structure)) - - coordinateSystem = buildCoordinateSystem(Ntwin,NtwinMax,twinSystems,structure,cOverA) - - 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 - -end function lattice_SchmidMatrix_twin - - + use prec, only: & + tol_math_check + use IO, only: & + IO_error + use math, only: & + math_trace33, & + math_outer + + integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,3,sum(Ntwin)) :: SchmidMatrix + + real(pReal), dimension(3,3,sum(Ntwin)) :: coordinateSystem + real(pReal), dimension(:,:), allocatable :: twinSystems + integer, dimension(:), allocatable :: NtwinMax + integer :: i + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + NtwinMax = LATTICE_FCC_NTWINSYSTEM + twinSystems = LATTICE_FCC_SYSTEMTWIN + case('bcc') + NtwinMax = LATTICE_BCC_NTWINSYSTEM + twinSystems = LATTICE_BCC_SYSTEMTWIN + case('hex') + NtwinMax = LATTICE_HEX_NTWINSYSTEM + twinSystems = LATTICE_HEX_SYSTEMTWIN + case default + call IO_error(137,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure)) + end select + + if (any(NtwinMax(1:size(Ntwin)) - Ntwin < 0)) & + call IO_error(145,ext_msg='Ntwin '//trim(structure)) + if (any(Ntwin < 0)) & + call IO_error(144,ext_msg='Ntwin '//trim(structure)) + + coordinateSystem = buildCoordinateSystem(Ntwin,NtwinMax,twinSystems,structure,cOverA) + + 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 + + end function lattice_SchmidMatrix_twin + + !-------------------------------------------------------------------------------------------------- !> @brief Schmid matrix for twinning !> details only active twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_trans(Ntrans,structure_target,cOverA,a_bcc,a_fcc) result(SchmidMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family - real(pReal), intent(in) :: cOverA !< c/a ratio - character(len=*), intent(in) :: structure_target !< lattice structure - real(pReal), dimension(3,3,sum(Ntrans)) :: SchmidMatrix - - real(pReal), dimension(3,3,sum(Ntrans)):: devNull - real(pReal) :: a_bcc, a_fcc - - if (len_trim(structure_target) /= 3) & - call IO_error(137,ext_msg='lattice_SchmidMatrix_trans (target): '//trim(structure_target)) - if (structure_target(1:3) /= 'bcc' .and. structure_target(1:3) /= 'hex') & - call IO_error(137,ext_msg='lattice_SchmidMatrix_trans (target): '//trim(structure_target)) - - !ToDo: add checks for CoverA_trans,a_fcc,a_bcc - - call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,cOverA,a_fcc,a_bcc) - - end function lattice_SchmidMatrix_trans - - + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family + real(pReal), intent(in) :: cOverA !< c/a ratio + character(len=*), intent(in) :: structure_target !< lattice structure + real(pReal), dimension(3,3,sum(Ntrans)) :: SchmidMatrix + + real(pReal), dimension(3,3,sum(Ntrans)):: devNull + real(pReal) :: a_bcc, a_fcc + + if (len_trim(structure_target) /= 3) & + call IO_error(137,ext_msg='lattice_SchmidMatrix_trans (target): '//trim(structure_target)) + if (structure_target(1:3) /= 'bcc' .and. structure_target(1:3) /= 'hex') & + call IO_error(137,ext_msg='lattice_SchmidMatrix_trans (target): '//trim(structure_target)) + + !ToDo: add checks for CoverA_trans,a_fcc,a_bcc + + call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,cOverA,a_fcc,a_bcc) + +end function lattice_SchmidMatrix_trans + + !-------------------------------------------------------------------------------------------------- !> @brief Schmid matrix for cleavage !> details only active cleavage systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(SchmidMatrix) - use math, only: & - math_outer - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix - - real(pReal), dimension(3,3,sum(Ncleavage)) :: coordinateSystem - real(pReal), dimension(:,:), allocatable :: cleavageSystems - integer, dimension(:), allocatable :: NcleavageMax - integer :: i + use math, only: & + math_outer + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix + + real(pReal), dimension(3,3,sum(Ncleavage)) :: coordinateSystem + real(pReal), dimension(:,:), allocatable :: cleavageSystems + integer, dimension(:), allocatable :: NcleavageMax + integer :: i + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure)) + + select case(structure(1:3)) + case('iso') + NcleavageMax = LATTICE_ISO_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_ISO_SYSTEMCLEAVAGE + case('ort') + NcleavageMax = LATTICE_ORT_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_ORT_SYSTEMCLEAVAGE + case('fcc') + NcleavageMax = LATTICE_FCC_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_FCC_SYSTEMCLEAVAGE + case('bcc') + NcleavageMax = LATTICE_BCC_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_BCC_SYSTEMCLEAVAGE + case('hex') + NcleavageMax = LATTICE_HEX_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_HEX_SYSTEMCLEAVAGE + case default + call IO_error(137,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure)) + end select + + if (any(NcleavageMax(1:size(Ncleavage)) - Ncleavage < 0)) & + call IO_error(145,ext_msg='Ncleavage '//trim(structure)) + if (any(Ncleavage < 0)) & + call IO_error(144,ext_msg='Ncleavage '//trim(structure)) + + coordinateSystem = buildCoordinateSystem(Ncleavage,NcleavageMax,cleavageSystems,structure,cOverA) + + do i = 1, sum(Ncleavage) + 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 - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure)) - - select case(structure(1:3)) - case('iso') - NcleavageMax = LATTICE_ISO_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_ISO_SYSTEMCLEAVAGE - case('ort') - NcleavageMax = LATTICE_ORT_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_ORT_SYSTEMCLEAVAGE - case('fcc') - NcleavageMax = LATTICE_FCC_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_FCC_SYSTEMCLEAVAGE - case('bcc') - NcleavageMax = LATTICE_BCC_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_BCC_SYSTEMCLEAVAGE - case('hex') - NcleavageMax = LATTICE_HEX_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_HEX_SYSTEMCLEAVAGE - case default - call IO_error(137,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure)) - end select - - if (any(NcleavageMax(1:size(Ncleavage)) - Ncleavage < 0)) & - call IO_error(145,ext_msg='Ncleavage '//trim(structure)) - if (any(Ncleavage < 0)) & - call IO_error(144,ext_msg='Ncleavage '//trim(structure)) - - coordinateSystem = buildCoordinateSystem(Ncleavage,NcleavageMax,cleavageSystems,structure,cOverA) - - do i = 1, sum(Ncleavage) - 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 function lattice_SchmidMatrix_cleavage - - + + !-------------------------------------------------------------------------------------------------- !> @brief Slip direction of slip systems (|| b) !-------------------------------------------------------------------------------------------------- function lattice_slip_direction(Nslip,structure,cOverA) result(d) - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,sum(Nslip)) :: d - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) - d = coordinateSystem(1:3,1,1:sum(Nslip)) - + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,sum(Nslip)) :: d + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + + coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) + d = coordinateSystem(1:3,1,1:sum(Nslip)) + end function lattice_slip_direction - - + + !-------------------------------------------------------------------------------------------------- !> @brief Normal direction of slip systems (|| n) !-------------------------------------------------------------------------------------------------- function lattice_slip_normal(Nslip,structure,cOverA) result(n) - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,sum(Nslip)) :: n - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) - n = coordinateSystem(1:3,2,1:sum(Nslip)) - + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,sum(Nslip)) :: n + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + + coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) + n = coordinateSystem(1:3,2,1:sum(Nslip)) + end function lattice_slip_normal + !-------------------------------------------------------------------------------------------------- !> @brief Transverse direction of slip systems ( || t = b x n) !-------------------------------------------------------------------------------------------------- function lattice_slip_transverse(Nslip,structure,cOverA) result(t) - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,sum(Nslip)) :: t - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) - t = coordinateSystem(1:3,3,1:sum(Nslip)) - + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,sum(Nslip)) :: t + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + + coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) + t = coordinateSystem(1:3,3,1:sum(Nslip)) + end function lattice_slip_transverse - - + + !-------------------------------------------------------------------------------------------------- !> @brief Projection of the transverse direction onto the slip plane !> @details: This projection is used to calculate forest hardening for edge dislocations !-------------------------------------------------------------------------------------------------- function slipProjection_transverse(Nslip,structure,cOverA) result(projection) - use math, only: & - math_inner - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - integer :: i, j + use math, only: & + math_inner + + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + integer :: i, j + + coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) + + do i=1, sum(Nslip); do j=1, sum(Nslip) + projection(i,j) = abs(math_inner(coordinateSystem(1:3,2,i),coordinateSystem(1:3,3,j))) + enddo; enddo - coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) - - do i=1, sum(Nslip); do j=1, sum(Nslip) - projection(i,j) = abs(math_inner(coordinateSystem(1:3,2,i),coordinateSystem(1:3,3,j))) - enddo; enddo - end function slipProjection_transverse - - + + !-------------------------------------------------------------------------------------------------- !> @brief Projection of the slip direction onto the slip plane !> @details: This projection is used to calculate forest hardening for screw dislocations !-------------------------------------------------------------------------------------------------- function slipProjection_direction(Nslip,structure,cOverA) result(projection) - use math, only: & - math_inner - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - integer :: i, j + use math, only: & + math_inner + + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + integer :: i, j + + coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) + + do i=1, sum(Nslip); do j=1, sum(Nslip) + projection(i,j) = abs(math_inner(coordinateSystem(1:3,2,i),coordinateSystem(1:3,1,j))) + enddo; enddo - coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) - - do i=1, sum(Nslip); do j=1, sum(Nslip) - projection(i,j) = abs(math_inner(coordinateSystem(1:3,2,i),coordinateSystem(1:3,1,j))) - enddo; enddo - end function slipProjection_direction - - + + !-------------------------------------------------------------------------------------------------- !> @brief build a local coordinate system on slip systems !> @details Order: Direction, plane (normal), and common perpendicular !-------------------------------------------------------------------------------------------------- function coordinateSystem_slip(Nslip,structure,cOverA) result(coordinateSystem) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - - real(pReal), dimension(:,:), allocatable :: slipSystems - integer, dimension(:), allocatable :: NslipMax - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='coordinateSystem_slip: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - NslipMax = LATTICE_FCC_NSLIPSYSTEM - slipSystems = LATTICE_FCC_SYSTEMSLIP - case('bcc') - NslipMax = LATTICE_BCC_NSLIPSYSTEM - slipSystems = LATTICE_BCC_SYSTEMSLIP - case('hex') - NslipMax = LATTICE_HEX_NSLIPSYSTEM - slipSystems = LATTICE_HEX_SYSTEMSLIP - case('bct') - NslipMax = LATTICE_BCT_NSLIPSYSTEM - slipSystems = LATTICE_BCT_SYSTEMSLIP - case default - call IO_error(137,ext_msg='coordinateSystem_slip: '//trim(structure)) - end select - - if (any(NslipMax(1:size(Nslip)) - Nslip < 0)) & - call IO_error(145,ext_msg='Nslip '//trim(structure)) - if (any(Nslip < 0)) & - call IO_error(144,ext_msg='Nslip '//trim(structure)) - - coordinateSystem = buildCoordinateSystem(Nslip,NslipMax,slipSystems,structure,cOverA) - -end function coordinateSystem_slip - - -!-------------------------------------------------------------------------------------------------- -!> @brief Populates reduced interaction matrix -!-------------------------------------------------------------------------------------------------- -function buildInteraction(acting_used,reacting_used,acting_max,reacting_max,values,matrix) use IO, only: & IO_error - implicit none - integer, dimension(:), intent(in) :: & - acting_used, & !< # of acting systems per family as specified in material.config - reacting_used, & !< # of reacting systems per family as specified in material.config - acting_max, & !< max # of acting systems per family for given lattice - reacting_max !< max # of reacting systems per family for given lattice - real(pReal), dimension(:), intent(in) :: values !< interaction values - integer, dimension(:,:), intent(in) :: matrix !< interaction types - real(pReal), dimension(sum(acting_used),sum(reacting_used)) :: buildInteraction + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + + real(pReal), dimension(:,:), allocatable :: slipSystems + integer, dimension(:), allocatable :: NslipMax - integer :: & - acting_family_index, acting_family, acting_system, & - reacting_family_index, reacting_family, reacting_system, & - i,j,k,l + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='coordinateSystem_slip: '//trim(structure)) - do acting_family = 1,size(acting_used,1) - acting_family_index = sum(acting_used(1:acting_family-1)) - do acting_system = 1,acting_used(acting_family) + select case(structure(1:3)) + case('fcc') + NslipMax = LATTICE_FCC_NSLIPSYSTEM + slipSystems = LATTICE_FCC_SYSTEMSLIP + case('bcc') + NslipMax = LATTICE_BCC_NSLIPSYSTEM + slipSystems = LATTICE_BCC_SYSTEMSLIP + case('hex') + NslipMax = LATTICE_HEX_NSLIPSYSTEM + slipSystems = LATTICE_HEX_SYSTEMSLIP + case('bct') + NslipMax = LATTICE_BCT_NSLIPSYSTEM + slipSystems = LATTICE_BCT_SYSTEMSLIP + case default + call IO_error(137,ext_msg='coordinateSystem_slip: '//trim(structure)) + end select + + if (any(NslipMax(1:size(Nslip)) - Nslip < 0)) & + call IO_error(145,ext_msg='Nslip '//trim(structure)) + if (any(Nslip < 0)) & + call IO_error(144,ext_msg='Nslip '//trim(structure)) + + coordinateSystem = buildCoordinateSystem(Nslip,NslipMax,slipSystems,structure,cOverA) + +end function coordinateSystem_slip + + +!-------------------------------------------------------------------------------------------------- +!> @brief Populates reduced interaction matrix +!-------------------------------------------------------------------------------------------------- +function buildInteraction(reacting_used,acting_used,reacting_max,acting_max,values,matrix) + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: & + reacting_used, & !< # of reacting systems per family as specified in material.config + acting_used, & !< # of acting systems per family as specified in material.config + reacting_max, & !< max # of reacting systems per family for given lattice + acting_max !< max # of acting systems per family for given lattice + real(pReal), dimension(:), intent(in) :: values !< interaction values + integer, dimension(:,:), intent(in) :: matrix !< interaction types + real(pReal), dimension(sum(reacting_used),sum(acting_used)) :: buildInteraction + + integer :: & + acting_family_index, acting_family, acting_system, & + reacting_family_index, reacting_family, reacting_system, & + i,j,k,l + + do acting_family = 1,size(acting_used,1) + acting_family_index = sum(acting_used(1:acting_family-1)) + do acting_system = 1,acting_used(acting_family) + + do reacting_family = 1,size(reacting_used,1) + reacting_family_index = sum(reacting_used(1:reacting_family-1)) + do reacting_system = 1,reacting_used(reacting_family) + + i = sum( acting_max(1: acting_family-1)) + acting_system + j = sum(reacting_max(1:reacting_family-1)) + reacting_system + + k = acting_family_index + acting_system + l = reacting_family_index + reacting_system + + if (matrix(i,j) > size(values)) call IO_error(138,ext_msg='buildInteraction') + + buildInteraction(l,k) = values(matrix(i,j)) + + enddo; enddo + enddo; enddo - do reacting_family = 1,size(reacting_used,1) - reacting_family_index = sum(reacting_used(1:reacting_family-1)) - do reacting_system = 1,reacting_used(reacting_family) - - i = sum( acting_max(1: acting_family-1)) + acting_system - j = sum(reacting_max(1:reacting_family-1)) + reacting_system - - k = acting_family_index + acting_system - l = reacting_family_index + reacting_system - - if (matrix(i,j) > size(values)) call IO_error(138,ext_msg='buildInteraction') - - buildInteraction(k,l) = values(matrix(i,j)) - - enddo; enddo - enddo; enddo - end function buildInteraction - - + + !-------------------------------------------------------------------------------------------------- !> @brief build a local coordinate system on slip, twin, trans, cleavage systems !> @details Order: Direction, plane (normal), and common perpendicular !-------------------------------------------------------------------------------------------------- function buildCoordinateSystem(active,complete,system,structure,cOverA) - use IO, only: & - IO_error - use math, only: & - math_cross - - implicit none - integer, dimension(:), intent(in) :: & - active, & - complete - real(pReal), dimension(:,:), intent(in) :: & - system - character(len=*), intent(in) :: & - structure !< lattice structure - real(pReal), intent(in) :: & - cOverA - real(pReal), dimension(3,3,sum(active)) :: & - buildCoordinateSystem - - real(pReal), dimension(3) :: & - direction, normal - integer :: & - a, & !< index of active system - c, & !< index in complete system matrix - f, & !< index of my family - s !< index of my system in current family - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='buildCoordinateSystem: '//trim(structure)) - if (trim(structure(1:3)) == 'bct' .and. cOverA > 2.0_pReal) & - call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(structure)) - if (trim(structure(1:3)) == 'hex' .and. (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal)) & - call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(structure)) - - a = 0 - activeFamilies: do f = 1,size(active,1) - activeSystems: do s = 1,active(f) - a = a + 1 - c = sum(complete(1:f-1))+s - - select case(trim(structure(1:3))) - - case ('fcc','bcc','iso','ort','bct') - direction = system(1:3,c) - normal = system(4:6,c) - - case ('hex') - direction = [ system(1,c)*1.5_pReal, & - (system(1,c)+2.0_pReal*system(2,c))*sqrt(0.75_pReal), & - system(4,c)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]) - normal = [ system(5,c), & - (system(5,c)+2.0_pReal*system(6,c))/sqrt(3.0_pReal), & - system(8,c)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) - - case default - call IO_error(137,ext_msg='buildCoordinateSystem: '//trim(structure)) - - end select - - buildCoordinateSystem(1:3,1,a) = direction/norm2(direction) - buildCoordinateSystem(1:3,2,a) = normal/norm2(normal) - buildCoordinateSystem(1:3,3,a) = math_cross(buildCoordinateSystem(1:3,1,a),& - buildCoordinateSystem(1:3,2,a)) - - enddo activeSystems - enddo activeFamilies - + use IO, only: & + IO_error + use math, only: & + math_cross + + integer, dimension(:), intent(in) :: & + active, & + complete + real(pReal), dimension(:,:), intent(in) :: & + system + character(len=*), intent(in) :: & + structure !< lattice structure + real(pReal), intent(in) :: & + cOverA + real(pReal), dimension(3,3,sum(active)) :: & + buildCoordinateSystem + + real(pReal), dimension(3) :: & + direction, normal + integer :: & + a, & !< index of active system + c, & !< index in complete system matrix + f, & !< index of my family + s !< index of my system in current family + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='buildCoordinateSystem: '//trim(structure)) + if (trim(structure(1:3)) == 'bct' .and. cOverA > 2.0_pReal) & + call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(structure)) + if (trim(structure(1:3)) == 'hex' .and. (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal)) & + call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(structure)) + + a = 0 + activeFamilies: do f = 1,size(active,1) + activeSystems: do s = 1,active(f) + a = a + 1 + c = sum(complete(1:f-1))+s + + select case(trim(structure(1:3))) + + case ('fcc','bcc','iso','ort','bct') + direction = system(1:3,c) + normal = system(4:6,c) + + case ('hex') + direction = [ system(1,c)*1.5_pReal, & + (system(1,c)+2.0_pReal*system(2,c))*sqrt(0.75_pReal), & + system(4,c)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]) + normal = [ system(5,c), & + (system(5,c)+2.0_pReal*system(6,c))/sqrt(3.0_pReal), & + system(8,c)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) + + case default + call IO_error(137,ext_msg='buildCoordinateSystem: '//trim(structure)) + + end select + + buildCoordinateSystem(1:3,1,a) = direction/norm2(direction) + buildCoordinateSystem(1:3,2,a) = normal/norm2(normal) + buildCoordinateSystem(1:3,3,a) = math_cross(buildCoordinateSystem(1:3,1,a),& + buildCoordinateSystem(1:3,2,a)) + + enddo activeSystems + enddo activeFamilies + end function buildCoordinateSystem - - + + !-------------------------------------------------------------------------------------------------- !> @brief Helper function to define transformation systems ! Needed to calculate Schmid matrix and rotated stiffness matrices. @@ -2394,139 +2370,138 @@ end function buildCoordinateSystem ! set a_bcc = 0.0 for fcc -> hex transformation !-------------------------------------------------------------------------------------------------- subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc) - use prec, only: & - dEq0 - use math, only: & - math_cross, & - math_outer, & - math_axisAngleToR, & - INRAD, & - MATH_I3 - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: & - Ntrans - real(pReal), dimension(3,3,sum(Ntrans)), intent(out) :: & - Q, & !< Total rotation: Q = R*B - S !< Eigendeformation tensor for phase transformation - real(pReal), intent(in) :: & - cOverA, & !< c/a for target hex structure - a_bcc, & !< lattice parameter a for target bcc structure - a_fcc !< lattice parameter a for parent fcc structure - - real(pReal), dimension(3,3) :: & - R, & !< Pitsch rotation - U, & !< Bain deformation - B, & !< Rotation of fcc to Bain coordinate system - ss, sd - real(pReal), dimension(3) :: & - x, y, z - integer :: & - i - real(pReal), dimension(3+3,LATTICE_FCC_NTRANS), parameter :: & - LATTICE_FCCTOHEX_SYSTEMTRANS = reshape(real( [& - -2, 1, 1, 1, 1, 1, & - 1,-2, 1, 1, 1, 1, & - 1, 1,-2, 1, 1, 1, & - 2,-1, 1, -1,-1, 1, & - -1, 2, 1, -1,-1, 1, & - -1,-1,-2, -1,-1, 1, & - -2,-1,-1, 1,-1,-1, & - 1, 2,-1, 1,-1,-1, & - 1,-1, 2, 1,-1,-1, & - 2, 1,-1, -1, 1,-1, & - -1,-2,-1, -1, 1,-1, & - -1, 1, 2, -1, 1,-1 & - ],pReal),shape(LATTICE_FCCTOHEX_SYSTEMTRANS)) - real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter :: & - LATTICE_FCCTOBCC_SYSTEMTRANS = 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, & - 0.0, 0.0, 1.0, -10.26, & - 1.0, 0.0, 0.0, 10.26, & - 1.0, 0.0, 0.0, -10.26, & - 0.0, 0.0, 1.0, 10.26, & - 0.0, 0.0, 1.0, -10.26, & - 1.0, 0.0, 0.0, 10.26, & - 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(LATTICE_FCCTOBCC_SYSTEMTRANS)) - - integer, dimension(9,LATTICE_fcc_Ntrans), parameter :: & - LATTICE_FCCTOBCC_BAINVARIANT = reshape( [& - 1, 0, 0, 0, 1, 0, 0, 0, 1, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) - 1, 0, 0, 0, 1, 0, 0, 0, 1, & - 1, 0, 0, 0, 1, 0, 0, 0, 1, & - 1, 0, 0, 0, 1, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 0, 1, 1, 0, 0, 0, 1, 0, & - 0, 0, 1, 1, 0, 0, 0, 1, 0, & - 0, 0, 1, 1, 0, 0, 0, 1, 0, & - 0, 0, 1, 1, 0, 0, 0, 1, 0 & - ],shape(LATTICE_FCCTOBCC_BAINVARIANT)) - - real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter :: & - LATTICE_FCCTOBCC_BAINROT = reshape([& - 1.0, 0.0, 0.0, 45.0, & ! Rotate fcc austensite to bain variant - 1.0, 0.0, 0.0, 45.0, & - 1.0, 0.0, 0.0, 45.0, & - 1.0, 0.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 0.0, 1.0, 45.0, & - 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(LATTICE_FCCTOBCC_BAINROT)) - - if (size(Ntrans) < 1 .or. size(Ntrans) > 1) & - call IO_error(0) !ToDo: define error - - if (a_bcc > 0.0_pReal .and. dEq0(cOverA)) then ! fcc -> bcc transformation - do i = 1,sum(Ntrans) - R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & - lattice_fccTobcc_systemTrans(4,i)*INRAD) - B = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & - lattice_fccTobcc_bainRot(4,i)*INRAD) - x = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) - y = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) - z = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) - - U = (a_bcc/a_fcc)*math_outer(x,x) & - + (a_bcc/a_fcc)*math_outer(y,y) * sqrt(2.0_pReal) & - + (a_bcc/a_fcc)*math_outer(z,z) * sqrt(2.0_pReal) - Q(1:3,1:3,i) = matmul(R,B) - S(1:3,1:3,i) = matmul(R,U) - MATH_I3 - enddo - elseif (cOverA > 0.0_pReal .and. dEq0(a_bcc)) then ! fcc -> hex transformation - ss = MATH_I3 - sd = MATH_I3 - ss(1,3) = sqrt(2.0_pReal)/4.0_pReal - if (cOverA > 1.0_pReal .and. cOverA < 2.0_pReal) & - sd(3,3) = cOverA/sqrt(8.0_pReal/3.0_pReal) - - do i = 1,sum(Ntrans) - x = lattice_fccTohex_systemTrans(1:3,i)/norm2(lattice_fccTohex_systemTrans(1:3,i)) - z = lattice_fccTohex_systemTrans(4:6,i)/norm2(lattice_fccTohex_systemTrans(4:6,i)) - y = -math_cross(x,z) - Q(1:3,1,i) = x - Q(1:3,2,i) = y - Q(1:3,3,i) = z - S(1:3,1:3,i) = matmul(Q(1:3,1:3,i), matmul(matmul(sd,ss), transpose(Q(1:3,1:3,i)))) - MATH_I3 ! ToDo: This is of interest for the Schmid matrix only - enddo - else - call IO_error(0) !ToDo: define error - endif - + use prec, only: & + dEq0 + use math, only: & + math_cross, & + math_outer, & + math_axisAngleToR, & + INRAD, & + MATH_I3 + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: & + Ntrans + real(pReal), dimension(3,3,sum(Ntrans)), intent(out) :: & + Q, & !< Total rotation: Q = R*B + S !< Eigendeformation tensor for phase transformation + real(pReal), intent(in) :: & + cOverA, & !< c/a for target hex structure + a_bcc, & !< lattice parameter a for target bcc structure + a_fcc !< lattice parameter a for parent fcc structure + + real(pReal), dimension(3,3) :: & + R, & !< Pitsch rotation + U, & !< Bain deformation + B, & !< Rotation of fcc to Bain coordinate system + ss, sd + real(pReal), dimension(3) :: & + x, y, z + integer :: & + i + real(pReal), dimension(3+3,LATTICE_FCC_NTRANS), parameter :: & + LATTICE_FCCTOHEX_SYSTEMTRANS = reshape(real( [& + -2, 1, 1, 1, 1, 1, & + 1,-2, 1, 1, 1, 1, & + 1, 1,-2, 1, 1, 1, & + 2,-1, 1, -1,-1, 1, & + -1, 2, 1, -1,-1, 1, & + -1,-1,-2, -1,-1, 1, & + -2,-1,-1, 1,-1,-1, & + 1, 2,-1, 1,-1,-1, & + 1,-1, 2, 1,-1,-1, & + 2, 1,-1, -1, 1,-1, & + -1,-2,-1, -1, 1,-1, & + -1, 1, 2, -1, 1,-1 & + ],pReal),shape(LATTICE_FCCTOHEX_SYSTEMTRANS)) + real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter :: & + LATTICE_FCCTOBCC_SYSTEMTRANS = 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, & + 0.0, 0.0, 1.0, -10.26, & + 1.0, 0.0, 0.0, 10.26, & + 1.0, 0.0, 0.0, -10.26, & + 0.0, 0.0, 1.0, 10.26, & + 0.0, 0.0, 1.0, -10.26, & + 1.0, 0.0, 0.0, 10.26, & + 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(LATTICE_FCCTOBCC_SYSTEMTRANS)) + + integer, dimension(9,LATTICE_fcc_Ntrans), parameter :: & + LATTICE_FCCTOBCC_BAINVARIANT = reshape( [& + 1, 0, 0, 0, 1, 0, 0, 0, 1, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) + 1, 0, 0, 0, 1, 0, 0, 0, 1, & + 1, 0, 0, 0, 1, 0, 0, 0, 1, & + 1, 0, 0, 0, 1, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 0, 1, 1, 0, 0, 0, 1, 0, & + 0, 0, 1, 1, 0, 0, 0, 1, 0, & + 0, 0, 1, 1, 0, 0, 0, 1, 0, & + 0, 0, 1, 1, 0, 0, 0, 1, 0 & + ],shape(LATTICE_FCCTOBCC_BAINVARIANT)) + + real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter :: & + LATTICE_FCCTOBCC_BAINROT = reshape([& + 1.0, 0.0, 0.0, 45.0, & ! Rotate fcc austensite to bain variant + 1.0, 0.0, 0.0, 45.0, & + 1.0, 0.0, 0.0, 45.0, & + 1.0, 0.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 0.0, 1.0, 45.0, & + 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(LATTICE_FCCTOBCC_BAINROT)) + + if (size(Ntrans) < 1 .or. size(Ntrans) > 1) & + call IO_error(0) !ToDo: define error + + if (a_bcc > 0.0_pReal .and. dEq0(cOverA)) then ! fcc -> bcc transformation + do i = 1,sum(Ntrans) + R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & + lattice_fccTobcc_systemTrans(4,i)*INRAD) + B = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & + lattice_fccTobcc_bainRot(4,i)*INRAD) + x = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) + y = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) + z = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) + + U = (a_bcc/a_fcc)*math_outer(x,x) & + + (a_bcc/a_fcc)*math_outer(y,y) * sqrt(2.0_pReal) & + + (a_bcc/a_fcc)*math_outer(z,z) * sqrt(2.0_pReal) + Q(1:3,1:3,i) = matmul(R,B) + S(1:3,1:3,i) = matmul(R,U) - MATH_I3 + enddo + elseif (cOverA > 0.0_pReal .and. dEq0(a_bcc)) then ! fcc -> hex transformation + ss = MATH_I3 + sd = MATH_I3 + ss(1,3) = sqrt(2.0_pReal)/4.0_pReal + if (cOverA > 1.0_pReal .and. cOverA < 2.0_pReal) & + sd(3,3) = cOverA/sqrt(8.0_pReal/3.0_pReal) + + do i = 1,sum(Ntrans) + x = lattice_fccTohex_systemTrans(1:3,i)/norm2(lattice_fccTohex_systemTrans(1:3,i)) + z = lattice_fccTohex_systemTrans(4:6,i)/norm2(lattice_fccTohex_systemTrans(4:6,i)) + y = -math_cross(x,z) + Q(1:3,1,i) = x + Q(1:3,2,i) = y + Q(1:3,3,i) = z + S(1:3,1:3,i) = matmul(Q(1:3,1:3,i), matmul(matmul(sd,ss), transpose(Q(1:3,1:3,i)))) - MATH_I3 ! ToDo: This is of interest for the Schmid matrix only + enddo + else + call IO_error(0) !ToDo: define error + endif + end subroutine buildTransformationSystem - + end module lattice diff --git a/src/material.f90 b/src/material.f90 index d35cfebd4..383462ae1 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -147,16 +147,14 @@ module material damage_initialPhi !< initial damage per each homogenization ! NEW MAPPINGS - integer(pInt), dimension(:), allocatable, public, protected :: & - material_homogenizationAt, & !< homogenization ID of each element (copy of mesh_homogenizationAt) - material_homogenizationMemberAt, & !< position of the element within its homogenization instance - material_aggregateAt, & !< aggregate ID of each element FUTURE USE FOR OUTPUT - material_aggregatMemberAt !< position of the element within its aggregate instance FUTURE USE FOR OUTPUT - integer(pInt), dimension(:,:), allocatable, public, protected :: & - material_phaseAt, & !< phase ID of each element - material_phaseMemberAt, & !< position of the element within its phase instance - material_crystalliteAt, & !< crystallite ID of each element CURRENTLY NOT PER CONSTITUTENT - material_crystalliteMemberAt !< position of the element within its crystallite instance CURRENTLY NOT PER CONSTITUTENT + integer, dimension(:), allocatable, public, protected :: & ! (elem) + material_homogenizationAt !< homogenization ID of each element (copy of mesh_homogenizationAt) + integer, dimension(:,:), allocatable, public, protected :: & ! (ip,elem) + material_homogenizationMemberAt !< position of the element within its homogenization instance + integer, dimension(:,:), allocatable, public, protected :: & ! (constituent,elem) + material_phaseAt !< phase ID of each element + integer, dimension(:,:,:), allocatable, public, protected :: & ! (constituent,ip,elem) + material_phaseMemberAt !< position of the element within its phase instance ! END NEW MAPPINGS ! DEPRECATED: use material_phaseAt @@ -275,7 +273,10 @@ contains !> @details figures out if solverJobName.materialConfig is present, if not looks for !> material.config !-------------------------------------------------------------------------------------------------- -subroutine material_init() +subroutine material_init +#if defined(PETSc) || defined(DAMASK_HDF5) + use results +#endif use IO, only: & IO_error use debug, only: & @@ -382,21 +383,57 @@ subroutine material_init() endif debugOut call material_populateGrains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! new mappings + allocate(material_homogenizationAt,source=theMesh%homogenizationAt) + allocate(material_homogenizationMemberAt(theMesh%elem%nIPs,theMesh%Nelems),source=0) + allocate(CounterHomogenization(size(config_homogenization)),source=0) + do e = 1, theMesh%Nelems + do i = 1, theMesh%elem%nIPs + CounterHomogenization(material_homogenizationAt(e)) = & + CounterHomogenization(material_homogenizationAt(e)) + 1 + material_homogenizationMemberAt(i,e) = CounterHomogenization(material_homogenizationAt(e)) + enddo + enddo + + + allocate(material_phaseAt(homogenization_maxNgrains,theMesh%Nelems), source=material_phase(:,1,:)) + allocate(material_phaseMemberAt(homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0) + + allocate(CounterPhase(size(config_phase)),source=0) + do e = 1, theMesh%Nelems + do i = 1, theMesh%elem%nIPs + do c = 1, homogenization_maxNgrains + CounterPhase(material_phaseAt(c,e)) = & + CounterPhase(material_phaseAt(c,e)) + 1 + material_phaseMemberAt(c,i,e) = CounterPhase(material_phaseAt(c,e)) + enddo + enddo + enddo + +#if defined(PETSc) || defined(DAMASK_HDF5) + call results_openJobFile + call results_mapping_constituent(material_phaseAt,material_phaseMemberAt,phase_name) + call results_mapping_materialpoint(material_homogenizationAt,material_homogenizationMemberAt,homogenization_name) + call results_closeJobFile +#endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! BEGIN DEPRECATED allocate(phaseAt ( homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0_pInt) allocate(phasememberAt ( homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0_pInt) allocate(mappingHomogenization (2, theMesh%elem%nIPs,theMesh%Nelems),source=0_pInt) allocate(mappingHomogenizationConst( theMesh%elem%nIPs,theMesh%Nelems),source=1_pInt) -! END DEPRECATED - - allocate(material_homogenizationAt,source=theMesh%homogenizationAt) - allocate(material_AggregateAt, source=theMesh%homogenizationAt) - allocate(CounterPhase (size(config_phase)), source=0_pInt) - allocate(CounterHomogenization(size(config_homogenization)),source=0_pInt) + CounterHomogenization=0 + CounterPhase =0 + -! BEGIN DEPRECATED do e = 1_pInt,theMesh%Nelems myHomog = theMesh%homogenizationAt(e) do i = 1_pInt, theMesh%elem%nIPs @@ -819,34 +856,9 @@ subroutine material_parseTexture if(dNeq(math_det33(texture_transformation(1:3,1:3,t)),1.0_pReal)) call IO_error(157_pInt,t) endif - if (config_texture(t)%keyExists('symmetry')) then - select case (config_texture(t)%getString('symmetry')) - case('orthotropic') - texture_symmetry(t) = 4_pInt - case('monoclinic') - texture_symmetry(t) = 2_pInt - case default - texture_symmetry(t) = 1_pInt - end select - endif - - if (config_texture(t)%keyExists('(random)')) then - strings = config_texture(t)%getStrings('(random)',raw=.true.) - do i = 1_pInt, size(strings) - gauss = gauss + 1_pInt - texture_Gauss(1:3,gauss,t) = math_sampleRandomOri() - chunkPos = IO_stringPos(strings(i)) - do j = 1_pInt,3_pInt,2_pInt - select case (IO_stringValue(strings(i),chunkPos,j)) - case('scatter') - texture_Gauss(4,gauss,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('fraction') - texture_Gauss(5,gauss,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt) - end select - enddo - enddo - endif - + if (config_texture(t)%keyExists('symmetry')) call IO_error(147,ext_msg='symmetry') + if (config_texture(t)%keyExists('(random)')) call IO_error(147,ext_msg='(random)') + if (config_texture(t)%keyExists('(fiber)')) call IO_error(147,ext_msg='(fiber)') if (config_texture(t)%keyExists('(gauss)')) then gauss = gauss + 1_pInt @@ -869,31 +881,6 @@ subroutine material_parseTexture enddo enddo endif - - - if (config_texture(t)%keyExists('(fiber)')) then - fiber = fiber + 1_pInt - strings = config_texture(t)%getStrings('(fiber)',raw= .true.) - do i = 1_pInt, size(strings) - chunkPos = IO_stringPos(strings(i)) - do j = 1_pInt,11_pInt,2_pInt - select case (IO_stringValue(strings(i),chunkPos,j)) - case('alpha1') - texture_Fiber(1,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('alpha2') - texture_Fiber(2,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('beta1') - texture_Fiber(3,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('beta2') - texture_Fiber(4,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('scatter') - texture_Fiber(5,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('fraction') - texture_Fiber(6,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt) - end select - enddo - enddo - endif enddo call config_deallocate('material.config/texture') @@ -1003,11 +990,7 @@ subroutine material_populateGrains math_RtoEuler, & math_EulerToR, & math_mul33x33, & - math_range, & - math_sampleRandomOri, & - math_sampleGaussOri, & - math_sampleFiberOri, & - math_symmetricEulers + math_range use mesh, only: & theMesh, & mesh_ipVolume @@ -1189,28 +1172,12 @@ subroutine material_populateGrains ! has texture components gauss: do t = 1_pInt,texture_Ngauss(textureID) ! loop over Gauss components do g = 1_pInt,int(real(myNorientations,pReal)*texture_Gauss(5,t,textureID),pInt) ! loop over required grain count - orientationOfGrain(:,grain+constituentGrain+g) = & - math_sampleGaussOri(texture_Gauss(1:3,t,textureID),& - texture_Gauss( 4,t,textureID)) + orientationOfGrain(:,grain+constituentGrain+g) = texture_Gauss(1:3,t,textureID) enddo constituentGrain = & constituentGrain + int(real(myNorientations,pReal)*texture_Gauss(5,t,textureID)) ! advance counter for grains of current constituent enddo gauss - fiber: do t = 1_pInt,texture_Nfiber(textureID) ! loop over fiber components - do g = 1_pInt,int(real(myNorientations,pReal)*texture_Fiber(6,t,textureID),pInt) ! loop over required grain count - orientationOfGrain(:,grain+constituentGrain+g) = & - math_sampleFiberOri(texture_Fiber(1:2,t,textureID),& - texture_Fiber(3:4,t,textureID),& - texture_Fiber( 5,t,textureID)) - enddo - constituentGrain = & - constituentGrain + int(real(myNorientations,pReal)*texture_fiber(6,t,textureID),pInt) ! advance counter for grains of current constituent - enddo fiber - - random: do constituentGrain = constituentGrain+1_pInt,myNorientations ! fill remainder with random - orientationOfGrain(:,grain+constituentGrain) = math_sampleRandomOri() - enddo random !-------------------------------------------------------------------------------------------------- ! ...texture transformation @@ -1224,25 +1191,6 @@ subroutine material_populateGrains ) enddo -!-------------------------------------------------------------------------------------------------- -! ...sample symmetry - - symExtension = texture_symmetry(textureID) - 1_pInt - if (symExtension > 0_pInt) then ! sample symmetry (number of additional equivalent orientations) - constituentGrain = myNorientations ! start right after "real" orientations - do j = 1_pInt,myNorientations ! loop over each "real" orientation - symOrientation = math_symmetricEulers(texture_symmetry(textureID), & - orientationOfGrain(1:3,grain+j)) ! get symmetric equivalents - e = min(symExtension,NgrainsOfConstituent(i)-constituentGrain) ! do not overshoot end of constituent grain array - if (e > 0_pInt) then - orientationOfGrain(1:3,grain+constituentGrain+1: & - grain+constituentGrain+e) = & - symOrientation(1:3,1:e) - constituentGrain = constituentGrain + e ! remainder shrinks by e - endif - enddo - endif - !-------------------------------------------------------------------------------------------------- ! shuffle grains within current constituent diff --git a/src/DAMASK_FEM.f90 b/src/mesh/DAMASK_FEM.f90 similarity index 100% rename from src/DAMASK_FEM.f90 rename to src/mesh/DAMASK_FEM.f90 diff --git a/src/FEM_mech.f90 b/src/mesh/FEM_mech.f90 similarity index 100% rename from src/FEM_mech.f90 rename to src/mesh/FEM_mech.f90 diff --git a/src/FEM_utilities.f90 b/src/mesh/FEM_utilities.f90 similarity index 100% rename from src/FEM_utilities.f90 rename to src/mesh/FEM_utilities.f90 diff --git a/src/FEM_zoo.f90 b/src/mesh/FEM_zoo.f90 similarity index 100% rename from src/FEM_zoo.f90 rename to src/mesh/FEM_zoo.f90 diff --git a/src/numerics.f90 b/src/numerics.f90 index 955696219..f7c603c60 100644 --- a/src/numerics.f90 +++ b/src/numerics.f90 @@ -21,7 +21,7 @@ module numerics pert_method = 1_pInt, & !< method used in perturbation technique for tangent randomSeed = 0_pInt, & !< fixed seeding for pseudo-random number generator, Default 0: use random seed worldrank = 0_pInt, & !< MPI worldrank (/=0 for MPI simulations only) - worldsize = 0_pInt, & !< MPI worldsize (/=0 for MPI simulations only) + worldsize = 1_pInt, & !< MPI worldsize (/=1 for MPI simulations only) numerics_integrator = 1_pInt !< method used for state integration Default 1: fix-point iteration integer(4), protected, public :: & DAMASK_NumThreadsInt = 0 !< value stored in environment variable DAMASK_NUM_THREADS, set to zero if no OpenMP directive diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index ccb37be48..56d910011 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -126,7 +126,6 @@ subroutine plastic_disloUCLA_init() config_phase use lattice - implicit none integer :: & Ninstance, & p, i, & @@ -200,9 +199,9 @@ subroutine plastic_disloUCLA_init() prm%nonSchmid_neg = prm%Schmid endif - prm%h_sl_sl = transpose(lattice_interaction_SlipBySlip(prm%N_sl, & + prm%h_sl_sl = lattice_interaction_SlipBySlip(prm%N_sl, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%forestProjectionEdge = lattice_forestProjection(prm%N_sl,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) @@ -353,7 +352,6 @@ end subroutine plastic_disloUCLA_init !-------------------------------------------------------------------------------------------------- pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp, & Mp,T,instance,of) - implicit none real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & @@ -403,7 +401,6 @@ subroutine plastic_disloUCLA_dotState(Mp,T,instance,of) PI, & math_clip - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -464,7 +461,6 @@ end subroutine plastic_disloUCLA_dotState !-------------------------------------------------------------------------------------------------- subroutine plastic_disloUCLA_dependentState(instance,of) - implicit none integer, intent(in) :: & instance, & of @@ -499,7 +495,6 @@ function plastic_disloUCLA_postResults(Mp,T,instance,of) result(postResults) PI, & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -552,23 +547,40 @@ end function plastic_disloUCLA_postResults !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_disloUCLA_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) - use results +#if defined(PETSc) || defined(DAMASK_HDF5) + use results, only: & + results_writeDataset - implicit none - integer, intent(in) :: instance - character(len=*) :: group + integer, intent(in) :: instance + character(len=*), intent(in) :: group + integer :: o - associate(prm => param(instance), stt => state(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + case (rho_mob_ID) + call results_writeDataset(group,stt%rho_mob,'rho_mob',& + 'mobile dislocation density','1/m²') + case (rho_dip_ID) + call results_writeDataset(group,stt%rho_dip,'rho_dip',& + 'dislocation dipole density''1/m²') + case (dot_gamma_sl_ID) + call results_writeDataset(group,stt%gamma_sl,'dot_gamma_sl',& + 'plastic shear','1') + case (Lambda_sl_ID) + call results_writeDataset(group,dst%Lambda_sl,'Lambda_sl',& + 'mean free path for slip','m') + case (thresholdstress_ID) + call results_writeDataset(group,dst%threshold_stress,'threshold_stress',& + 'threshold stress for slip','Pa') end select enddo outputsLoop end associate + #else - integer, intent(in) :: instance - character(len=*) :: group + integer, intent(in) :: instance + character(len=*), intent(in) :: group #endif end subroutine plastic_disloUCLA_results @@ -590,7 +602,6 @@ pure subroutine kinetics(Mp,T,instance,of, & PI, & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index ed6638c4f..7db1f5f7f 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -148,7 +148,7 @@ module plastic_dislotwin type(tDislotwinState), allocatable, dimension(:), private :: & dotState, & state - type(tDislotwinMicrostructure), allocatable, dimension(:), private :: microstructure + type(tDislotwinMicrostructure), allocatable, dimension(:), private :: dependentState public :: & plastic_dislotwin_init, & @@ -190,7 +190,6 @@ subroutine plastic_dislotwin_init config_phase use lattice - implicit none integer :: & Ninstance, & p, i, & @@ -233,14 +232,14 @@ subroutine plastic_dislotwin_init allocate(param(Ninstance)) allocate(state(Ninstance)) allocate(dotState(Ninstance)) - allocate(microstructure(Ninstance)) + allocate(dependentState(Ninstance)) do p = 1, size(phase_plasticity) if (phase_plasticity(p) /= PLASTICITY_DISLOTWIN_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & stt => state(phase_plasticityInstance(p)), & - dst => microstructure(phase_plasticityInstance(p)), & + dst => dependentState(phase_plasticityInstance(p)), & config => config_phase(p)) prm%aTol_rho = config%getFloat('atol_rho', defaultVal=0.0_pReal) @@ -260,9 +259,9 @@ subroutine plastic_dislotwin_init slipActive: if (prm%sum_N_sl > 0) then prm%P_sl = lattice_SchmidMatrix_slip(prm%N_sl,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%h_sl_sl = transpose(lattice_interaction_SlipBySlip(prm%N_sl, & + prm%h_sl_sl = lattice_interaction_SlipBySlip(prm%N_sl, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%forestProjection = lattice_forestProjection (prm%N_sl,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) @@ -324,9 +323,9 @@ subroutine plastic_dislotwin_init if (prm%sum_N_tw > 0) then prm%P_tw = lattice_SchmidMatrix_twin(prm%N_tw,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%h_tw_tw = transpose(lattice_interaction_TwinByTwin(prm%N_tw,& + prm%h_tw_tw = lattice_interaction_TwinByTwin(prm%N_tw,& config%getFloats('interaction_twintwin'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%b_tw = config%getFloats('twinburgers', requiredSize=size(prm%N_tw)) prm%t_tw = config%getFloats('twinsize', requiredSize=size(prm%N_tw)) @@ -366,15 +365,15 @@ subroutine plastic_dislotwin_init prm%b_tr = config%getFloats('transburgers') prm%b_tr = math_expand(prm%b_tr,prm%N_tr) - prm%h = config%getFloat('transstackheight', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%i_tr = config%getFloat('cmfptrans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%gamma_fcc_hex = config%getFloat('deltag') - prm%xc_trans = config%getFloat('xc_trans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%L_tr = config%getFloat('l0_trans') + prm%h = config%getFloat('transstackheight', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%i_tr = config%getFloat('cmfptrans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%gamma_fcc_hex = config%getFloat('deltag') + prm%xc_trans = config%getFloat('xc_trans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%L_tr = config%getFloat('l0_trans') - prm%h_tr_tr = transpose(lattice_interaction_TransByTrans(prm%N_tr,& - config%getFloats('interaction_transtrans'), & - config%getString('lattice_structure'))) + prm%h_tr_tr = lattice_interaction_TransByTrans(prm%N_tr,& + config%getFloats('interaction_transtrans'), & + config%getString('lattice_structure')) prm%C66_tr = lattice_C66_trans(prm%N_tr,prm%C66, & config%getString('trans_lattice_structure'), & @@ -382,7 +381,7 @@ subroutine plastic_dislotwin_init config%getFloat('a_bcc', defaultVal=0.0_pReal), & config%getFloat('a_fcc', defaultVal=0.0_pReal)) - prm%P_tr = lattice_SchmidMatrix_trans(prm%N_tr, & + prm%P_tr = lattice_SchmidMatrix_trans(prm%N_tr, & config%getString('trans_lattice_structure'), & 0.0_pReal, & config%getFloat('a_bcc', defaultVal=0.0_pReal), & @@ -408,16 +407,16 @@ subroutine plastic_dislotwin_init endif if (prm%sum_N_sl > 0 .and. prm%sum_N_tw > 0) then - prm%h_sl_tw = transpose(lattice_interaction_SlipByTwin(prm%N_sl,prm%N_tw,& + prm%h_sl_tw = lattice_interaction_SlipByTwin(prm%N_sl,prm%N_tw,& config%getFloats('interaction_sliptwin'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) if (prm%fccTwinTransNucleation .and. prm%sum_N_tw > 12) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if N_tw is [6,6] endif if (prm%sum_N_sl > 0 .and. prm%sum_N_tr > 0) then - prm%h_sl_tr = transpose(lattice_interaction_SlipByTrans(prm%N_sl,prm%N_tr,& + prm%h_sl_tr = lattice_interaction_SlipByTrans(prm%N_sl,prm%N_tr,& config%getFloats('interaction_sliptrans'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) if (prm%fccTwinTransNucleation .and. prm%sum_N_tr > 12) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if N_tr is [6,6] endif @@ -597,7 +596,6 @@ function plastic_dislotwin_homogenizedC(ipc,ip,el) result(homogenizedC) phase_plasticityInstance, & phasememberAt - implicit none real(pReal), dimension(6,6) :: & homogenizedC integer, intent(in) :: & @@ -645,7 +643,6 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,T,instance,of) math_symmetric33, & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(out) :: Lp real(pReal), dimension(3,3,3,3), intent(out) :: dLp_dMp real(pReal), dimension(3,3), intent(in) :: Mp @@ -768,7 +765,6 @@ subroutine plastic_dislotwin_dotState(Mp,T,instance,of) math_mul33xx33, & PI - implicit none real(pReal), dimension(3,3), intent(in):: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -793,7 +789,7 @@ subroutine plastic_dislotwin_dotState(Mp,T,instance,of) dot_gamma_tr associate(prm => param(instance), stt => state(instance), & - dot => dotstate(instance), dst => microstructure(instance)) + dot => dotstate(instance), dst => dependentState(instance)) f_unrotated = 1.0_pReal & - sum(stt%f_tw(1:prm%sum_N_tw,of)) & @@ -861,7 +857,6 @@ subroutine plastic_dislotwin_dependentState(T,instance,of) use math, only: & PI - implicit none integer, intent(in) :: & instance, & of @@ -889,7 +884,7 @@ subroutine plastic_dislotwin_dependentState(T,instance,of) associate(prm => param(instance),& stt => state(instance),& - dst => microstructure(instance)) + dst => dependentState(instance)) sumf_twin = sum(stt%f_tw(1:prm%sum_N_tw,of)) sumf_trans = sum(stt%f_tr(1:prm%sum_N_tr,of)) @@ -979,7 +974,6 @@ function plastic_dislotwin_postResults(Mp,T,instance,of) result(postResults) PI, & math_mul33xx33 - implicit none real(pReal), dimension(3,3),intent(in) :: & Mp !< 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal), intent(in) :: & @@ -994,7 +988,7 @@ function plastic_dislotwin_postResults(Mp,T,instance,of) result(postResults) integer :: & o,c,j - associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) c = 0 @@ -1055,20 +1049,52 @@ end function plastic_dislotwin_postResults !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_dislotwin_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) - use results +#if defined(PETSc) || defined(DAMASK_HDF5) + use results, only: & + results_writeDataset - implicit none integer, intent(in) :: instance character(len=*) :: group integer :: o - associate(prm => param(instance), stt => state(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + + case (rho_mob_ID) + call results_writeDataset(group,stt%rho_mob,'rho_mob',& + 'mobile dislocation density','1/m²') + case (rho_dip_ID) + call results_writeDataset(group,stt%rho_dip,'rho_dip',& + 'dislocation dipole density''1/m²') + case (dot_gamma_sl_ID) + call results_writeDataset(group,stt%gamma_sl,'dot_gamma_sl',& + 'plastic shear','1') + case (Lambda_sl_ID) + call results_writeDataset(group,dst%Lambda_sl,'Lambda_sl',& + 'mean free path for slip','m') + case (threshold_stress_slip_ID) + call results_writeDataset(group,dst%tau_pass,'tau_pass',& + 'passing stress for slip','Pa') + + case (f_tw_ID) + call results_writeDataset(group,stt%f_tw,'f_tw',& + 'twinned volume fraction','m³/m³') + case (Lambda_tw_ID) + call results_writeDataset(group,dst%Lambda_tw,'Lambda_tw',& + 'mean free path for twinning','m') + case (tau_hat_tw_ID) + call results_writeDataset(group,dst%tau_hat_tw,'tau_hat_tw',& + 'threshold stress for twinning','Pa') + + case (f_tr_ID) + call results_writeDataset(group,stt%f_tr,'f_tr',& + 'martensite volume fraction','m³/m³') + end select enddo outputsLoop end associate + #else integer, intent(in) :: instance character(len=*) :: group @@ -1092,7 +1118,6 @@ pure subroutine kinetics_slip(Mp,T,instance,of, & use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -1122,7 +1147,7 @@ pure subroutine kinetics_slip(Mp,T,instance,of, & tau_eff !< effective resolved stress integer :: i - associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) do i = 1, prm%sum_N_sl tau(i) = math_mul33xx33(Mp,prm%P_sl(1:3,1:3,i)) @@ -1171,7 +1196,6 @@ pure subroutine kinetics_twin(Mp,T,dot_gamma_sl,instance,of,& use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -1195,7 +1219,7 @@ pure subroutine kinetics_twin(Mp,T,dot_gamma_sl,instance,of,& integer :: i,s1,s2 - associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) do i = 1, prm%sum_N_tw tau(i) = math_mul33xx33(Mp,prm%P_tw(1:3,1:3,i)) @@ -1243,7 +1267,6 @@ pure subroutine kinetics_trans(Mp,T,dot_gamma_sl,instance,of,& use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -1267,7 +1290,7 @@ pure subroutine kinetics_trans(Mp,T,dot_gamma_sl,instance,of,& integer :: i,s1,s2 - associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) do i = 1, prm%sum_N_tr tau(i) = math_mul33xx33(Mp,prm%P_tr(1:3,1:3,i)) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 45bc136db..c572f0ded 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -96,7 +96,6 @@ subroutine plastic_isotropic_init config_phase use lattice - implicit none integer :: & Ninstance, & p, i, & @@ -247,7 +246,6 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) math_deviatoric33, & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & @@ -314,7 +312,6 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) math_spherical33, & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(out) :: & Li !< inleastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & @@ -371,7 +368,6 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) math_mul33xx33, & math_deviatoric33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -398,8 +394,7 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) xi_inf_star = prm%xi_inf else xi_inf_star = prm%xi_inf & - + asinh( (dot_gamma / prm%c_1)**(1.0_pReal / prm%c_2) & - )**(1.0_pReal / prm%c_3) & + + asinh( (dot_gamma / prm%c_1)**(1.0_pReal / prm%c_2))**(1.0_pReal / prm%c_3) & / prm%c_4 * (dot_gamma / prm%dot_gamma_0)**(1.0_pReal / prm%n) endif dot%xi(of) = dot_gamma & @@ -425,7 +420,6 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) math_mul33xx33, & math_deviatoric33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -476,14 +470,16 @@ subroutine plastic_isotropic_results(instance,group) #if defined(PETSc) || defined(DAMASKHDF5) use results - implicit none integer, intent(in) :: instance - character(len=*) :: group + character(len=*), intent(in) :: group + integer :: o associate(prm => param(instance), stt => state(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + case (xi_ID) + call results_writeDataset(group,stt%xi,'xi','resistance against plastic flow','Pa') end select enddo outputsLoop end associate diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 6890c7006..861b98da3 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -117,7 +117,6 @@ subroutine plastic_kinehardening_init config_phase use lattice - implicit none integer :: & Ninstance, & p, i, o, & @@ -192,9 +191,9 @@ subroutine plastic_kinehardening_init prm%nonSchmid_pos = prm%Schmid prm%nonSchmid_neg = prm%Schmid endif - prm%interaction_SlipSlip = transpose(lattice_interaction_SlipBySlip(prm%Nslip, & + prm%interaction_SlipSlip = lattice_interaction_SlipBySlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%crss0 = config%getFloats('crss0', requiredSize=size(prm%Nslip)) prm%tau1 = config%getFloats('tau1', requiredSize=size(prm%Nslip)) @@ -335,7 +334,6 @@ end subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- pure subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) - implicit none real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & @@ -378,7 +376,6 @@ end subroutine plastic_kinehardening_LpAndItsTangent !-------------------------------------------------------------------------------------------------- subroutine plastic_kinehardening_dotState(Mp,instance,of) - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -431,7 +428,6 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) debug_levelSelective #endif - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -482,7 +478,6 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -539,10 +534,10 @@ end function plastic_kinehardening_postResults !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_kinehardening_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) - use results +#if defined(PETSc) || defined(DAMASK_HDF5) + use results, only: & + results_writeDataset - implicit none integer, intent(in) :: instance character(len=*) :: group integer :: o @@ -550,6 +545,27 @@ subroutine plastic_kinehardening_results(instance,group) associate(prm => param(instance), stt => state(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + case (crss_ID) + call results_writeDataset(group,stt%crss,'xi_sl', & + 'resistance against plastic slip','Pa') + + case(crss_back_ID) + call results_writeDataset(group,stt%crss_back,'tau_back', & + 'back stress against plastic slip','Pa') + + case (sense_ID) + call results_writeDataset(group,stt%sense,'sense_of_shear','tbd','1') + + case (chi0_ID) + call results_writeDataset(group,stt%chi0,'chi0','tbd','Pa') + + case (gamma0_ID) + call results_writeDataset(group,stt%gamma0,'gamma0','tbd','1') + + case (accshear_ID) + call results_writeDataset(group,stt%accshear,'gamma_sl', & + 'plastic shear','1') + end select enddo outputsLoop end associate @@ -574,7 +590,6 @@ pure subroutine kinetics(Mp,instance,of, & use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & diff --git a/src/plastic_none.f90 b/src/plastic_none.f90 index fb19a9968..4b14266f1 100644 --- a/src/plastic_none.f90 +++ b/src/plastic_none.f90 @@ -25,7 +25,6 @@ subroutine plastic_none_init debug_levelBasic use material - implicit none integer :: & Ninstance, & p, & @@ -40,8 +39,6 @@ subroutine plastic_none_init do p = 1, size(phase_plasticity) if (phase_plasticity(p) /= PLASTICITY_NONE_ID) cycle -!-------------------------------------------------------------------------------------------------- -! allocate state arrays NipcMyPhase = count(material_phase == p) call material_allocatePlasticState(p,NipcMyPhase,0,0,0, & 0,0,0) diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index 19f6b38cc..6097bbbc8 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -252,7 +252,6 @@ subroutine plastic_nonlocal_init use config use lattice - implicit none character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer, dimension(0), parameter :: emptyIntArray = [integer::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] @@ -743,7 +742,6 @@ subroutine plastic_nonlocal_init material_phase, & phase_plasticityInstance, & phasememberAt - implicit none integer,intent(in) ::& phase, & @@ -859,7 +857,6 @@ subroutine plastic_nonlocal_dependentState(Fe, Fp, ip, el) LATTICE_fcc_ID, & lattice_structure - implicit none integer, intent(in) :: & ip, & el @@ -1082,7 +1079,6 @@ end subroutine plastic_nonlocal_dependentState !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_kinetics(v, dv_dtau, dv_dtauNS, tau, tauNS, & tauThreshold, c, Temperature, instance, of) - implicit none integer, intent(in) :: & c, & !< dislocation character (1:edge, 2:screw) instance, of @@ -1231,7 +1227,6 @@ subroutine plastic_nonlocal_LpAndItsTangent(Lp, dLp_dMp, & phaseAt, phasememberAt, & phase_plasticityInstance - implicit none integer, intent(in) :: & ip, & !< current integration point el !< current element number @@ -1384,7 +1379,6 @@ subroutine plastic_nonlocal_deltaState(Mp,ip,el) phaseAt, phasememberAt, & phase_plasticityInstance - implicit none integer, intent(in) :: & ip, & el @@ -1545,7 +1539,6 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & LATTICE_bcc_ID, & LATTICE_fcc_ID - implicit none integer, intent(in) :: & ip, & !< current integration point el !< current element number @@ -2019,7 +2012,6 @@ subroutine plastic_nonlocal_updateCompatibility(orientation,i,e) use lattice, only: & lattice_qDisorientation - implicit none integer, intent(in) :: & i, & e @@ -2167,7 +2159,6 @@ function plastic_nonlocal_postResults(ph,instance,of) result(postResults) use material, only: & plasticState - implicit none integer, intent(in) :: & ph, & instance, & @@ -2308,7 +2299,7 @@ outputsLoop: do o = 1,size(param(instance)%outputID) case (rho_dot_ann_ath_ID) postResults(cs+1:cs+ns) = results(instance)%rhoDotAthermalAnnihilation(1:ns,1,of) & - + results(instance)%rhoDotAthermalAnnihilation(1:ns,2,of) + + results(instance)%rhoDotAthermalAnnihilation(1:ns,2,of) cs = cs + ns case (rho_dot_ann_the_edge_ID) @@ -2370,7 +2361,6 @@ end function plastic_nonlocal_postResults function getRho(instance,of,ip,el) use mesh - implicit none integer, intent(in) :: instance, of,ip,el real(pReal), dimension(param(instance)%totalNslip,10) :: getRho @@ -2394,10 +2384,10 @@ end function getRho !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) - use results +#if defined(PETSc) || defined(DAMASK_HDF5) + use results, only: & + results_writeDataset - implicit none integer, intent(in) :: instance character(len=*) :: group integer :: o @@ -2405,6 +2395,39 @@ subroutine plastic_nonlocal_results(instance,group) associate(prm => param(instance), stt => state(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + case (rho_sgl_mob_edg_pos_ID) + call results_writeDataset(group,stt%rho_sgl_mob_edg_pos, 'rho_sgl_mob_edg_pos', & + 'positive mobile edge density','1/m²') + case (rho_sgl_imm_edg_pos_ID) + call results_writeDataset(group,stt%rho_sgl_imm_edg_pos, 'rho_sgl_imm_edg_pos',& + 'positive immobile edge density','1/m²') + case (rho_sgl_mob_edg_neg_ID) + call results_writeDataset(group,stt%rho_sgl_mob_edg_neg, 'rho_sgl_mob_edg_neg',& + 'negative mobile edge density','1/m²') + case (rho_sgl_imm_edg_neg_ID) + call results_writeDataset(group,stt%rho_sgl_imm_edg_neg, 'rho_sgl_imm_edg_neg',& + 'negative immobile edge density','1/m²') + case (rho_dip_edg_ID) + call results_writeDataset(group,stt%rho_dip_edg, 'rho_dip_edg',& + 'edge dipole density','1/m²') + case (rho_sgl_mob_scr_pos_ID) + call results_writeDataset(group,stt%rho_sgl_mob_scr_pos, 'rho_sgl_mob_scr_pos',& + 'positive mobile screw density','1/m²') + case (rho_sgl_imm_scr_pos_ID) + call results_writeDataset(group,stt%rho_sgl_imm_scr_pos, 'rho_sgl_imm_scr_pos',& + 'positive immobile screw density','1/m²') + case (rho_sgl_mob_scr_neg_ID) + call results_writeDataset(group,stt%rho_sgl_mob_scr_neg, 'rho_sgl_mob_scr_neg',& + 'negative mobile screw density','1/m²') + case (rho_sgl_imm_scr_neg_ID) + call results_writeDataset(group,stt%rho_sgl_imm_scr_neg, 'rho_sgl_imm_scr_neg',& + 'negative immobile screw density','1/m²') + case (rho_dip_scr_ID) + call results_writeDataset(group,stt%rho_dip_scr, 'rho_dip_scr',& + 'screw dipole density','1/m²') + case (rho_forest_ID) + call results_writeDataset(group,stt%rho_forest, 'rho_forest',& + 'forest density','1/m²') end select enddo outputsLoop end associate diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 8e7ee82d0..196129f64 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -121,7 +121,6 @@ subroutine plastic_phenopowerlaw_init config_phase use lattice - implicit none integer :: & Ninstance, & p, i, & @@ -195,9 +194,9 @@ subroutine plastic_phenopowerlaw_init prm%nonSchmid_pos = prm%Schmid_slip prm%nonSchmid_neg = prm%Schmid_slip endif - prm%interaction_SlipSlip = transpose(lattice_interaction_SlipBySlip(prm%Nslip, & + prm%interaction_SlipSlip = lattice_interaction_SlipBySlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%xi_slip_0 = config%getFloats('tau0_slip', requiredSize=size(prm%Nslip)) prm%xi_slip_sat = config%getFloats('tausat_slip', requiredSize=size(prm%Nslip)) @@ -232,9 +231,9 @@ subroutine plastic_phenopowerlaw_init twinActive: if (prm%totalNtwin > 0) then prm%Schmid_twin = lattice_SchmidMatrix_twin(prm%Ntwin,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%interaction_TwinTwin = transpose(lattice_interaction_TwinByTwin(prm%Ntwin,& + prm%interaction_TwinTwin = lattice_interaction_TwinByTwin(prm%Ntwin,& config%getFloats('interaction_twintwin'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%gamma_twin_char = lattice_characteristicShear_twin(prm%Ntwin,config%getString('lattice_structure'),& config%getFloat('c/a')) @@ -260,12 +259,12 @@ subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- ! slip-twin related parameters slipAndTwinActive: if (prm%totalNslip > 0 .and. prm%totalNtwin > 0) then - prm%interaction_SlipTwin = transpose(lattice_interaction_SlipByTwin(prm%Nslip,prm%Ntwin,& + prm%interaction_SlipTwin = lattice_interaction_SlipByTwin(prm%Nslip,prm%Ntwin,& config%getFloats('interaction_sliptwin'), & - config%getString('lattice_structure'))) - prm%interaction_TwinSlip = transpose(lattice_interaction_TwinBySlip(prm%Ntwin,prm%Nslip,& + config%getString('lattice_structure')) + prm%interaction_TwinSlip = lattice_interaction_TwinBySlip(prm%Ntwin,prm%Nslip,& config%getFloats('interaction_twinslip'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) else slipAndTwinActive allocate(prm%interaction_SlipTwin(prm%TotalNslip,prm%TotalNtwin)) ! at least one dimension is 0 allocate(prm%interaction_TwinSlip(prm%TotalNtwin,prm%TotalNslip)) ! at least one dimension is 0 @@ -379,7 +378,6 @@ end subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- pure subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) - implicit none real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & @@ -431,7 +429,6 @@ end subroutine plastic_phenopowerlaw_LpAndItsTangent !-------------------------------------------------------------------------------------------------- subroutine plastic_phenopowerlaw_dotState(Mp,instance,of) - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -490,7 +487,6 @@ function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -555,28 +551,42 @@ end function plastic_phenopowerlaw_postResults !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_phenopowerlaw_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) - use results +#if defined(PETSc) || defined(DAMASK_HDF5) + use results, only: & + results_writeDataset - implicit none - integer, intent(in) :: instance - character(len=*) :: group - integer :: o + integer, intent(in) :: instance + character(len=*), intent(in) :: group + + integer :: o - associate(prm => param(instance), stt => state(instance)) - outputsLoop: do o = 1,size(prm%outputID) - select case(prm%outputID(o)) - case (resistance_slip_ID) - call results_writeVectorDataset(group,stt%xi_slip,'xi_slip','Pa') - case (accumulatedshear_slip_ID) - call results_writeVectorDataset(group,stt%gamma_slip,'gamma_slip','-') - end select - enddo outputsLoop - end associate + associate(prm => param(instance), stt => state(instance)) + outputsLoop: do o = 1,size(prm%outputID) + select case(prm%outputID(o)) + + case (resistance_slip_ID) + call results_writeDataset(group,stt%xi_slip, 'xi_sl', & + 'resistance against plastic slip','Pa') + case (accumulatedshear_slip_ID) + call results_writeDataset(group,stt%gamma_slip,'gamma_sl', & + 'plastic shear','1') + + case (resistance_twin_ID) + call results_writeDataset(group,stt%xi_twin, 'xi_tw', & + 'resistance against twinning','Pa') + case (accumulatedshear_twin_ID) + call results_writeDataset(group,stt%gamma_twin,'gamma_tw', & + 'twinning shear','1') + + end select + enddo outputsLoop + end associate + #else - integer, intent(in) :: instance - character(len=*) :: group + integer, intent(in) :: instance + character(len=*), intent(in) :: group #endif + end subroutine plastic_phenopowerlaw_results @@ -593,7 +603,6 @@ pure subroutine kinetics_slip(Mp,instance,of, & use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -670,7 +679,6 @@ pure subroutine kinetics_twin(Mp,instance,of,& use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & diff --git a/src/quaternions.f90 b/src/quaternions.f90 index 2716817cf..fa9c13f38 100644 --- a/src/quaternions.f90 +++ b/src/quaternions.f90 @@ -77,11 +77,11 @@ module quaternions procedure, private :: pow_scal__ generic, public :: operator(**) => pow_quat__, pow_scal__ - procedure, private :: abs__ - procedure, private :: dot_product__ - procedure, private :: conjg__ - procedure, private :: exp__ - procedure, private :: log__ + procedure, public :: abs__ + procedure, public :: dot_product__ + procedure, public :: conjg__ + procedure, public :: exp__ + procedure, public :: log__ procedure, public :: homomorphed => quat_homomorphed @@ -124,7 +124,6 @@ contains !--------------------------------------------------------------------------------------------------- type(quaternion) pure function init__(array) - implicit none real(pReal), intent(in), dimension(4) :: array init__%w=array(1) @@ -140,7 +139,6 @@ end function init__ !--------------------------------------------------------------------------------------------------- elemental subroutine assign_quat__(self,other) - implicit none type(quaternion), intent(out) :: self type(quaternion), intent(in) :: other @@ -157,7 +155,6 @@ end subroutine assign_quat__ !--------------------------------------------------------------------------------------------------- pure subroutine assign_vec__(self,other) - implicit none type(quaternion), intent(out) :: self real(pReal), intent(in), dimension(4) :: other @@ -174,7 +171,6 @@ end subroutine assign_vec__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function add__(self,other) - implicit none class(quaternion), intent(in) :: self,other add__%w = self%w + other%w @@ -190,7 +186,6 @@ end function add__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function pos__(self) - implicit none class(quaternion), intent(in) :: self pos__%w = self%w @@ -206,7 +201,6 @@ end function pos__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function sub__(self,other) - implicit none class(quaternion), intent(in) :: self,other sub__%w = self%w - other%w @@ -222,7 +216,6 @@ end function sub__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function neg__(self) - implicit none class(quaternion), intent(in) :: self neg__%w = -self%w @@ -238,7 +231,6 @@ end function neg__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function mul_quat__(self,other) - implicit none class(quaternion), intent(in) :: self, other mul_quat__%w = self%w*other%w - self%x*other%x - self%y*other%y - self%z*other%z @@ -254,7 +246,6 @@ end function mul_quat__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function mul_scal__(self,scal) - implicit none class(quaternion), intent(in) :: self real(pReal), intent(in) :: scal @@ -271,7 +262,6 @@ end function mul_scal__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function div_quat__(self,other) - implicit none class(quaternion), intent(in) :: self, other div_quat__ = self * (conjg(other)/(abs(other)**2.0_pReal)) @@ -284,7 +274,6 @@ end function div_quat__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function div_scal__(self,scal) - implicit none class(quaternion), intent(in) :: self real(pReal), intent(in) :: scal @@ -300,7 +289,6 @@ logical elemental function eq__(self,other) use prec, only: & dEq - implicit none class(quaternion), intent(in) :: self,other eq__ = all(dEq([ self%w, self%x, self%y, self%z], & @@ -314,7 +302,6 @@ end function eq__ !--------------------------------------------------------------------------------------------------- logical elemental function neq__(self,other) - implicit none class(quaternion), intent(in) :: self,other neq__ = .not. self%eq__(other) @@ -327,7 +314,6 @@ end function neq__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function pow_scal__(self,expon) - implicit none class(quaternion), intent(in) :: self real(pReal), intent(in) :: expon @@ -341,7 +327,6 @@ end function pow_scal__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function pow_quat__(self,expon) - implicit none class(quaternion), intent(in) :: self type(quaternion), intent(in) :: expon @@ -356,7 +341,6 @@ end function pow_quat__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function exp__(self) - implicit none class(quaternion), intent(in) :: self real(pReal) :: absImag @@ -376,7 +360,6 @@ end function exp__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function log__(self) - implicit none class(quaternion), intent(in) :: self real(pReal) :: absImag @@ -395,7 +378,6 @@ end function log__ !--------------------------------------------------------------------------------------------------- real(pReal) elemental function abs__(a) - implicit none class(quaternion), intent(in) :: a abs__ = norm2([a%w,a%x,a%y,a%z]) @@ -408,7 +390,6 @@ end function abs__ !--------------------------------------------------------------------------------------------------- real(pReal) elemental function dot_product__(a,b) - implicit none class(quaternion), intent(in) :: a,b dot_product__ = a%w*b%w + a%x*b%x + a%y*b%y + a%z*b%z @@ -421,7 +402,6 @@ end function dot_product__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function conjg__(a) - implicit none class(quaternion), intent(in) :: a conjg__ = quaternion([a%w, -a%x, -a%y, -a%z]) @@ -434,7 +414,6 @@ end function conjg__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function quat_homomorphed(a) - implicit none class(quaternion), intent(in) :: a quat_homomorphed = quaternion(-[a%w,a%x,a%y,a%z]) diff --git a/src/results.f90 b/src/results.f90 index f70e124f8..516c64552 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -5,9 +5,6 @@ !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !-------------------------------------------------------------------------------------------------- module results - use prec - use IO - use HDF5 use HDF5_utilities #ifdef PETSc use PETSC @@ -18,6 +15,29 @@ module results integer(HID_T), public, protected :: tempCoordinates, tempResults integer(HID_T), private :: resultsFile, currentIncID, plist_id + interface results_writeDataset + + module procedure results_writeTensorDataset_real + module procedure results_writeVectorDataset_real + module procedure results_writeScalarDataset_real + + module procedure results_writeTensorDataset_int + module procedure results_writeVectorDataset_int + + module procedure results_writeScalarDataset_rotation + + end interface results_writeDataset + + interface results_addAttribute + + module procedure results_addAttribute_real + module procedure results_addAttribute_int + module procedure results_addAttribute_str + + module procedure results_addAttribute_int_array + module procedure results_addAttribute_real_array + + end interface results_addAttribute public :: & results_init, & @@ -26,23 +46,35 @@ module results results_addIncrement, & results_addGroup, & results_openGroup, & - results_writeVectorDataset, & + results_writeDataset, & results_setLink, & - results_removeLink + results_addAttribute, & + results_removeLink, & + results_mapping_constituent, & + results_mapping_materialpoint contains subroutine results_init use DAMASK_interface, only: & getSolverJobName - implicit none + character(len=pStringLen) :: commandLine write(6,'(/,a)') ' <<<+- results init -+>>>' write(6,'(/,a)') ' Diehl et al., Integrating Materials and Manufacturing Innovation 6(1):83–91, 2017' write(6,'(a)') ' https://doi.org/10.1007/s40192-018-0118-7' - call HDF5_closeFile(HDF5_openFile(trim(getSolverJobName())//'.hdf5','w',.true.)) + resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','w',.true.) + call HDF5_addAttribute(resultsFile,'DADF5-version',0.1) + call HDF5_addAttribute(resultsFile,'DADF5-major',0) + call HDF5_addAttribute(resultsFile,'DADF5-minor',1) + call HDF5_addAttribute(resultsFile,'DAMASK',DAMASKVERSION) + call get_command(commandLine) + call HDF5_addAttribute(resultsFile,'call',trim(commandLine)) + call HDF5_closeGroup(results_addGroup('mapping')) + call HDF5_closeGroup(results_addGroup('mapping/cellResults')) + call HDF5_closeFile(resultsFile) end subroutine results_init @@ -50,18 +82,12 @@ end subroutine results_init !-------------------------------------------------------------------------------------------------- !> @brief opens the results file to append data !-------------------------------------------------------------------------------------------------- -subroutine results_openJobFile() - use DAMASK_interface, only: & - getSolverJobName +subroutine results_openJobFile + use DAMASK_interface, only: & + getSolverJobName - implicit none - character(len=pStringLen) :: commandLine - resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','a',.true.) - call HDF5_addAttribute(resultsFile,'DADF5',0.1_pReal) - call HDF5_addAttribute(resultsFile,'DAMASK',DAMASKVERSION) - call get_command(commandLine) - call HDF5_addAttribute(resultsFile,'call',trim(commandLine)) + resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','a',.true.) end subroutine results_openJobFile @@ -69,10 +95,9 @@ end subroutine results_openJobFile !-------------------------------------------------------------------------------------------------- !> @brief closes the results file !-------------------------------------------------------------------------------------------------- -subroutine results_closeJobFile() - implicit none +subroutine results_closeJobFile - call HDF5_closeFile(resultsFile) + call HDF5_closeFile(resultsFile) end subroutine results_closeJobFile @@ -82,15 +107,17 @@ end subroutine results_closeJobFile !-------------------------------------------------------------------------------------------------- subroutine results_addIncrement(inc,time) - implicit none - integer(pInt), intent(in) :: inc - real(pReal), intent(in) :: time - character(len=pStringLen) :: incChar + integer(pInt), intent(in) :: inc + real(pReal), intent(in) :: time + character(len=pStringLen) :: incChar - write(incChar,*) inc - call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) - call results_setLink(trim('inc'//trim(adjustl(incChar))),'current') - call HDF5_addAttribute(resultsFile,'time/s',time,trim('inc'//trim(adjustl(incChar)))) + write(incChar,'(i5.5)') inc ! allow up to 99999 increments + call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) + call results_setLink(trim('inc'//trim(adjustl(incChar))),'current') + call HDF5_addAttribute(resultsFile,'time/s',time,trim('inc'//trim(adjustl(incChar)))) + + call HDF5_closeGroup(results_addGroup('current/constituent')) + call HDF5_closeGroup(results_addGroup('current/materialpoint')) end subroutine results_addIncrement @@ -99,10 +126,9 @@ end subroutine results_addIncrement !-------------------------------------------------------------------------------------------------- integer(HID_T) function results_openGroup(groupName) - implicit none - character(len=*), intent(in) :: groupName - - results_openGroup = HDF5_openGroup(resultsFile,groupName) + character(len=*), intent(in) :: groupName + + results_openGroup = HDF5_openGroup(resultsFile,groupName) end function results_openGroup @@ -112,10 +138,9 @@ end function results_openGroup !-------------------------------------------------------------------------------------------------- integer(HID_T) function results_addGroup(groupName) - implicit none - character(len=*), intent(in) :: groupName - - results_addGroup = HDF5_addGroup(resultsFile,groupName) + character(len=*), intent(in) :: groupName + + results_addGroup = HDF5_addGroup(resultsFile,groupName) end function results_addGroup @@ -124,852 +149,797 @@ end function results_addGroup !> @brief set link to object in results file !-------------------------------------------------------------------------------------------------- subroutine results_setLink(path,link) - use hdf5_utilities, only: & - HDF5_setLink - implicit none - character(len=*), intent(in) :: path, link + character(len=*), intent(in) :: path, link - call HDF5_setLink(resultsFile,path,link) + call HDF5_setLink(resultsFile,path,link) end subroutine results_setLink +!-------------------------------------------------------------------------------------------------- +!> @brief adds a string attribute to an object in the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_addAttribute_str(attrLabel,attrValue,path) + + character(len=*), intent(in) :: attrLabel, attrValue, path + + call HDF5_addAttribute(resultsFile,attrLabel, attrValue, path) + +end subroutine results_addAttribute_str + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds an integer attribute an object in the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_addAttribute_int(attrLabel,attrValue,path) + + character(len=*), intent(in) :: attrLabel, path + integer, intent(in) :: attrValue + + call HDF5_addAttribute(resultsFile,attrLabel, attrValue, path) + +end subroutine results_addAttribute_int + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a real attribute an object in the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_addAttribute_real(attrLabel,attrValue,path) + + character(len=*), intent(in) :: attrLabel, path + real(pReal), intent(in) :: attrValue + + call HDF5_addAttribute(resultsFile,attrLabel, attrValue, path) + +end subroutine results_addAttribute_real + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds an integer array attribute an object in the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_addAttribute_int_array(attrLabel,attrValue,path) + + character(len=*), intent(in) :: attrLabel, path + integer, intent(in), dimension(:) :: attrValue + + call HDF5_addAttribute(resultsFile,attrLabel, attrValue, path) + +end subroutine results_addAttribute_int_array + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a real array attribute an object in the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_addAttribute_real_array(attrLabel,attrValue,path) + + character(len=*), intent(in) :: attrLabel, path + real(pReal), intent(in), dimension(:) :: attrValue + + call HDF5_addAttribute(resultsFile,attrLabel, attrValue, path) + +end subroutine results_addAttribute_real_array + + !-------------------------------------------------------------------------------------------------- !> @brief remove link to an object !-------------------------------------------------------------------------------------------------- subroutine results_removeLink(link) - use hdf5 - implicit none - character(len=*), intent(in) :: link - integer :: hdferr + character(len=*), intent(in) :: link + integer :: hdferr - call h5ldelete_f(resultsFile,link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,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 +!-------------------------------------------------------------------------------------------------- +!> @brief stores a scalar dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeScalarDataset_real(group,dataset,label,description,SIunit) + + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: SIunit + real(pReal), intent(inout), dimension(:) :: dataset + + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeScalarDataset_real + !-------------------------------------------------------------------------------------------------- !> @brief stores a vector dataset in a group !-------------------------------------------------------------------------------------------------- -subroutine results_writeVectorDataset(group,dataset,label,SIunit) +subroutine results_writeVectorDataset_real(group,dataset,label,description,SIunit) - implicit none - character(len=*), intent(in) :: SIunit,label,group - real(pReal), intent(inout), dimension(:,:) :: dataset - integer(HID_T) :: groupHandle + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: SIunit + real(pReal), intent(inout), dimension(:,:) :: dataset + + integer(HID_T) :: groupHandle - groupHandle = results_openGroup(group) - call HDF5_write(groupHandle,dataset,label) - if (HDF5_objectExists(groupHandle,label)) & - call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) - call HDF5_closeGroup(groupHandle) + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) + call HDF5_closeGroup(groupHandle) -end subroutine results_writeVectorDataset +end subroutine results_writeVectorDataset_real + + +!-------------------------------------------------------------------------------------------------- +!> @brief stores a tensor dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeTensorDataset_real(group,dataset,label,description,SIunit) + + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: SIunit + real(pReal), intent(inout), dimension(:,:,:) :: dataset + + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeTensorDataset_real + + +!-------------------------------------------------------------------------------------------------- +!> @brief stores a vector dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeVectorDataset_int(group,dataset,label,description,SIunit) + + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: SIunit + integer, intent(inout), dimension(:,:) :: dataset + + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeVectorDataset_int + + +!-------------------------------------------------------------------------------------------------- +!> @brief stores a vector dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeTensorDataset_int(group,dataset,label,description,SIunit) + + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: SIunit + integer, intent(inout), dimension(:,:,:) :: dataset + + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeTensorDataset_int + + +!-------------------------------------------------------------------------------------------------- +!> @brief stores a vector dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeScalarDataset_rotation(group,dataset,label,description,lattice_structure) + use rotations, only: & + rotation + + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: lattice_structure + type(rotation), intent(inout), dimension(:) :: dataset + + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(lattice_structure)) & + call HDF5_addAttribute(groupHandle,'Lattice',lattice_structure,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeScalarDataset_rotation !-------------------------------------------------------------------------------------------------- !> @brief adds the unique mapping from spatial position and constituent ID to results !-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingPhase(mapping,mapping2,Nconstituents,material_phase,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) - use hdf5 +subroutine results_mapping_constituent(phaseAt,memberAt,label) + use numerics, only: & + worldrank, & + worldsize + + integer, dimension(:,:), intent(in) :: phaseAt !< phase section at (constituent,element) + integer, dimension(:,:,:), intent(in) :: memberAt !< phase member at (constituent,IP,element) + character(len=64), dimension(:), intent(in) :: label !< label of each phase section + + integer, dimension(size(memberAt,1),size(memberAt,2),size(memberAt,3)) :: & + phaseAt_perIP, & + memberAt_total + integer, dimension(size(label),0:worldsize-1) :: memberOffset !< offset in member counting per process + integer, dimension(0:worldsize-1) :: writeSize !< amount of data written per process + integer(HSIZE_T), dimension(2) :: & + myShape, & !< shape of the dataset (this process) + myOffset, & + totalShape !< shape of the dataset (all processes) + + integer(HID_T) :: & + loc_id, & !< identifier of group in file + dtype_id, & !< identifier of compound data type + name_id, & !< identifier of name (string) in compound data type + position_id, & !< identifier of position/index (integer) in compound data type + dset_id, & + memspace_id, & + filespace_id, & + plist_id, & + dt_id - implicit none - integer(pInt), intent(in) :: Nconstituents, dataspace_size, mpiOffset - integer(pInt), intent(in), dimension(:) :: mapping, mapping2 - character(len=*), intent(in), dimension(:) :: phase_name - integer(pInt), intent(in), dimension(:) :: mpiOffset_phase - integer(pInt), intent(in), dimension(:,:,:) :: material_phase - - character(len=len(phase_name(1))), dimension(:), allocatable :: namesNA - character(len=len(phase_name(1))) :: a - character(len=*), parameter :: n = "NULL" - - integer(pInt) :: hdferr, NmatPoints, i, j, k - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace - integer(HID_T) :: dt5_id ! Memory datatype identifier - integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - - integer(HSIZE_T), dimension(2) :: counter - integer(HSSIZE_T), dimension(2) :: fileOffset - integer(pInt), dimension(:,:), allocatable :: arrOffset - - a = n - allocate(namesNA(0:size(phase_name)),source=[a,phase_name]) - NmatPoints = size(mapping,1)/Nconstituents - mapping_ID = results_openGroup("current/mapGeometry") - - allocate(arrOffset(Nconstituents,NmatPoints)) - do i=1_pInt, NmatPoints - do k=1_pInt, Nconstituents - do j=1_pInt, size(phase_name) - if(material_phase(k,1,i) == j) & - arrOffset(k,i) = mpiOffset_phase(j) - enddo - enddo - enddo + + integer(SIZE_T) :: type_size_string, type_size_int + integer :: ierr, i + +!--------------------------------------------------------------------------------------------------- +! compound type: name of phase section + position/index within results array + call h5tcopy_f(H5T_NATIVE_CHARACTER, dt_id, ierr) + call h5tset_size_f(dt_id, int(len(label(1)),SIZE_T), ierr) + call h5tget_size_f(dt_id, type_size_string, ierr) + + call h5tget_size_f(H5T_NATIVE_INTEGER, type_size_int, ierr) + + call h5tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, ierr) + call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt_id,ierr) + call h5tinsert_f(dtype_id, "Position", type_size_string, H5T_NATIVE_INTEGER, ierr) + +!-------------------------------------------------------------------------------------------------- +! create memory types for each component of the compound type + call h5tcreate_f(H5T_COMPOUND_F, type_size_string, name_id, ierr) + call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt_id, ierr) + + call h5tcreate_f(H5T_COMPOUND_F, type_size_int, position_id, ierr) + call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_NATIVE_INTEGER, ierr) + + call h5tclose_f(dt_id, ierr) !-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(2, int([Nconstituents,dataspace_size],HSIZE_T), space_id, hdferr, & - int([Nconstituents,dataspace_size],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') +! prepare MPI communication (transparent for non-MPI runs) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + memberOffset = 0 + do i=1, size(label) + memberOffset(i,worldrank) = count(phaseAt == i)*size(memberAt,2) ! number of points/instance of this process + enddo + writeSize = 0 + writeSize(worldrank) = size(memberAt(1,:,:)) ! total number of points by this process !-------------------------------------------------------------------------------------------------- -! compound type - ! First calculate total size by calculating sizes of each member - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) - typesize = len(phase_name(1)) - CALL h5tset_size_f(dt5_id, typesize, hdferr) - CALL h5tget_size_f(dt5_id, type_sizec, hdferr) - CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) - type_size = type_sizec + type_sizei - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 0') - call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 2') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, 'constitutive', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase') - -!-------------------------------------------------------------------------------------------------- -! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f instance_id') - call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f instance_id') - - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- -! Define and select hyperslabs - counter(1) = Nconstituents ! how big i am - counter(2) = NmatPoints - fileOffset(1) = 0 ! where i start to write my data - fileOffset(2) = mpiOffset - - call h5screate_simple_f(2, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write +! MPI settings and communication #ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pset_dxpl_mpio_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5pset_dxpl_mpio_f') + + call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get output at each process + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_constituent: MPI_allreduce/writeSize') + + call MPI_allreduce(MPI_IN_PLACE,memberOffset,size(memberOffset),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr)! get offset at each process + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_constituent: MPI_allreduce/memberOffset') #endif + myShape = int([size(phaseAt,1),writeSize(worldrank)], HSIZE_T) + myOffset = int([0,sum(writeSize(0:worldrank-1))], HSIZE_T) + totalShape = int([size(phaseAt,1),sum(writeSize)], HSIZE_T) + !-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, name_id, reshape(namesNA(mapping),[Nconstituents,NmatPoints]), & - int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f position_id') +! create dataspace in memory (local shape = hyperslab) and in file (global shape) + call h5screate_simple_f(2,myShape,memspace_id,ierr,myShape) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5screate_simple_f/memspace_id') + + call h5screate_simple_f(2,totalShape,filespace_id,ierr,totalShape) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5screate_simple_f/filespace_id') + + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5sselect_hyperslab_f') - call h5dwrite_f(dset_id, position_id, reshape(mapping2-1_pInt,[Nconstituents,NmatPoints])+arrOffset, & - int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f instance_id') +!--------------------------------------------------------------------------------------------------- +! expand phaseAt to consider IPs (is not stored per IP) + do i = 1, size(phaseAt_perIP,2) + phaseAt_perIP(:,i,:) = phaseAt + enddo + +!--------------------------------------------------------------------------------------------------- +! renumber member from my process to all processes + do i = 1, size(label) + where(phaseAt_perIP == i) memberAt_total = memberAt + sum(memberOffset(i,0:worldrank-1)) -1 ! convert to 0-based + enddo !-------------------------------------------------------------------------------------------------- -! close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f position_id') - call h5tclose_f(name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f name_id ') - call h5tclose_f(dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dt5_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingPhase +! write the components of the compound type individually + call h5pset_preserve_f(plist_id, .TRUE., ierr) + + loc_id = results_openGroup('/mapping/cellResults') + call h5dcreate_f(loc_id, 'constituent', dtype_id, filespace_id, dset_id, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dcreate_f') + + call h5dwrite_f(dset_id, name_id, reshape(label(pack(phaseAt_perIP,.true.)),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dwrite_f/name_id') + call h5dwrite_f(dset_id, position_id, reshape(pack(memberAt_total,.true.),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dwrite_f/position_id') !-------------------------------------------------------------------------------------------------- -!> @brief adds the backward mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_backwardMappingPhase(material_phase,phasememberat,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) - use hdf5 +! close all + call HDF5_closeGroup(loc_id) + call h5pclose_f(plist_id, ierr) + call h5sclose_f(filespace_id, ierr) + call h5sclose_f(memspace_id, ierr) + call h5dclose_f(dset_id, ierr) + call h5tclose_f(dtype_id, ierr) + call h5tclose_f(name_id, ierr) + call h5tclose_f(position_id, ierr) - implicit none - integer(pInt), intent(in), dimension(:,:,:) :: material_phase, phasememberat - character(len=*), intent(in), dimension(:) :: phase_name - integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_phase - integer(pInt), intent(in) :: mpiOffset +end subroutine results_mapping_constituent - integer(pInt) :: hdferr, NmatPoints, Nconstituents, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace - integer(SIZE_T) :: type_size - - integer(pInt), dimension(:,:), allocatable :: arr - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - - character(len=64) :: phaseID - - Nconstituents = size(phasememberat,1) - NmatPoints = count(material_phase /=0_pInt)/Nconstituents - - allocate(arr(2,NmatPoints*Nconstituents)) - - do i=1_pInt, NmatPoints - do j=Nconstituents-1_pInt, 0_pInt, -1_pInt - arr(1,Nconstituents*i-j) = i-1_pInt - enddo - enddo - arr(2,:) = pack(material_phase,material_phase/=0_pInt) - - do i=1_pInt, size(phase_name) - write(phaseID, '(i0)') i - mapping_ID = results_openGroup('/current/constitutive/'//trim(phaseID)//'_'//phase_name(i)) - NmatPoints = count(material_phase == i) - -!-------------------------------------------------------------------------------------------------- - ! create dataspace - call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & - int([dataspace_size(i)],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') - -!-------------------------------------------------------------------------------------------------- - ! compound type - call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f 0') - -!-------------------------------------------------------------------------------------------------- - ! create Dataset - call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase') - -!-------------------------------------------------------------------------------------------------- - ! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- - ! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset_phase(i) ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- - ! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset, int([dataspace_size(i)],HSIZE_T),& - hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- - !close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f position_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - - enddo - -end subroutine HDF5_backwardMappingPhase !-------------------------------------------------------------------------------------------------- !> @brief adds the unique mapping from spatial position and constituent ID to results !-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) - use hdf5 +subroutine results_mapping_materialpoint(homogenizationAt,memberAt,label) + use numerics, only: & + worldrank, & + worldsize + + integer, dimension(:), intent(in) :: homogenizationAt !< homogenization section at (element) + integer, dimension(:,:), intent(in) :: memberAt !< homogenization member at (IP,element) + character(len=64), dimension(:), intent(in) :: label !< label of each homogenization section + + integer, dimension(size(memberAt,1),size(memberAt,2)) :: & + homogenizationAt_perIP, & + memberAt_total + integer, dimension(size(label),0:worldsize-1) :: memberOffset !< offset in member counting per process + integer, dimension(0:worldsize-1) :: writeSize !< amount of data written per process + integer(HSIZE_T), dimension(1) :: & + myShape, & !< shape of the dataset (this process) + myOffset, & + totalShape !< shape of the dataset (all processes) + + integer(HID_T) :: & + loc_id, & !< identifier of group in file + dtype_id, & !< identifier of compound data type + name_id, & !< identifier of name (string) in compound data type + position_id, & !< identifier of position/index (integer) in compound data type + dset_id, & + memspace_id, & + filespace_id, & + plist_id, & + dt_id - implicit none - integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat - character(len=*), intent(in), dimension(:) :: homogenization_name - integer(pInt), intent(in), dimension(:) :: mpiOffset_homog - integer(pInt), intent(in) :: dataspace_size, mpiOffset - - integer(pInt) :: hdferr, NmatPoints, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace - - integer(HID_T) :: dt5_id ! Memory datatype identifier - integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - integer(pInt), dimension(:), allocatable :: arrOffset - - NmatPoints = count(material_homog /=0_pInt) - mapping_ID = results_openGroup("current/mapGeometry") - - allocate(arrOffset(NmatPoints)) - do i=1_pInt, NmatPoints - do j=1_pInt, size(homogenization_name) - if(material_homog(1,i) == j) & - arrOffset(i) = mpiOffset_homog(j) - enddo - enddo + + integer(SIZE_T) :: type_size_string, type_size_int + integer :: ierr, i + +!--------------------------------------------------------------------------------------------------- +! compound type: name of phase section + position/index within results array + call h5tcopy_f(H5T_NATIVE_CHARACTER, dt_id, ierr) + call h5tset_size_f(dt_id, int(len(label(1)),SIZE_T), ierr) + call h5tget_size_f(dt_id, type_size_string, ierr) + + call h5tget_size_f(H5T_NATIVE_INTEGER, type_size_int, ierr) + + call h5tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, ierr) + call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt_id,ierr) + call h5tinsert_f(dtype_id, "Position", type_size_string, H5T_NATIVE_INTEGER, ierr) + +!-------------------------------------------------------------------------------------------------- +! create memory types for each component of the compound type + call h5tcreate_f(H5T_COMPOUND_F, type_size_string, name_id, ierr) + call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt_id, ierr) + + call h5tcreate_f(H5T_COMPOUND_F, type_size_int, position_id, ierr) + call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_NATIVE_INTEGER, ierr) + + call h5tclose_f(dt_id, ierr) !-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & - int([dataspace_size],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') +! prepare MPI communication (transparent for non-MPI runs) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + memberOffset = 0 + do i=1, size(label) + memberOffset(i,worldrank) = count(homogenizationAt == i)*size(memberAt,1) ! number of points/instance of this process + enddo + writeSize = 0 + writeSize(worldrank) = size(memberAt) ! total number of points by this process !-------------------------------------------------------------------------------------------------- -! compound type - ! First calculate total size by calculating sizes of each member - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) - typesize = len(homogenization_name(1)) - CALL h5tset_size_f(dt5_id, typesize, hdferr) - CALL h5tget_size_f(dt5_id, type_sizec, hdferr) - CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) - type_size = type_sizec + type_sizei - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 0') - call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 2') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, 'homogenization', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog') - -!-------------------------------------------------------------------------------------------------- -! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f instance_id') - call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f instance_id') - - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- -! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! Create property list for collective dataset write +! MPI settings and communication #ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pset_dxpl_mpio_f') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5pset_dxpl_mpio_f') + + call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get output at each process + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_materialpoint: MPI_allreduce/writeSize') + + call MPI_allreduce(MPI_IN_PLACE,memberOffset,size(memberOffset),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr)! get offset at each process + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_materialpoint: MPI_allreduce/memberOffset') #endif + myShape = int([writeSize(worldrank)], HSIZE_T) + myOffset = int([sum(writeSize(0:worldrank-1))], HSIZE_T) + totalShape = int([sum(writeSize)], HSIZE_T) + !-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, name_id, homogenization_name(pack(material_homog,material_homog/=0_pInt)), & - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f position_id') +! create dataspace in memory (local shape = hyperslab) and in file (global shape) + call h5screate_simple_f(1,myShape,memspace_id,ierr,myShape) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5screate_simple_f/memspace_id') + + call h5screate_simple_f(1,totalShape,filespace_id,ierr,totalShape) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5screate_simple_f/filespace_id') + + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5sselect_hyperslab_f') - call h5dwrite_f(dset_id, position_id, pack(homogmemberat-1_pInt,homogmemberat/=0_pInt) + arrOffset, & - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f instance_id') +!--------------------------------------------------------------------------------------------------- +! expand phaseAt to consider IPs (is not stored per IP) + do i = 1, size(homogenizationAt_perIP,1) + homogenizationAt_perIP(i,:) = homogenizationAt + enddo + +!--------------------------------------------------------------------------------------------------- +! renumber member from my process to all processes + do i = 1, size(label) + where(homogenizationAt_perIP == i) memberAt_total = memberAt + sum(memberOffset(i,0:worldrank-1)) - 1 ! convert to 0-based + enddo !-------------------------------------------------------------------------------------------------- -!close types, dataspaces -call h5tclose_f(dtype_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dtype_id') -call h5tclose_f(position_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f position_id') -call h5tclose_f(name_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f name_id ') -call h5tclose_f(dt5_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dt5_id') -call h5dclose_f(dset_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dclose_f') -call h5sclose_f(space_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f space_id') -call h5sclose_f(memspace, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f memspace') -call h5pclose_f(plist_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pclose_f') -call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingHomog +! write the components of the compound type individually + call h5pset_preserve_f(plist_id, .TRUE., ierr) + + loc_id = results_openGroup('/mapping/cellResults') + call h5dcreate_f(loc_id, 'materialpoint', dtype_id, filespace_id, dset_id, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dcreate_f') + + call h5dwrite_f(dset_id, name_id, reshape(label(pack(homogenizationAt_perIP,.true.)),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dwrite_f/name_id') + call h5dwrite_f(dset_id, position_id, reshape(pack(memberAt_total,.true.),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dwrite_f/position_id') !-------------------------------------------------------------------------------------------------- -!> @brief adds the backward mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_backwardMappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat - character(len=*), intent(in), dimension(:) :: homogenization_name - integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_homog - integer(pInt), intent(in) :: mpiOffset - - integer(pInt) :: hdferr, NmatPoints, i - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace - integer(SIZE_T) :: type_size - - integer(pInt), dimension(:,:), allocatable :: arr - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - - character(len=64) :: homogID - - NmatPoints = count(material_homog /=0_pInt) - allocate(arr(2,NmatPoints)) - - arr(1,:) = (/(i, i=0_pint,NmatPoints-1_pInt)/) - arr(2,:) = pack(material_homog,material_homog/=0_pInt) - - do i=1_pInt, size(homogenization_name) - write(homogID, '(i0)') i - mapping_ID = results_openGroup('/current/homogenization/'//trim(homogID)//'_'//homogenization_name(i)) - -!-------------------------------------------------------------------------------------------------- - ! create dataspace - call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & - int([dataspace_size(i)],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') - -!-------------------------------------------------------------------------------------------------- - ! compound type - call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f 0') - -!-------------------------------------------------------------------------------------------------- - ! create Dataset - call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog') - -!-------------------------------------------------------------------------------------------------- - ! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- - ! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset_homog(i) ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- - ! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset,int([dataspace_size(i)],HSIZE_T),& - hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- - !close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f position_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - - enddo - -end subroutine HDF5_backwardMappingHomog - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the unique mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: crystalliteAt - integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt - character(len=*), intent(in), dimension(:) :: crystallite_name - integer(pInt), intent(in), dimension(:) :: mpiOffset_cryst - integer(pInt), intent(in) :: dataspace_size, mpiOffset - - integer :: hdferr - integer(pInt) :: NmatPoints, Nconstituents, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, plist_id, memspace - - integer(HID_T), dimension(:), allocatable :: position_id - - integer(HID_T) :: dt5_id ! Memory datatype identifier - integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - integer(pInt), dimension(:), allocatable :: arrOffset - - character(len=64) :: m - - Nconstituents = size(crystmemberAt,1) - NmatPoints = count(crystalliteAt /=0_pInt) - mapping_ID = results_openGroup("current/mapGeometry") - - allocate(position_id(Nconstituents)) - - allocate(arrOffset(NmatPoints)) - do i=1_pInt, NmatPoints - do j=1_pInt, size(crystallite_name) - if(crystalliteAt(1,i) == j) & - arrOffset(i) = Nconstituents*mpiOffset_cryst(j) - enddo - enddo - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & - int([dataspace_size],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') - -!-------------------------------------------------------------------------------------------------- -! compound type - ! First calculate total size by calculating sizes of each member - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) - typesize = len(crystallite_name(1)) - CALL h5tset_size_f(dt5_id, typesize, hdferr) - CALL h5tget_size_f(dt5_id, type_sizec, hdferr) - CALL h5tget_size_f(H5T_STD_I32LE, type_sizei, hdferr) - type_size = type_sizec + type_sizei*Nconstituents - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 0') - do i=1_pInt, Nconstituents - write(m, '(i0)') i - call h5tinsert_f(dtype_id, "Position "//trim(m), type_sizec+(i-1)*type_sizei, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 2 '//trim(m)) - enddo - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, 'crystallite', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite') - -!-------------------------------------------------------------------------------------------------- -! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f instance_id') - call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f instance_id') - - do i=1_pInt, Nconstituents - write(m, '(i0)') i - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id(i), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f position_id') - call h5tinsert_f(position_id(i), "Position "//trim(m), 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f position_id') - enddo - -!-------------------------------------------------------------------------------------------------- -! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, name_id, crystallite_name(pack(crystalliteAt,crystalliteAt/=0_pInt)), & - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f position_id') - - do i=1_pInt, Nconstituents - call h5dwrite_f(dset_id, position_id(i), pack(crystmemberAt(i,:,:)-1_pInt,crystmemberAt(i,:,:)/=0_pInt)+arrOffset,& - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f instance_id') - enddo - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dtype_id') - do i=1_pInt, Nconstituents - call h5tclose_f(position_id(i), hdferr) - enddo - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f position_id') - call h5tclose_f(name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f name_id') - call h5tclose_f(dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dt5_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingCrystallite - - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the backward mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_backwardMappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: crystalliteAt - integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt - character(len=*), intent(in), dimension(:) :: crystallite_name - integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_cryst - integer(pInt), intent(in) :: mpiOffset - - integer :: hdferr - integer(pInt) :: NmatPoints, Nconstituents, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace - integer(SIZE_T) :: type_size - - integer(pInt), dimension(:,:), allocatable :: h_arr, arr - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - - character(len=64) :: crystallID - - Nconstituents = size(crystmemberAt,1) - NmatPoints = count(crystalliteAt /=0_pInt) - - allocate(h_arr(2,NmatPoints)) - allocate(arr(2,Nconstituents*NmatPoints)) - - h_arr(1,:) = (/(i, i=0_pInt,NmatPoints-1_pInt)/) - h_arr(2,:) = pack(crystalliteAt,crystalliteAt/=0_pInt) - - do i=1_pInt, NmatPoints - do j=Nconstituents-1_pInt, 0_pInt, -1_pInt - arr(1,Nconstituents*i-j) = h_arr(1,i) - arr(2,Nconstituents*i-j) = h_arr(2,i) - enddo - enddo - - do i=1_pInt, size(crystallite_name) - if (crystallite_name(i) == 'none') cycle - write(crystallID, '(i0)') i - mapping_ID = results_openGroup('/current/crystallite/'//trim(crystallID)//'_'//crystallite_name(i)) - NmatPoints = count(crystalliteAt == i) - -!-------------------------------------------------------------------------------------------------- - ! create dataspace - call h5screate_simple_f(1, int([Nconstituents*dataspace_size(i)],HSIZE_T), space_id, hdferr, & - int([Nconstituents*dataspace_size(i)],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') - -!-------------------------------------------------------------------------------------------------- - ! compound type - call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f 0') - -!-------------------------------------------------------------------------------------------------- - ! create Dataset - call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite') - -!-------------------------------------------------------------------------------------------------- - ! Create memory types - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- - ! Define and select hyperslabs - counter = Nconstituents*NmatPoints ! how big i am - fileOffset = Nconstituents*mpiOffset_cryst(i) ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- - ! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i) + mpiOffset,& - int([Nconstituents*dataspace_size(i)],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- - !close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f position_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - - enddo - -end subroutine HDF5_backwardMappingCrystallite - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the unique cell to node mapping -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingCells(mapping) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:) :: mapping - - integer :: hdferr, Nnodes - integer(HID_T) :: mapping_id, dset_id, space_id - - Nnodes=size(mapping) - mapping_ID = results_openGroup("mapping") - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, & - int([Nnodes],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5screate_simple_f') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, "Cell",H5T_NATIVE_INTEGER, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells') - -!-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, mapping, int([Nnodes],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5sclose_f') - call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingCells +! close all + call HDF5_closeGroup(loc_id) + call h5pclose_f(plist_id, ierr) + call h5sclose_f(filespace_id, ierr) + call h5sclose_f(memspace_id, ierr) + call h5dclose_f(dset_id, ierr) + call h5tclose_f(dtype_id, ierr) + call h5tclose_f(name_id, ierr) + call h5tclose_f(position_id, ierr) + +end subroutine results_mapping_materialpoint + + +!!-------------------------------------------------------------------------------------------------- +!!> @brief adds the backward mapping from spatial position and constituent ID to results +!!-------------------------------------------------------------------------------------------------- +!subroutine HDF5_backwardMappingPhase(material_phase,phasememberat,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) +! use hdf5 + +! integer(pInt), intent(in), dimension(:,:,:) :: material_phase, phasememberat +! character(len=*), intent(in), dimension(:) :: phase_name +! integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_phase +! integer(pInt), intent(in) :: mpiOffset + +! integer(pInt) :: hdferr, NmatPoints, Nconstituents, i, j +! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace +! integer(SIZE_T) :: type_size + +! integer(pInt), dimension(:,:), allocatable :: arr + +! integer(HSIZE_T), dimension(1) :: counter +! integer(HSSIZE_T), dimension(1) :: fileOffset + +! character(len=64) :: phaseID + +! Nconstituents = size(phasememberat,1) +! NmatPoints = count(material_phase /=0)/Nconstituents + +! allocate(arr(2,NmatPoints*Nconstituents)) + +! do i=1, NmatPoints +! do j=Nconstituents-1, 0, -1 +! arr(1,Nconstituents*i-j) = i-1 +! enddo +! enddo +! arr(2,:) = pack(material_phase,material_phase/=0) + +! do i=1, size(phase_name) +! write(phaseID, '(i0)') i +! mapping_ID = results_openGroup('/current/constitutive/'//trim(phaseID)//'_'//phase_name(i)) +! NmatPoints = count(material_phase == i) + +!!-------------------------------------------------------------------------------------------------- +! ! create dataspace +! call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & +! int([dataspace_size(i)],HSIZE_T)) +! if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping') + +!!-------------------------------------------------------------------------------------------------- +! ! compound type +! call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) +! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') + +! call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tinsert_f 0') + +!!-------------------------------------------------------------------------------------------------- +! ! create Dataset +! call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase') + +!!-------------------------------------------------------------------------------------------------- +! ! Create memory types (one compound datatype for each member) +! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tcreate_f position_id') +! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tinsert_f position_id') + +!!-------------------------------------------------------------------------------------------------- +! ! Define and select hyperslabs +! counter = NmatPoints ! how big i am +! fileOffset = mpiOffset_phase(i) ! where i start to write my data + +! call h5screate_simple_f(1, counter, memspace, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5screate_simple_f') +! call h5dget_space_f(dset_id, space_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5dget_space_f') +! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5sselect_hyperslab_f') + +!!-------------------------------------------------------------------------------------------------- +! ! Create property list for collective dataset write +!#ifdef PETSc +! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5pcreate_f') +! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5pset_dxpl_mpio_f') +!#endif + +!!-------------------------------------------------------------------------------------------------- +! ! write data by fields in the datatype. Fields order is not important. +! call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset, int([dataspace_size(i)],HSIZE_T),& +! hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5dwrite_f instance_id') + +!!-------------------------------------------------------------------------------------------------- +! !close types, dataspaces +! call h5tclose_f(dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tclose_f dtype_id') +! call h5tclose_f(position_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tclose_f position_id') +! call h5dclose_f(dset_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5dclose_f') +! call h5sclose_f(space_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5sclose_f space_id') +! call h5sclose_f(memspace, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5sclose_f memspace') +! call h5pclose_f(plist_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5pclose_f') +! call HDF5_closeGroup(mapping_ID) + +! enddo + +!end subroutine HDF5_backwardMappingPhase + + +!!-------------------------------------------------------------------------------------------------- +!!> @brief adds the backward mapping from spatial position and constituent ID to results +!!-------------------------------------------------------------------------------------------------- +!subroutine HDF5_backwardMappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) +! use hdf5 + +! integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat +! character(len=*), intent(in), dimension(:) :: homogenization_name +! integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_homog +! integer(pInt), intent(in) :: mpiOffset + +! integer(pInt) :: hdferr, NmatPoints, i +! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace +! integer(SIZE_T) :: type_size + +! integer(pInt), dimension(:,:), allocatable :: arr + +! integer(HSIZE_T), dimension(1) :: counter +! integer(HSSIZE_T), dimension(1) :: fileOffset + +! character(len=64) :: homogID + +! NmatPoints = count(material_homog /=0) +! allocate(arr(2,NmatPoints)) + +! arr(1,:) = (/(i, i=0,NmatPoints-1)/) +! arr(2,:) = pack(material_homog,material_homog/=0) + +! do i=1, size(homogenization_name) +! write(homogID, '(i0)') i +! mapping_ID = results_openGroup('/current/homogenization/'//trim(homogID)//'_'//homogenization_name(i)) + +!!-------------------------------------------------------------------------------------------------- +! ! create dataspace +! call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & +! int([dataspace_size(i)],HSIZE_T)) +! if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping') + +!!-------------------------------------------------------------------------------------------------- +! ! compound type +! call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) +! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') + +! call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tinsert_f 0') + +!!-------------------------------------------------------------------------------------------------- +! ! create Dataset +! call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog') + +!!-------------------------------------------------------------------------------------------------- +! ! Create memory types (one compound datatype for each member) +! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tcreate_f position_id') +! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tinsert_f position_id') + +!!-------------------------------------------------------------------------------------------------- +! ! Define and select hyperslabs +! counter = NmatPoints ! how big i am +! fileOffset = mpiOffset_homog(i) ! where i start to write my data + +! call h5screate_simple_f(1, counter, memspace, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5screate_simple_f') +! call h5dget_space_f(dset_id, space_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5dget_space_f') +! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5sselect_hyperslab_f') + +!!-------------------------------------------------------------------------------------------------- +! ! Create property list for collective dataset write +!#ifdef PETSc +! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5pcreate_f') +! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5pset_dxpl_mpio_f') +!#endif + +!!-------------------------------------------------------------------------------------------------- +! ! write data by fields in the datatype. Fields order is not important. +! call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset,int([dataspace_size(i)],HSIZE_T),& +! hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5dwrite_f instance_id') + +!!-------------------------------------------------------------------------------------------------- +! !close types, dataspaces +! call h5tclose_f(dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tclose_f dtype_id') +! call h5tclose_f(position_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tclose_f position_id') +! call h5dclose_f(dset_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5dclose_f') +! call h5sclose_f(space_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5sclose_f space_id') +! call h5sclose_f(memspace, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5sclose_f memspace') +! call h5pclose_f(plist_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5pclose_f') +! call HDF5_closeGroup(mapping_ID) + +! enddo + +!end subroutine HDF5_backwardMappingHomog + + +!!-------------------------------------------------------------------------------------------------- +!!> @brief adds the unique cell to node mapping +!!-------------------------------------------------------------------------------------------------- +!subroutine HDF5_mappingCells(mapping) +! use hdf5 + +! integer(pInt), intent(in), dimension(:) :: mapping + +! integer :: hdferr, Nnodes +! integer(HID_T) :: mapping_id, dset_id, space_id + +! Nnodes=size(mapping) +! mapping_ID = results_openGroup("mapping") + +!!-------------------------------------------------------------------------------------------------- +!! create dataspace +! call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, & +! int([Nnodes],HSIZE_T)) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingCells: h5screate_simple_f') + +!!-------------------------------------------------------------------------------------------------- +!! create Dataset +! call h5dcreate_f(mapping_id, "Cell",H5T_NATIVE_INTEGER, space_id, dset_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingCells') + +!!-------------------------------------------------------------------------------------------------- +!! write data by fields in the datatype. Fields order is not important. +! call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, mapping, int([Nnodes],HSIZE_T), hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingCells: h5dwrite_f instance_id') + +!!-------------------------------------------------------------------------------------------------- +!!close types, dataspaces +! call h5dclose_f(dset_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingConstitutive: h5dclose_f') +! call h5sclose_f(space_id, hdferr) +! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingConstitutive: h5sclose_f') +! call HDF5_closeGroup(mapping_ID) + +!end subroutine HDF5_mappingCells end module results