diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f1af6259f..9b992136c 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -7,9 +7,9 @@ stages: - compilePETScGNU - prepareSpectral - spectral - - compileMarc2018_1 + - compileMarc - marc - - compileAbaqus2017 + - compileAbaqus - example - performance - createPackage @@ -51,39 +51,37 @@ variables: # Names of module files to load # =============================================================================================== # ++++++++++++ Compiler ++++++++++++++++++++++++++++++++++++++++++++++ - IntelCompiler16_0: "Compiler/Intel/16.0 Libraries/IMKL/2016" - IntelCompiler16_4: "Compiler/Intel/16.4 Libraries/IMKL/2016-4" - IntelCompiler17_0: "Compiler/Intel/17.0 Libraries/IMKL/2017" - IntelCompiler18_1: "Compiler/Intel/18.1 Libraries/IMKL/2018" - GNUCompiler7_3: "Compiler/GNU/7.3" + IntelCompiler16_4: "Compiler/Intel/16.4 Libraries/IMKL/2016" + IntelCompiler17_8: "Compiler/Intel/17.8 Libraries/IMKL/2017" + IntelCompiler18_4: "Compiler/Intel/18.4 Libraries/IMKL/2018" + GNUCompiler8_2: "Compiler/GNU/8.2" # ------------ Defaults ---------------------------------------------- - IntelCompiler: "$IntelCompiler18_1" - GNUCompiler: "$GNUCompiler7_3" + IntelCompiler: "$IntelCompiler18_4" + GNUCompiler: "$GNUCompiler8_2" # ++++++++++++ MPI +++++++++++++++++++++++++++++++++++++++++++++++++++ - MPICH3_2Intel18_1: "MPI/Intel/18.1/MPICH/3.2.1" - MPICH3_2GNU7_3: "MPI/GNU/7.3/MPICH/3.2.1" + IMPI2018Intel18_4: "MPI/Intel/18.4/IntelMPI/2018" + MPICH3_3GNU8_2: "MPI/GNU/8.2/MPICH/3.3" # ------------ Defaults ---------------------------------------------- - MPICH_Intel: "$MPICH3_2Intel18_1" - MPICH_GNU: "$MPICH3_2GNU7_3" + MPICH_Intel: "$IMPI2018Intel18_4" + MPICH_GNU: "$MPICH3_3GNU8_2" # ++++++++++++ PETSc +++++++++++++++++++++++++++++++++++++++++++++++++ - PETSc3_10_0MPICH3_2Intel18_1: "Libraries/PETSc/3.10.0/Intel-18.1-MPICH-3.2.1" - PETSc3_10_0MPICH3_2GNU7_3: "Libraries/PETSc/3.10.0/GNU-7.3-MPICH-3.2.1" + PETSc3_10_3IMPI2018Intel18_4: "Libraries/PETSc/3.10.3/Intel-18.4-IntelMPI-2018" + PETSc3_10_3MPICH3_3GNU8_2: "Libraries/PETSc/3.10.3/GNU-8.2-MPICH-3.3" # ------------ Defaults ---------------------------------------------- - PETSc_MPICH_Intel: "$PETSc3_10_0MPICH3_2Intel18_1" - PETSc_MPICH_GNU: "$PETSc3_10_0MPICH3_2GNU7_3" + PETSc_MPICH_Intel: "$PETSc3_10_3IMPI2018Intel18_4" + PETSc_MPICH_GNU: "$PETSc3_10_3MPICH3_3GNU8_2" # ++++++++++++ FEM +++++++++++++++++++++++++++++++++++++++++++++++++++ - Abaqus2017: "FEM/Abaqus/2017" + Abaqus2019: "FEM/Abaqus/2019" MSC2018_1: "FEM/MSC/2018.1" - MSC2017: "FEM/MSC/2017" # ------------ Defaults ---------------------------------------------- - Abaqus: "$Abaqus2017" + Abaqus: "$Abaqus2019" MSC: "$MSC2018_1" - IntelMarc: "$IntelCompiler17_0" + IntelMarc: "$IntelCompiler17_8" IntelAbaqus: "$IntelCompiler16_4" # ++++++++++++ Documentation +++++++++++++++++++++++++++++++++++++++++ - Doxygen1_8_13: "Documentation/Doxygen/1.8.13" + Doxygen1_8_15: "Documentation/Doxygen/1.8.15" # ------------ Defaults ---------------------------------------------- - Doxygen: "$Doxygen1_8_13" + Doxygen: "$Doxygen1_8_15" ################################################################################################### @@ -158,6 +156,13 @@ Post_AverageDown: - master - release +Post_ASCIItable: + stage: postprocessing + script: ASCIItable/test.py + except: + - master + - release + Post_General: stage: postprocessing script: PostProcessing/test.py @@ -383,9 +388,9 @@ TextureComponents: ################################################################################################### Marc_compileIfort2018_1: - stage: compileMarc2018_1 + stage: compileMarc script: - - module load $IntelCompiler17_0 $MSC2018_1 + - module load $IntelMarc $MSC - Marc_compileIfort/test.py -m 2018.1 except: - master @@ -430,11 +435,11 @@ J2_plasticBehavior: - release ################################################################################################### -Abaqus_compile2017: - stage: compileAbaqus2017 +Abaqus_compile: + stage: compileAbaqus script: - - module load $IntelCompiler16_4 $Abaqus2017 - - Abaqus_compileIfort/test.py -a 2017 + - module load $IntelAbaqus $Abaqus + - Abaqus_compileIfort/test.py except: - master - release @@ -477,24 +482,40 @@ AbaqusStd: script: - module load $IntelCompiler $MPICH_Intel $PETSc_MPICH_Intel $Doxygen - $DAMASKROOT/PRIVATE/documenting/runDoxygen.sh $DAMASKROOT abaqus - only: - - development + except: + - master + - release Marc: stage: createDocumentation script: - module load $IntelCompiler $MPICH_Intel $PETSc_MPICH_Intel $Doxygen - $DAMASKROOT/PRIVATE/documenting/runDoxygen.sh $DAMASKROOT marc - only: - - development + except: + - master + - release Spectral: stage: createDocumentation script: - module load $IntelCompiler $MPICH_Intel $PETSc_MPICH_Intel $Doxygen - $DAMASKROOT/PRIVATE/documenting/runDoxygen.sh $DAMASKROOT spectral - only: - - development + except: + - master + - release + +Processing: + stage: createDocumentation + script: + - cd $DAMASKROOT/processing/pre + - rm 3DRVEfrom2Dang.py abq_addUserOutput.py marc_addUserOutput.py + - $DAMASKROOT/PRIVATE/documenting/scriptHelpToWiki.py --debug *.py + - cd $DAMASKROOT/processing/post + - rm marc_to_vtk.py vtk2ang.py + - $DAMASKROOT/PRIVATE/documenting/scriptHelpToWiki.py --debug *.py + except: + - master + - release ################################################################################################## backupData: @@ -503,11 +524,10 @@ backupData: - cd $TESTROOT/performance # location of new runtime results - git commit -am"${CI_PIPELINE_ID}_${CI_COMMIT_SHA}" - mkdir $BACKUP/${CI_PIPELINE_ID}_${CI_COMMIT_SHA} - - cp $TESTROOT/performance/time.txt $BACKUP/${CI_PIPELINE_ID}_${CI_COMMIT_SHA}/ - mv $TESTROOT/performance/time.png $BACKUP/${CI_PIPELINE_ID}_${CI_COMMIT_SHA}/ - - cp $TESTROOT/performance/memory.txt $BACKUP/${CI_PIPELINE_ID}_${CI_COMMIT_SHA}/ - mv $TESTROOT/performance/memory.png $BACKUP/${CI_PIPELINE_ID}_${CI_COMMIT_SHA}/ - mv $DAMASKROOT/PRIVATE/documenting/DAMASK_* $BACKUP/${CI_PIPELINE_ID}_${CI_COMMIT_SHA}/ + - mv $DAMASKROOT/processing $BACKUP/${CI_PIPELINE_ID}_${CI_COMMIT_SHA}/ only: - development diff --git a/CMakeLists.txt b/CMakeLists.txt index 3aa49cd7a..6096c8824 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -445,6 +445,33 @@ elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") # Additional options # -fdefault-integer-8: Use it to set precision to 8 bytes for integer, don't use it for the standard case of pInt=4 (there is no -fdefault-integer-4) + + +################################################################################################### +# 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 else () message (FATAL_ERROR "Compiler type (CMAKE_Fortran_COMPILER_ID) not recognized") endif () diff --git a/CONFIG b/CONFIG index 13b75a768..31a9c34c8 100644 --- a/CONFIG +++ b/CONFIG @@ -8,6 +8,6 @@ set DAMASK_NUM_THREADS = 4 set MSC_ROOT = /opt/msc set MARC_VERSION = 2018.1 -set ABAQUS_VERSION = 2017 +set ABAQUS_VERSION = 2019 set DAMASK_HDF5 = OFF diff --git a/PRIVATE b/PRIVATE index 406d482f8..e86418193 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 406d482f8059b4459634af729ce85491a9a3245c +Subproject commit e86418193f202364e068de2dffee36f99c846856 diff --git a/README b/README index 5c5d976b6..7fc372881 100644 --- a/README +++ b/README @@ -10,3 +10,4 @@ Germany Email: DAMASK@mpie.de https://damask.mpie.de +https://magit1.mpie.de diff --git a/VERSION b/VERSION index 2479c4238..7d075db3e 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.2-1667-g6b66563b +v2.0.2-1837-g3bec76e7 diff --git a/processing/post/addAPS34IDEstrainCoords.py b/processing/post/addAPS34IDEstrainCoords.py index 1071baa91..67231a368 100755 --- a/processing/post/addAPS34IDEstrainCoords.py +++ b/processing/post/addAPS34IDEstrainCoords.py @@ -14,20 +14,15 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Transform X,Y,Z,F APS BeamLine 34 coordinates to x,y,z APS strain coordinates. """, version = scriptID) -parser.add_option('-f', - '--frame', - dest='frame', - metavar='string', - help='APS X,Y,Z coords') -parser.add_option('--depth', - dest='depth', - metavar='string', - help='depth') +parser.add_option('-f','--frame',dest='frame', metavar='string', + help='label of APS X,Y,Z coords') +parser.add_option('--depth', dest='depth', metavar='string', + help='depth') (options,filenames) = parser.parse_args() diff --git a/processing/post/addCalculation.py b/processing/post/addCalculation.py index d19855753..73edde9e8 100755 --- a/processing/post/addCalculation.py +++ b/processing/post/addCalculation.py @@ -18,7 +18,7 @@ def listify(x): # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add or alter column(s) with derived values according to user-defined arithmetic operation between column(s). Column labels are tagged by '#label#' in formulas. Use ';' for ',' in functions. Numpy is available as 'np'. @@ -41,10 +41,7 @@ parser.add_option('-f','--formula', parser.add_option('-c','--condition', dest = 'condition', metavar='string', - help = 'condition to alter existing column data') - -parser.set_defaults(condition = None, - ) + help = 'condition to alter existing column data (optional)') (options,filenames) = parser.parse_args() @@ -80,7 +77,7 @@ for name in filenames: condition = options.condition # copy per file, since might be altered inline breaker = False - for position,(all,marker,column) in enumerate(set(re.findall(r'#(([s]#)?(.+?))#',condition))): # find three groups + for position,(all,marker,column) in enumerate(set(re.findall(r'#(([s]#)?(.+?))#',condition))): # find three groups idx = table.label_index(column) dim = table.label_dimension(column) if idx < 0 and column not in specials: @@ -89,15 +86,15 @@ for name in filenames: else: if column in specials: replacement = 'specials["{}"]'.format(column) - elif dim == 1: # scalar input + elif dim == 1: # scalar input replacement = '{}(table.data[{}])'.format({ '':'float', - 's#':'str'}[marker],idx) # take float or string value of data column - elif dim > 1: # multidimensional input (vector, tensor, etc.) - replacement = 'np.array(table.data[{}:{}],dtype=float)'.format(idx,idx+dim) # use (flat) array representation + 's#':'str'}[marker],idx) # take float or string value of data column + elif dim > 1: # multidimensional input (vector, tensor, etc.) + replacement = 'np.array(table.data[{}:{}],dtype=float)'.format(idx,idx+dim) # use (flat) array representation condition = condition.replace('#'+all+'#',replacement) - if breaker: continue # found mistake in condition evaluation --> next file + if breaker: continue # found mistake in condition evaluation --> next file # ------------------------------------------ build formulas ---------------------------------------- diff --git a/processing/post/addCauchy.py b/processing/post/addCauchy.py index 3c873f2aa..c7b95f562 100755 --- a/processing/post/addCauchy.py +++ b/processing/post/addCauchy.py @@ -13,8 +13,8 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ -Add column(s) containing Cauchy stress based on given column(s) of deformation gradient and first Piola--Kirchhoff stress. +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ +Add column containing Cauchy stress based on deformation gradient and first Piola--Kirchhoff stress. """, version = scriptID) diff --git a/processing/post/addCompatibilityMismatch.py b/processing/post/addCompatibilityMismatch.py index 7d2a89fa0..1fe84bf2b 100755 --- a/processing/post/addCompatibilityMismatch.py +++ b/processing/post/addCompatibilityMismatch.py @@ -209,7 +209,7 @@ def shapeMismatch(size,F,nodes,centres): # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options file[s]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add column(s) containing the shape and volume mismatch resulting from given deformation gradient. Operates on periodic three-dimensional x,y,z-ordered data sets. diff --git a/processing/post/addCumulative.py b/processing/post/addCumulative.py index 4588d915c..392cbd69e 100755 --- a/processing/post/addCumulative.py +++ b/processing/post/addCumulative.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,sys @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add cumulative (sum of first to current row) values for given label(s). """, version = scriptID) @@ -22,12 +22,9 @@ parser.add_option('-l','--label', action = 'extend', metavar = '', help = 'columns to cumulate') -parser.set_defaults(label = [], - ) - (options,filenames) = parser.parse_args() -if len(options.label) == 0: +if options.label is None: parser.error('no data column(s) specified.') # --- loop over input files ------------------------------------------------------------------------- diff --git a/processing/post/addCurl.py b/processing/post/addCurl.py index 2716849b4..5c9d46e2f 100755 --- a/processing/post/addCurl.py +++ b/processing/post/addCurl.py @@ -49,14 +49,14 @@ def curlFFT(geomdim,field): curl_fourier = np.einsum(einsums[n],e,k_s,field_fourier)*TWOPIIMG - return np.fft.irfftn(curl_fourier,s=shapeFFT,axes=(0,1,2)).reshape([N,n]) + return np.fft.irfftn(curl_fourier,axes=(0,1,2),s=shapeFFT).reshape([N,n]) # -------------------------------------------------------------------- # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog option(s) [ASCIItable(s)]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add column(s) containing curl of requested column(s). Operates on periodic ordered three-dimensional data sets of vector and tensor fields. diff --git a/processing/post/addDerivative.py b/processing/post/addDerivative.py index dc97c09ea..7967af4b2 100755 --- a/processing/post/addDerivative.py +++ b/processing/post/addDerivative.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,sys @@ -34,7 +34,7 @@ def derivative(coordinates,what): # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add column(s) containing numerical derivative of requested column(s) with respect to given coordinates. """, version = scriptID) diff --git a/processing/post/addDeterminant.py b/processing/post/addDeterminant.py index b8b177e37..897f2364b 100755 --- a/processing/post/addDeterminant.py +++ b/processing/post/addDeterminant.py @@ -20,7 +20,7 @@ def determinant(m): # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add column(s) containing determinant of requested tensor column(s). """, version = scriptID) diff --git a/processing/post/addDeviator.py b/processing/post/addDeviator.py index 1f97ca467..220b29ec8 100755 --- a/processing/post/addDeviator.py +++ b/processing/post/addDeviator.py @@ -23,7 +23,7 @@ def deviator(m,spherical = False): # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(2)]', description = """ Add column(s) containing deviator of requested tensor column(s). """, version = scriptID) diff --git a/processing/post/addDisplacement.py b/processing/post/addDisplacement.py index ff9d251f7..aa12ba2b1 100755 --- a/processing/post/addDisplacement.py +++ b/processing/post/addDisplacement.py @@ -87,7 +87,7 @@ def displacementFluctFFT(F,grid,size,nodal=False,transformed=False): # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog [options] [ASCIItable(s)]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add displacments resulting from deformation gradient field. Operates on periodic three-dimensional x,y,z-ordered data sets. Outputs at cell centers or cell nodes (into separate file). @@ -111,7 +111,6 @@ parser.add_option('--nodal', parser.set_defaults(defgrad = 'f', pos = 'pos', - nodal = False, ) (options,filenames) = parser.parse_args() diff --git a/processing/post/addDivergence.py b/processing/post/addDivergence.py index 0aa4b05ae..f579a0a49 100755 --- a/processing/post/addDivergence.py +++ b/processing/post/addDivergence.py @@ -45,7 +45,7 @@ def divFFT(geomdim,field): div_fourier = np.einsum(einsums[n],k_s,field_fourier)*TWOPIIMG - return np.fft.irfftn(div_fourier,s=shapeFFT,axes=(0,1,2)).reshape([N,n//3]) + return np.fft.irfftn(div_fourier,axes=(0,1,2),s=shapeFFT).reshape([N,n//3]) # -------------------------------------------------------------------- diff --git a/processing/post/addEhkl.py b/processing/post/addEhkl.py index 3cfec69af..573484617 100755 --- a/processing/post/addEhkl.py +++ b/processing/post/addEhkl.py @@ -30,7 +30,7 @@ def E_hkl(stiffness,vec): # stiffness = (c11,c12,c44) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add column(s) containing directional stiffness based on given cubic stiffness values C11, C12, and C44 in consecutive columns. """, version = scriptID) diff --git a/processing/post/addEuclideanDistance.py b/processing/post/addEuclideanDistance.py index f759b7a8f..b11f46fd8 100755 --- a/processing/post/addEuclideanDistance.py +++ b/processing/post/addEuclideanDistance.py @@ -83,7 +83,7 @@ neighborhoods = { ]) } -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add column(s) containing Euclidean distance to grain structural features: boundaries, triple lines, and quadruple points. """, version = scriptID) diff --git a/processing/post/addGaussian.py b/processing/post/addGaussian.py index f468790ef..3f237a3e6 100755 --- a/processing/post/addGaussian.py +++ b/processing/post/addGaussian.py @@ -15,7 +15,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog option(s) [ASCIItable(s)]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog option [ASCIItable(s)]', description = """ Add column(s) containing Gaussian filtered values of requested column(s). Operates on periodic and non-periodic ordered three-dimensional data sets. For details see scipy.ndimage documentation. @@ -34,12 +34,12 @@ parser.add_option('-o','--order', dest = 'order', type = int, metavar = 'int', - help = 'order of the filter') + help = 'order of the filter [%default]') parser.add_option('--sigma', dest = 'sigma', type = float, metavar = 'float', - help = 'standard deviation') + help = 'standard deviation [%default]') parser.add_option('--periodic', dest = 'periodic', action = 'store_true', @@ -50,7 +50,6 @@ parser.add_option('--periodic', parser.set_defaults(pos = 'pos', order = 0, sigma = 1, - periodic = False, ) (options,filenames) = parser.parse_args() diff --git a/processing/post/addGradient.py b/processing/post/addGradient.py index 83cb54064..d3910d2ad 100755 --- a/processing/post/addGradient.py +++ b/processing/post/addGradient.py @@ -45,14 +45,14 @@ def gradFFT(geomdim,field): k_s = np.concatenate((ki[:,:,:,None],kj[:,:,:,None],kk[:,:,:,None]),axis = 3).astype('c16') grad_fourier = np.einsum(einsums[n],field_fourier,k_s)*TWOPIIMG - return np.fft.irfftn(grad_fourier,s=shapeFFT,axes=(0,1,2)).reshape([N,3*n]) + return np.fft.irfftn(grad_fourier,axes=(0,1,2),s=shapeFFT).reshape([N,3*n]) # -------------------------------------------------------------------- # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog option(s) [ASCIItable(s)]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog option [ASCIItable(s)]', description = """ Add column(s) containing gradient of requested column(s). Operates on periodic ordered three-dimensional data sets of vector and scalar fields. diff --git a/processing/post/addGrainID.py b/processing/post/addGrainID.py index 3c4eaf4fa..6493736d8 100755 --- a/processing/post/addGrainID.py +++ b/processing/post/addGrainID.py @@ -28,9 +28,9 @@ parser.add_option('-d', help = 'disorientation threshold in degrees [%default]') parser.add_option('-s', '--symmetry', - dest = 'symmetry', + dest = 'symmetry', type = 'choice', choices = damask.Symmetry.lattices[1:], metavar = 'string', - help = 'crystal symmetry [%default]') + help = 'crystal symmetry [%default] {{{}}} '.format(', '.join(damask.Symmetry.lattices[1:]))) parser.add_option('-o', '--orientation', dest = 'quaternion', @@ -49,7 +49,7 @@ parser.add_option('--quiet', parser.set_defaults(disorientation = 5, verbose = True, quaternion = 'orientation', - symmetry = 'cubic', + symmetry = damask.Symmetry.lattices[-1], pos = 'pos', ) diff --git a/processing/post/addIPFcolor.py b/processing/post/addIPFcolor.py index c5a59a63a..9c191b3ad 100755 --- a/processing/post/addIPFcolor.py +++ b/processing/post/addIPFcolor.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add RGB color value corresponding to TSL-OIM scheme for inverse pole figures. """, version = scriptID) diff --git a/processing/post/addIndexed.py b/processing/post/addIndexed.py index 63206d329..9a73f5572 100755 --- a/processing/post/addIndexed.py +++ b/processing/post/addIndexed.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add data in column(s) of mapped ASCIItable selected from the row indexed by the value in a mapping column. Row numbers start at 1. diff --git a/processing/post/addInfo.py b/processing/post/addInfo.py index 59efcd973..fbfa8c3dd 100755 --- a/processing/post/addInfo.py +++ b/processing/post/addInfo.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options file[s]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add info lines to ASCIItable header. """, version = scriptID) @@ -23,11 +23,12 @@ parser.add_option('-i', dest = 'info', action = 'extend', metavar = '', help = 'items to add') -parser.set_defaults(info = [], - ) (options,filenames) = parser.parse_args() +if options.info is None: + parser.error('no info specified.') + # --- loop over input files ------------------------------------------------------------------------ if filenames == []: filenames = [None] diff --git a/processing/post/addLinked.py b/processing/post/addLinked.py index d60307bc2..bed3da30a 100755 --- a/processing/post/addLinked.py +++ b/processing/post/addLinked.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,sys @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add data of selected column(s) from (first) row of linked ASCIItable that shares the linking column value. """, version = scriptID) @@ -21,7 +21,7 @@ Add data of selected column(s) from (first) row of linked ASCIItable that shares parser.add_option('--link', dest = 'link', nargs = 2, type = 'string', metavar = 'string string', - help = 'column labels containing linked values') + help = 'column labels of table and linked table containing linking values') parser.add_option('-l','--label', dest = 'label', action = 'extend', metavar = '', @@ -105,7 +105,8 @@ for name in filenames: outputAlive = True while outputAlive and table.data_read(): # read next data line of ASCII table try: - table.data_append(data[np.argwhere(np.all((map(float,table.data[myLink:myLink+myLinkDim]) - index)==0,axis=1))[0]]) # add data of first matching line + table.data_append(data[np.argwhere(np.all((list(map(float,table.data[myLink:myLink+myLinkDim])) - index)==0, + axis=1))[0]]) # add data of first matching line except IndexError: table.data_append(np.nan*np.ones_like(data[0])) # or add NaNs outputAlive = table.data_write() # output processed line diff --git a/processing/post/addMises.py b/processing/post/addMises.py index 7e757ed9d..35a6922c3 100755 --- a/processing/post/addMises.py +++ b/processing/post/addMises.py @@ -24,7 +24,7 @@ def Mises(what,tensor): # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add vonMises equivalent values for symmetric part of requested strains and/or stresses. """, version = scriptID) @@ -38,13 +38,9 @@ parser.add_option('-s','--stress', action = 'extend', metavar = '', help = 'heading(s) of columns containing stress tensors') -parser.set_defaults(strain = [], - stress = [], - ) - (options,filenames) = parser.parse_args() -if len(options.stress+options.strain) == 0: +if options.stress is None and options.strain is None: parser.error('no data column specified...') # --- loop over input files ------------------------------------------------------------------------- diff --git a/processing/post/addNorm.py b/processing/post/addNorm.py index f90cd4b31..efadc0f52 100755 --- a/processing/post/addNorm.py +++ b/processing/post/addNorm.py @@ -9,6 +9,7 @@ scriptName = os.path.splitext(os.path.basename(__file__))[0] scriptID = ' '.join([scriptName,damask.version]) # definition of element-wise p-norms for matrices +# ToDo: better use numpy.linalg.norm def norm(which,object): @@ -18,12 +19,14 @@ def norm(which,object): return math.sqrt(sum([x*x for x in object])) elif which == 'Max': # p = inf return max(map(abs, object)) + else: + return -1 # -------------------------------------------------------------------- # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add column(s) containing norm of requested column(s) being either vectors or tensors. """, version = scriptID) @@ -43,6 +46,8 @@ parser.set_defaults(norm = 'frobenius', (options,filenames) = parser.parse_args() +if options.norm.lower() not in normChoices: + parser.error('invalid norm ({}) specified.'.format(options.norm)) if options.label is None: parser.error('no data column specified.') @@ -74,7 +79,7 @@ for name in filenames: else: dims.append(dim) columns.append(table.label_index(what)) - table.labels_append('norm{}({})'.format(options.norm.capitalize(),what)) # extend ASCII header with new labels + table.labels_append('norm{}({})'.format(options.norm.capitalize(),what)) # extend ASCII header with new labels if remarks != []: damask.util.croak(remarks) if errors != []: diff --git a/processing/post/addOrientations.py b/processing/post/addOrientations.py index c9db1cbd7..cc10dfb84 100755 --- a/processing/post/addOrientations.py +++ b/processing/post/addOrientations.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add quaternion and/or Bunge Euler angle representation of crystal lattice orientation. Orientation is given by quaternion, Euler angles, rotation matrix, or crystal frame coordinates (i.e. component vectors of rotation matrix). @@ -43,12 +43,12 @@ parser.add_option('-R', '--labrotation', dest='labrotation', type = 'float', nargs = 4, metavar = ' '.join(['float']*4), - help = 'angle and axis of additional lab frame rotation') + help = 'angle and axis of additional lab frame rotation [%default]') parser.add_option('-r', '--crystalrotation', dest='crystalrotation', type = 'float', nargs = 4, metavar = ' '.join(['float']*4), - help = 'angle and axis of additional crystal frame rotation') + help = 'angle and axis of additional crystal frame rotation [%default]') parser.add_option('--eulers', dest = 'eulers', metavar = 'string', @@ -81,7 +81,6 @@ parser.add_option('-z', parser.set_defaults(output = [], labrotation = (0.,1.,0.,0.), # no rotation about 1,0,0 crystalrotation = (0.,1.,0.,0.), # no rotation about 1,0,0 - degrees = False, ) (options, filenames) = parser.parse_args() diff --git a/processing/post/addPK2.py b/processing/post/addPK2.py index 3c615295d..cddcd7002 100755 --- a/processing/post/addPK2.py +++ b/processing/post/addPK2.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add column(s) containing Second Piola--Kirchhoff stress based on given column(s) of deformation gradient and first Piola--Kirchhoff stress. diff --git a/processing/post/addPole.py b/processing/post/addPole.py index 3098effc7..628d64d5e 100755 --- a/processing/post/addPole.py +++ b/processing/post/addPole.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add coordinates of stereographic projection of given direction (pole) in crystal frame. """, version = scriptID) @@ -35,7 +35,6 @@ parser.add_option('-o', parser.set_defaults(pole = (1.0,0.0,0.0), quaternion = 'orientation', - polar = False, ) (options, filenames) = parser.parse_args() diff --git a/processing/post/addSchmidfactors.py b/processing/post/addSchmidfactors.py index 37dd56512..b4033a035 100755 --- a/processing/post/addSchmidfactors.py +++ b/processing/post/addSchmidfactors.py @@ -103,7 +103,7 @@ slipSystems = { # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add columns listing Schmid factors (and optional trace vector of selected system) for given Euler angles. """, version = scriptID) @@ -115,7 +115,7 @@ parser.add_option('-l', help = 'type of lattice structure [%default] {}'.format(latticeChoices)) parser.add_option('--covera', dest = 'CoverA', type = 'float', metavar = 'float', - help = 'C over A ratio for hexagonal systems') + help = 'C over A ratio for hexagonal systems [%default]') parser.add_option('-f', '--force', dest = 'force', diff --git a/processing/post/addSpectralDecomposition.py b/processing/post/addSpectralDecomposition.py index e7d552c70..f3c25b117 100755 --- a/processing/post/addSpectralDecomposition.py +++ b/processing/post/addSpectralDecomposition.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add column(s) containing eigenvalues and eigenvectors of requested symmetric tensor column(s). """, version = scriptID) diff --git a/processing/post/addStrainTensors.py b/processing/post/addStrainTensors.py index bffc92f9a..375b0b5e8 100755 --- a/processing/post/addStrainTensors.py +++ b/processing/post/addStrainTensors.py @@ -25,7 +25,7 @@ def operator(stretch,strain,eigenvalues): # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Add column(s) containing given strains based on given stretches of requested deformation gradient column(s). """, version = scriptID) @@ -56,16 +56,15 @@ parser.add_option('-f','--defgrad', metavar = '', help = 'heading(s) of columns containing deformation tensor values [%default]') -parser.set_defaults(right = False, - left = False, - logarithmic = False, - biot = False, - green = False, +parser.set_defaults( defgrad = ['f'], ) (options,filenames) = parser.parse_args() +if len(options.defgrad) > 1: + options.defgrad = options.defgrad[1:] + stretches = [] strains = [] diff --git a/processing/post/addTable.py b/processing/post/addTable.py index 82799b4f5..eb61b43dc 100755 --- a/processing/post/addTable.py +++ b/processing/post/addTable.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,sys @@ -12,7 +12,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Append data of ASCIItable(s). """, version = scriptID) @@ -24,6 +24,10 @@ parser.add_option('-a', '--add','--table', (options,filenames) = parser.parse_args() +if options.table is None: + parser.error('no table specified.') + + # --- loop over input files ------------------------------------------------------------------------- if filenames == []: filenames = [None] diff --git a/processing/post/averageDown.py b/processing/post/averageDown.py index 96520a789..3a70cf314 100755 --- a/processing/post/averageDown.py +++ b/processing/post/averageDown.py @@ -14,7 +14,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Average each data block of size 'packing' into single values thus reducing the former grid to grid/packing. """, version = scriptID) @@ -34,16 +34,14 @@ parser.add_option('--shift', parser.add_option('-g', '--grid', dest = 'grid', type = 'int', nargs = 3, metavar = 'int int int', - help = 'grid in x,y,z [autodetect]') + help = 'grid in x,y,z (optional)') parser.add_option('-s', '--size', dest = 'size', type = 'float', nargs = 3, metavar = 'float float float', - help = 'size in x,y,z [autodetect]') + help = 'size in x,y,z (optional)') parser.set_defaults(pos = 'pos', packing = (2,2,2), shift = (0,0,0), - grid = (0,0,0), - size = (0.0,0.0,0.0), ) (options,filenames) = parser.parse_args() @@ -92,7 +90,7 @@ for name in filenames: table.data_readArray() - if (any(options.grid) == 0 or any(options.size) == 0.0): + if (options.grid is None or options.size is None): grid,size = damask.util.coordGridAndSize(table.data[:,table.label_indexrange(options.pos)]) else: grid = np.array(options.grid,'i') diff --git a/processing/post/binXY.py b/processing/post/binXY.py index ea73d13b9..dc286b7ac 100755 --- a/processing/post/binXY.py +++ b/processing/post/binXY.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Produces a binned grid of two columns from an ASCIItable, i.e. a two-dimensional probability density map. """, version = scriptID) @@ -37,15 +37,15 @@ parser.add_option('-t','--type', parser.add_option('-x','--xrange', dest = 'xrange', type = 'float', nargs = 2, metavar = 'float float', - help = 'min max value in x direction [autodetect]') + help = 'min max limits in x direction (optional)') parser.add_option('-y','--yrange', dest = 'yrange', type = 'float', nargs = 2, metavar = 'float float', - help = 'min max value in y direction [autodetect]') + help = 'min max limits in y direction (optional)') parser.add_option('-z','--zrange', dest = 'zrange', type = 'float', nargs = 2, metavar = 'float float', - help = 'min max value in z direction [autodetect]') + help = 'min max limits in z direction (optional)') parser.add_option('-i','--invert', dest = 'invert', action = 'store_true', @@ -64,9 +64,6 @@ parser.set_defaults(bins = (10,10), xrange = (0.0,0.0), yrange = (0.0,0.0), zrange = (0.0,0.0), - invert = False, - normRow = False, - normCol = False, ) (options,filenames) = parser.parse_args() diff --git a/processing/post/blowUp.py b/processing/post/blowUp.py index 5a0d631e0..d596bb751 100755 --- a/processing/post/blowUp.py +++ b/processing/post/blowUp.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,sys @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Blows up each value to a surrounding data block of size 'packing' thus increasing the former resolution to resolution*packing. @@ -27,10 +27,10 @@ parser.add_option('-p','--packing', help = 'dimension of packed group [%default]') parser.add_option('-g','--grid', dest = 'resolution', type = 'int', nargs = 3, metavar = 'int int int', - help = 'resolution in x,y,z [autodetect]') + help = 'grid in x,y,z (optional)') parser.add_option('-s','--size', dest = 'dimension', type = 'float', nargs = 3, metavar = 'int int int', - help = 'dimension in x,y,z [autodetect]') + help = 'size in x,y,z (optional)') parser.set_defaults(pos = 'pos', packing = (2,2,2), grid = (0,0,0), diff --git a/processing/post/filterTable.py b/processing/post/filterTable.py index 865df6c03..2703ea274 100755 --- a/processing/post/filterTable.py +++ b/processing/post/filterTable.py @@ -30,7 +30,7 @@ def sortingList(labels,whitelistitems): # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Filter rows according to condition and columns by either white or black listing. Examples: diff --git a/processing/post/groupTable.py b/processing/post/groupTable.py index f78566304..d97861495 100755 --- a/processing/post/groupTable.py +++ b/processing/post/groupTable.py @@ -20,7 +20,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Apply a user-specified function to condense into a single row all those rows for which columns 'label' have identical values. Output table will contain as many rows as there are different (unique) values in the grouping column(s). Periodic domain averaging of coordinate values is supported. diff --git a/processing/post/permuteData.py b/processing/post/permuteData.py index 1843c9f57..d263e42b8 100755 --- a/processing/post/permuteData.py +++ b/processing/post/permuteData.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Permute all values in given column(s). """, version = scriptID) diff --git a/processing/post/reLabel.py b/processing/post/reLabel.py index 0c6ef8dc9..a8d0e1556 100755 --- a/processing/post/reLabel.py +++ b/processing/post/reLabel.py @@ -12,7 +12,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog [options] dfile[s]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Rename scalar, vectorial, and/or tensorial data header labels. """, version = scriptID) diff --git a/processing/post/rotateData.py b/processing/post/rotateData.py index 5be38f1e8..1438acb15 100755 --- a/processing/post/rotateData.py +++ b/processing/post/rotateData.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Rotate vector and/or tensor column data by given angle around given axis. """, version = scriptID) @@ -29,7 +29,7 @@ parser.add_option('-r', '--rotation', parser.add_option('--degrees', dest = 'degrees', action = 'store_true', - help = 'angle is given in degrees [%default]') + help = 'angles are given in degrees') parser.set_defaults(rotation = (0.,1.,0.,0.), # no rotation about 1,0,0 degrees = False, diff --git a/processing/post/scaleData.py b/processing/post/scaleData.py index 381485a8a..368180f93 100755 --- a/processing/post/scaleData.py +++ b/processing/post/scaleData.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Uniformly scale column values by given factor. """, version = scriptID) diff --git a/processing/post/shiftData.py b/processing/post/shiftData.py index 4ad1cbd0d..f490ee66e 100755 --- a/processing/post/shiftData.py +++ b/processing/post/shiftData.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Uniformly shift column values by given offset. """, version = scriptID) diff --git a/processing/post/sortTable.py b/processing/post/sortTable.py index 92fa81672..bf23193bb 100755 --- a/processing/post/sortTable.py +++ b/processing/post/sortTable.py @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Sort rows by given (or all) column label(s). Examples: diff --git a/processing/post/viewTable.py b/processing/post/viewTable.py index d661e4727..514ea40d9 100755 --- a/processing/post/viewTable.py +++ b/processing/post/viewTable.py @@ -12,7 +12,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(usage='%prog [options] [file[s]]', description = """ +parser = OptionParser(usage='%prog options [ASCIItable(s)]', description = """ Show components of given ASCIItable(s). """, version = scriptID) diff --git a/processing/post/vtk_addGridData.py b/processing/post/vtk_addGridData.py index e0c274dc7..c458b1f07 100755 --- a/processing/post/vtk_addGridData.py +++ b/processing/post/vtk_addGridData.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,vtk @@ -17,7 +17,7 @@ scriptID = ' '.join([scriptName,damask.version]) msg = "Add scalars, vectors, and/or an RGB tuple from" msg += "an ASCIItable to existing VTK grid (.vtr/.vtk/.vtu)." parser = OptionParser(option_class=damask.extendableOption, - usage='%prog options [file[s]]', + usage='%prog options [ASCIItable(s)]', description = msg, version = scriptID) @@ -25,10 +25,6 @@ parser.add_option( '--vtk', dest = 'vtk', type = 'string', metavar = 'string', help = 'VTK file name') -parser.add_option( '--inplace', - dest = 'inplace', - action = 'store_true', - help = 'modify VTK file in-place') parser.add_option('-r', '--render', dest = 'render', action = 'store_true', @@ -49,7 +45,6 @@ parser.add_option('-c', '--color', parser.set_defaults(data = [], tensor = [], color = [], - inplace = False, render = False, ) @@ -64,24 +59,23 @@ if os.path.splitext(options.vtk)[1] == '.vtr': reader.Update() rGrid = reader.GetOutput() writer = vtk.vtkXMLRectilinearGridWriter() - writer.SetFileName(os.path.splitext(options.vtk)[0]+('.vtr' if options.inplace else '_added.vtr')) elif os.path.splitext(options.vtk)[1] == '.vtk': reader = vtk.vtkGenericDataObjectReader() reader.SetFileName(options.vtk) reader.Update() rGrid = reader.GetRectilinearGridOutput() writer = vtk.vtkXMLRectilinearGridWriter() - writer.SetFileName(os.path.splitext(options.vtk)[0]+('.vtr' if options.inplace else '_added.vtr')) elif os.path.splitext(options.vtk)[1] == '.vtu': reader = vtk.vtkXMLUnstructuredGridReader() reader.SetFileName(options.vtk) reader.Update() rGrid = reader.GetOutput() writer = vtk.vtkXMLUnstructuredGridWriter() - writer.SetFileName(os.path.splitext(options.vtk)[0]+('.vtu' if options.inplace else '_added.vtu')) else: parser.error('Unsupported VTK file type extension.') +writer.SetFileName(options.vtk) + Npoints = rGrid.GetNumberOfPoints() Ncells = rGrid.GetNumberOfCells() @@ -172,8 +166,7 @@ for name in filenames: writer.SetDataModeToBinary() writer.SetCompressorTypeToZLib() - if vtk.VTK_MAJOR_VERSION <= 5: writer.SetInput(rGrid) - else: writer.SetInputData(rGrid) + writer.SetInputData(rGrid) writer.Write() # ------------------------------------------ render result --------------------------------------- diff --git a/processing/post/vtk_addPointcloudData.py b/processing/post/vtk_addPointCloudData.py similarity index 91% rename from processing/post/vtk_addPointcloudData.py rename to processing/post/vtk_addPointCloudData.py index 3937413c6..5ab1d419e 100755 --- a/processing/post/vtk_addPointcloudData.py +++ b/processing/post/vtk_addPointCloudData.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,vtk @@ -15,7 +15,7 @@ scriptID = ' '.join([scriptName,damask.version]) # -------------------------------------------------------------------- parser = OptionParser(option_class=damask.extendableOption, - usage='%prog options [file[s]]', + usage='%prog options [ASCIItable(s)]', description = """Add scalar and RGB tuples from ASCIItable to existing VTK point cloud (.vtp).""", version = scriptID) @@ -23,10 +23,6 @@ parser.add_option( '--vtk', dest = 'vtk', type = 'string', metavar = 'string', help = 'VTK file name') -parser.add_option( '--inplace', - dest = 'inplace', - action = 'store_true', - help = 'modify VTK file in-place') parser.add_option('-r', '--render', dest = 'render', action = 'store_true', @@ -46,8 +42,6 @@ parser.add_option('-c', '--color', dest='color', action='extend', parser.set_defaults(data = [], tensor = [], color = [], - inplace = False, - render = False, ) (options, filenames) = parser.parse_args() @@ -151,14 +145,12 @@ for name in filenames: # ------------------------------------------ output result --------------------------------------- Polydata.Modified() - if vtk.VTK_MAJOR_VERSION <= 5: Polydata.Update() writer = vtk.vtkXMLPolyDataWriter() writer.SetDataModeToBinary() writer.SetCompressorTypeToZLib() - writer.SetFileName(os.path.splitext(options.vtk)[0]+('.vtp' if options.inplace else '_added.vtp')) - if vtk.VTK_MAJOR_VERSION <= 5: writer.SetInput(Polydata) - else: writer.SetInputData(Polydata) + writer.SetFileName(options.vtk) + writer.SetInputData(Polydata) writer.Write() # ------------------------------------------ render result --------------------------------------- diff --git a/processing/post/vtk_addRectilinearGridData.py b/processing/post/vtk_addRectilinearGridData.py index 9ec384e4d..e445214fd 100755 --- a/processing/post/vtk_addRectilinearGridData.py +++ b/processing/post/vtk_addRectilinearGridData.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,vtk @@ -25,10 +25,6 @@ parser.add_option( '--vtk', dest = 'vtk', type = 'string', metavar = 'string', help = 'VTK file name') -parser.add_option( '--inplace', - dest = 'inplace', - action = 'store_true', - help = 'modify VTK file in-place') parser.add_option('-r', '--render', dest = 'render', action = 'store_true', @@ -49,7 +45,6 @@ parser.add_option('-c', '--color', parser.set_defaults(data = [], tensor = [], color = [], - inplace = False, render = False, ) @@ -158,16 +153,14 @@ for name in filenames: elif mode == 'point': rGrid.GetPointData().AddArray(VTKarray[me]) rGrid.Modified() - if vtk.VTK_MAJOR_VERSION <= 5: rGrid.Update() # ------------------------------------------ output result --------------------------------------- writer = vtk.vtkXMLRectilinearGridWriter() writer.SetDataModeToBinary() writer.SetCompressorTypeToZLib() - writer.SetFileName(os.path.splitext(options.vtk)[0]+('.vtr' if options.inplace else '_added.vtr')) - if vtk.VTK_MAJOR_VERSION <= 5: writer.SetInput(rGrid) - else: writer.SetInputData(rGrid) + writer.SetFileName(options.vtk) + writer.SetInputData(rGrid) writer.Write() # ------------------------------------------ render result --------------------------------------- diff --git a/processing/post/vtk_pointcloud.py b/processing/post/vtk_pointCloud.py similarity index 93% rename from processing/post/vtk_pointcloud.py rename to processing/post/vtk_pointCloud.py index 54f02d300..2aad22479 100755 --- a/processing/post/vtk_pointcloud.py +++ b/processing/post/vtk_pointCloud.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,sys,vtk @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Produce a VTK point cloud dataset based on coordinates given in an ASCIItable. """, version = scriptID) @@ -78,7 +78,6 @@ for name in filenames: Polydata.SetPoints(Points) Polydata.SetVerts(Vertices) Polydata.Modified() - if vtk.VTK_MAJOR_VERSION <= 5: Polydata.Update() # ------------------------------------------ output result --------------------------------------- @@ -94,8 +93,8 @@ for name in filenames: writer.SetHeader('# powered by '+scriptID) writer.WriteToOutputStringOn() - if vtk.VTK_MAJOR_VERSION <= 5: writer.SetInput(Polydata) - else: writer.SetInputData(Polydata) + + writer.SetInputData(Polydata) writer.Write() diff --git a/processing/post/vtk_rectilinearGrid.py b/processing/post/vtk_rectilinearGrid.py index d01d118cb..2e7c66ad5 100755 --- a/processing/post/vtk_rectilinearGrid.py +++ b/processing/post/vtk_rectilinearGrid.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,sys,vtk @@ -13,7 +13,7 @@ scriptID = ' '.join([scriptName,damask.version]) # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [file[s]]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [ASCIItable(s)]', description = """ Create regular voxel grid from points in an ASCIItable. """, version = scriptID) @@ -125,8 +125,7 @@ for name in filenames: writer.SetHeader('# powered by '+scriptID) writer.WriteToOutputStringOn() - if vtk.VTK_MAJOR_VERSION <= 5: writer.SetInput(rGrid) - else: writer.SetInputData(rGrid) + writer.SetInputData(rGrid) writer.Write() diff --git a/processing/pre/geom_addPrimitive.py b/processing/pre/geom_addPrimitive.py index 8e512c44d..88df1e62d 100755 --- a/processing/pre/geom_addPrimitive.py +++ b/processing/pre/geom_addPrimitive.py @@ -25,7 +25,7 @@ mappings = { 'microstructures': lambda x: int(x), } -parser = OptionParser(option_class=damask.extendableOption, usage='%prog option(s) [geomfile(s)]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog option [geomfile(s)]', description = """ Positions a geometric object within the (three-dimensional) canvas of a spectral geometry description. Depending on the sign of the dimension parameters, these objects can be boxes, cylinders, or ellipsoids. diff --git a/processing/pre/geom_clean.py b/processing/pre/geom_clean.py index e3fa59dd8..907431146 100755 --- a/processing/pre/geom_clean.py +++ b/processing/pre/geom_clean.py @@ -18,7 +18,7 @@ def mostFrequent(arr): # MAIN #-------------------------------------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog option(s) [geomfile(s)]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options [geomfile(s)]', description = """ Smooth geometry by selecting most frequent microstructure index within given stencil at each location. """, version=scriptID) diff --git a/processing/pre/geom_grainGrowth.py b/processing/pre/geom_grainGrowth.py index f1394cb5f..1afb02715 100755 --- a/processing/pre/geom_grainGrowth.py +++ b/processing/pre/geom_grainGrowth.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,sys,math @@ -49,7 +49,7 @@ parser.set_defaults(d = 1, (options, filenames) = parser.parse_args() -options.immutable = map(int,options.immutable) +options.immutable = list(map(int,options.immutable)) getInterfaceEnergy = lambda A,B: np.float32((A*B != 0)*(A != B)*1.0) # 1.0 if A & B are distinct & nonzero, 0.0 otherwise struc = ndimage.generate_binary_structure(3,1) # 3D von Neumann neighborhood @@ -70,9 +70,9 @@ for name in filenames: table.head_read() info,extra_header = table.head_getGeom() - damask.util.croak(['grid a b c: {}'.format(' x '.join(map(str,info['grid']))), - 'size x y z: {}'.format(' x '.join(map(str,info['size']))), - 'origin x y z: {}'.format(' : '.join(map(str,info['origin']))), + damask.util.croak(['grid a b c: {}'.format(' x '.join(list(map(str,info['grid'])))), + 'size x y z: {}'.format(' x '.join(list(map(str,info['size'])))), + 'origin x y z: {}'.format(' : '.join(list(map(str,info['origin'])))), 'homogenization: {}'.format(info['homogenization']), 'microstructures: {}'.format(info['microstructures']), ]) @@ -102,9 +102,9 @@ for name in filenames: gauss = np.exp(-(X*X + Y*Y + Z*Z)/(2.0*options.d*options.d),dtype=np.float32) \ /np.power(2.0*np.pi*options.d*options.d,(3.0 - np.count_nonzero(info['grid'] == 1))/2.,dtype=np.float32) - gauss[:,:,:grid[2]/2:-1] = gauss[:,:,1:(grid[2]+1)/2] # trying to cope with uneven (odd) grid size - gauss[:,:grid[1]/2:-1,:] = gauss[:,1:(grid[1]+1)/2,:] - gauss[:grid[0]/2:-1,:,:] = gauss[1:(grid[0]+1)/2,:,:] + gauss[:,:,:grid[2]//2:-1] = gauss[:,:,1:(grid[2]+1)//2] # trying to cope with uneven (odd) grid size + gauss[:,:grid[1]//2:-1,:] = gauss[:,1:(grid[1]+1)//2,:] + gauss[:grid[0]//2:-1,:,:] = gauss[1:(grid[0]+1)//2,:,:] gauss = np.fft.rfftn(gauss).astype(np.complex64) for smoothIter in range(options.N): @@ -119,9 +119,9 @@ for name in filenames: microstructure,i,axis=0), j,axis=1), k,axis=2))) # periodically extend interfacial energy array by half a grid size in positive and negative directions - periodic_interfaceEnergy = np.tile(interfaceEnergy,(3,3,3))[grid[0]/2:-grid[0]/2, - grid[1]/2:-grid[1]/2, - grid[2]/2:-grid[2]/2] + periodic_interfaceEnergy = np.tile(interfaceEnergy,(3,3,3))[grid[0]//2:-grid[0]//2, + grid[1]//2:-grid[1]//2, + grid[2]//2:-grid[2]//2] # transform bulk volume (i.e. where interfacial energy remained zero), store index of closest boundary voxel index = ndimage.morphology.distance_transform_edt(periodic_interfaceEnergy == 0., @@ -148,15 +148,15 @@ for name in filenames: ndimage.morphology.binary_dilation(interfaceEnergy > 0., structure = struc, iterations = int(round(options.d*2.))-1),# fat boundary - periodic_bulkEnergy[grid[0]/2:-grid[0]/2, # retain filled energy on fat boundary... - grid[1]/2:-grid[1]/2, - grid[2]/2:-grid[2]/2], # ...and zero everywhere else + periodic_bulkEnergy[grid[0]//2:-grid[0]//2, # retain filled energy on fat boundary... + grid[1]//2:-grid[1]//2, + grid[2]//2:-grid[2]//2], # ...and zero everywhere else 0.)).astype(np.complex64) * gauss).astype(np.float32) - periodic_diffusedEnergy = np.tile(diffusedEnergy,(3,3,3))[grid[0]/2:-grid[0]/2, - grid[1]/2:-grid[1]/2, - grid[2]/2:-grid[2]/2] # periodically extend the smoothed bulk energy + periodic_diffusedEnergy = np.tile(diffusedEnergy,(3,3,3))[grid[0]//2:-grid[0]//2, + grid[1]//2:-grid[1]//2, + grid[2]//2:-grid[2]//2] # periodically extend the smoothed bulk energy # transform voxels close to interface region @@ -164,15 +164,15 @@ for name in filenames: return_distances = False, return_indices = True) # want index of closest bulk grain - periodic_microstructure = np.tile(microstructure,(3,3,3))[grid[0]/2:-grid[0]/2, - grid[1]/2:-grid[1]/2, - grid[2]/2:-grid[2]/2] # periodically extend the microstructure + periodic_microstructure = np.tile(microstructure,(3,3,3))[grid[0]//2:-grid[0]//2, + grid[1]//2:-grid[1]//2, + grid[2]//2:-grid[2]//2] # periodically extend the microstructure microstructure = periodic_microstructure[index[0], index[1], - index[2]].reshape(2*grid)[grid[0]/2:-grid[0]/2, - grid[1]/2:-grid[1]/2, - grid[2]/2:-grid[2]/2] # extent grains into interface region + index[2]].reshape(2*grid)[grid[0]//2:-grid[0]//2, + grid[1]//2:-grid[1]//2, + grid[2]//2:-grid[2]//2] # extent grains into interface region # replace immutable microstructures with closest mutable ones index = ndimage.morphology.distance_transform_edt(np.in1d(microstructure,options.immutable).reshape(grid), @@ -236,3 +236,4 @@ for name in filenames: # --- output finalization -------------------------------------------------------------------------- table.close() + \ No newline at end of file diff --git a/processing/pre/geom_toTable.py b/processing/pre/geom_toTable.py index eb6bdde61..73e4888d1 100755 --- a/processing/pre/geom_toTable.py +++ b/processing/pre/geom_toTable.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import os,sys @@ -48,11 +48,11 @@ for name in filenames: table.head_read() info,extra_header = table.head_getGeom() - damask.util.croak(['grid a b c: %s'%(' x '.join(map(str,info['grid']))), - 'size x y z: %s'%(' x '.join(map(str,info['size']))), - 'origin x y z: %s'%(' : '.join(map(str,info['origin']))), - 'homogenization: %i'%info['homogenization'], - 'microstructures: %i'%info['microstructures'], + damask.util.croak(['grid a b c: {}'.format(' x '.join(list(map(str,info['grid'])))), + 'size x y z: {}'.format(' x '.join(list(map(str,info['size'])))), + 'origin x y z: {}'.format(' : '.join(list(map(str,info['origin'])))), + 'homogenization: {}'.format(info['homogenization']), + 'microstructures: {}'.format(info['microstructures']), ]) errors = [] @@ -86,7 +86,7 @@ for name in filenames: yy = np.tile(np.repeat(y,info['grid'][0] ),info['grid'][2]) zz = np.repeat(z,info['grid'][0]*info['grid'][1]) - table.data = np.squeeze(np.dstack((xx,yy,zz,microstructure))) + table.data = np.squeeze(np.dstack((xx,yy,zz,microstructure)),axis=0) table.data_writeArray() # ------------------------------------------ finalize output --------------------------------------- diff --git a/processing/pre/seeds_check.sh b/processing/pre/seeds_check.sh index 9bc054406..025c9eb90 100755 --- a/processing/pre/seeds_check.sh +++ b/processing/pre/seeds_check.sh @@ -2,9 +2,9 @@ for seeds in "$@" do - vtk_pointcloud $seeds + vtk_pointCloud $seeds - vtk_addPointcloudData $seeds \ + vtk_addPointCloudData $seeds \ --data microstructure,weight \ --inplace \ --vtk ${seeds%.*}.vtp \ diff --git a/processing/pre/seeds_fromDistribution.py b/processing/pre/seeds_fromDistribution.py index 3b9005032..2e8936f27 100755 --- a/processing/pre/seeds_fromDistribution.py +++ b/processing/pre/seeds_fromDistribution.py @@ -1,10 +1,11 @@ -#!/usr/bin/env python2.7 +#!/usr/bin/env python3 # -*- coding: UTF-8 no BOM -*- import threading,time,os,sys,random import numpy as np from optparse import OptionParser -from cStringIO import StringIO +from io import StringIO +import binascii import damask scriptName = os.path.splitext(os.path.basename(__file__))[0] @@ -96,7 +97,7 @@ class myThread (threading.Thread): perturbedGeomVFile = StringIO() perturbedSeedsVFile.reset() perturbedGeomVFile.write(damask.util.execute('geom_fromVoronoiTessellation '+ - ' -g '+' '.join(map(str, options.grid)),streamIn=perturbedSeedsVFile)[0]) + ' -g '+' '.join(list(map(str, options.grid))),streamIn=perturbedSeedsVFile)[0]) perturbedGeomVFile.reset() #--- evaluate current seeds file ---------------------------------------------------------------------- @@ -214,7 +215,7 @@ options = parser.parse_args()[0] damask.util.report(scriptName,options.seedFile) if options.randomSeed is None: - options.randomSeed = int(os.urandom(4).encode('hex'), 16) + options.randomSeed = int(binascii.hexlify(os.urandom(4)),16) damask.util.croak(options.randomSeed) delta = (options.scale/options.grid[0],options.scale/options.grid[1],options.scale/options.grid[2]) baseFile=os.path.splitext(os.path.basename(options.seedFile))[0] @@ -240,17 +241,17 @@ if os.path.isfile(os.path.splitext(options.seedFile)[0]+'.seeds'): for line in initialSeedFile: bestSeedsVFile.write(line) else: bestSeedsVFile.write(damask.util.execute('seeds_fromRandom'+\ - ' -g '+' '.join(map(str, options.grid))+\ + ' -g '+' '.join(list(map(str, options.grid)))+\ ' -r {:d}'.format(options.randomSeed)+\ ' -N '+str(nMicrostructures))[0]) bestSeedsUpdate = time.time() # ----------- tessellate initial seed file to get and evaluate geom file -bestSeedsVFile.reset() +bestSeedsVFile.seek(0) initialGeomVFile = StringIO() initialGeomVFile.write(damask.util.execute('geom_fromVoronoiTessellation '+ - ' -g '+' '.join(map(str, options.grid)),bestSeedsVFile)[0]) -initialGeomVFile.reset() + ' -g '+' '.join(list(map(str, options.grid))),bestSeedsVFile)[0]) +initialGeomVFile.seek(0) initialGeomTable = damask.ASCIItable(initialGeomVFile,None,labeled=False,readonly=True) initialGeomTable.head_read() info,devNull = initialGeomTable.head_getGeom() diff --git a/processing/pre/seeds_fromRandom.py b/processing/pre/seeds_fromRandom.py index 6ec221e25..b17335e03 100755 --- a/processing/pre/seeds_fromRandom.py +++ b/processing/pre/seeds_fromRandom.py @@ -28,7 +28,7 @@ def kdtree_search(cloud, queryPoints): # MAIN # -------------------------------------------------------------------- -parser = OptionParser(option_class=damask.extendableOption, usage='%prog [options]', description = """ +parser = OptionParser(option_class=damask.extendableOption, usage='%prog options', description = """ Distribute given number of points randomly within (a fraction of) the three-dimensional cube [0.0,0.0,0.0]--[1.0,1.0,1.0]. Reports positions with random crystal orientations in seeds file format to STDOUT. diff --git a/python/damask/solver/abaqus.py b/python/damask/solver/abaqus.py index bf8691533..22dbab045 100644 --- a/python/damask/solver/abaqus.py +++ b/python/damask/solver/abaqus.py @@ -2,7 +2,7 @@ from .solver import Solver import damask -import subprocess,re +import subprocess class Abaqus(Solver): @@ -15,14 +15,13 @@ class Abaqus(Solver): def return_run_command(self,model): env=damask.Environment() - shortVersion = re.sub('[\.,-]', '',self.version) try: - cmd='abq'+shortVersion - subprocess.check_output(['abq'+shortVersion,'information=release']) + cmd='abq'+self.version + subprocess.check_output([cmd,'information=release']) except OSError: # link to abqXXX not existing cmd='abaqus' process = subprocess.Popen(['abaqus','information=release'],stdout = subprocess.PIPE,stderr = subprocess.PIPE) - detectedVersion = process.stdout.readlines()[1].split()[1] + detectedVersion = process.stdout.readlines()[1].split()[1].decode('utf-8') if self.version != detectedVersion: - raise Exception('found Abaqus version %s, but requested %s'%(detectedVersion,self.version)) - return '%s -job %s -user %s/src/DAMASK_abaqus interactive'%(cmd,model,env.rootDir()) + raise Exception('found Abaqus version {}, but requested {}'.format(detectedVersion,self.version)) + return '{} -job {} -user {}/src/DAMASK_abaqus interactive'.format(cmd,model,env.rootDir()) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 37913b6df..c50688f1e 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -7,6 +7,7 @@ endif() # The dependency detection in CMake is not functioning for Fortran, # hence we declare the dependencies from top to bottom in the following + add_library(C_ROUTINES OBJECT "C_routines.c") set(OBJECTFILES $) @@ -17,6 +18,10 @@ list(APPEND OBJECTFILES $) add_library(PREC OBJECT "prec.f90") list(APPEND OBJECTFILES $) +add_library(ELEMENT OBJECT "element.f90") +add_dependencies(ELEMENT PREC) +list(APPEND OBJECTFILES $) + add_library(QUIT OBJECT "quit.f90") add_dependencies(QUIT PREC) list(APPEND OBJECTFILES $) @@ -34,7 +39,7 @@ add_dependencies(NUMERICS IO) list(APPEND OBJECTFILES $) add_library(DEBUG OBJECT "debug.f90") -add_dependencies(DEBUG NUMERICS) +add_dependencies(DEBUG IO) list(APPEND OBJECTFILES $) add_library(DAMASK_CONFIG OBJECT "config.f90") @@ -42,7 +47,7 @@ add_dependencies(DAMASK_CONFIG DEBUG) list(APPEND OBJECTFILES $) add_library(HDF5_UTILITIES OBJECT "HDF5_utilities.f90") -add_dependencies(HDF5_UTILITIES DAMASK_CONFIG) +add_dependencies(HDF5_UTILITIES DAMASK_CONFIG NUMERICS) list(APPEND OBJECTFILES $) add_library(RESULTS OBJECT "results.f90") @@ -50,7 +55,7 @@ add_dependencies(RESULTS HDF5_UTILITIES) list(APPEND OBJECTFILES $) add_library(FEsolving OBJECT "FEsolving.f90") -add_dependencies(FEsolving RESULTS) +add_dependencies(FEsolving DEBUG) list(APPEND OBJECTFILES $) add_library(MATH OBJECT "math.f90") @@ -69,17 +74,21 @@ add_library(ROTATIONS OBJECT "rotations.f90") add_dependencies(ROTATIONS LAMBERT QUATERNIONS) list(APPEND OBJECTFILES $) +add_library(MESH_BASE OBJECT "mesh_base.f90") +add_dependencies(MESH_BASE ELEMENT) +list(APPEND OBJECTFILES $) + # SPECTRAL solver and FEM solver use different mesh files if (PROJECT_NAME STREQUAL "DAMASK_spectral") - add_library(MESH OBJECT "mesh.f90") - add_dependencies(MESH ROTATIONS FEsolving) + add_library(MESH OBJECT "mesh_grid.f90") + add_dependencies(MESH MESH_BASE MATH FEsolving) list(APPEND OBJECTFILES $) elseif (PROJECT_NAME STREQUAL "DAMASK_FEM") add_library(FEZoo OBJECT "FEM_zoo.f90") - add_dependencies(FEZoo ROTATIONS FEsolving) + add_dependencies(FEZoo IO) list(APPEND OBJECTFILES $) - add_library(MESH OBJECT "meshFEM.f90") - add_dependencies(MESH FEZoo) + add_library(MESH OBJECT "mesh_FEM.f90") + add_dependencies(MESH FEZoo MESH_BASE MATH FEsolving) list(APPEND OBJECTFILES $) endif() @@ -87,9 +96,9 @@ add_library(MATERIAL OBJECT "material.f90") add_dependencies(MATERIAL MESH DAMASK_CONFIG) list(APPEND OBJECTFILES $) -add_library(DAMASK_HELPERS OBJECT "lattice.f90") -add_dependencies(DAMASK_HELPERS MATERIAL) -list(APPEND OBJECTFILES $) +add_library(LATTICE OBJECT "lattice.f90") +add_dependencies(LATTICE MATERIAL) +list(APPEND OBJECTFILES $) # For each modular section add_library (PLASTIC OBJECT @@ -100,14 +109,14 @@ add_library (PLASTIC OBJECT "plastic_kinematichardening.f90" "plastic_nonlocal.f90" "plastic_none.f90") -add_dependencies(PLASTIC DAMASK_HELPERS) +add_dependencies(PLASTIC LATTICE RESULTS) list(APPEND OBJECTFILES $) add_library (KINEMATICS OBJECT "kinematics_cleavage_opening.f90" "kinematics_slipplane_opening.f90" "kinematics_thermal_expansion.f90") -add_dependencies(KINEMATICS DAMASK_HELPERS) +add_dependencies(KINEMATICS LATTICE RESULTS) list(APPEND OBJECTFILES $) add_library (SOURCE OBJECT @@ -117,7 +126,7 @@ add_library (SOURCE OBJECT "source_damage_isoDuctile.f90" "source_damage_anisoBrittle.f90" "source_damage_anisoDuctile.f90") -add_dependencies(SOURCE DAMASK_HELPERS) +add_dependencies(SOURCE LATTICE RESULTS) list(APPEND OBJECTFILES $) add_library(CONSTITUTIVE OBJECT "constitutive.f90") diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index b0f1641e6..ba18f7d52 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -140,8 +140,7 @@ subroutine CPFEM_init restartRead, & modelName use mesh, only: & - mesh_NcpElems, & - mesh_maxNips + theMesh use material, only: & material_phase, & homogState, & @@ -168,10 +167,9 @@ subroutine CPFEM_init flush(6) endif mainProcess - ! initialize stress and jacobian to zero - allocate(CPFEM_cs(6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_cs = 0.0_pReal - allocate(CPFEM_dcsdE(6,6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dcsdE = 0.0_pReal - allocate(CPFEM_dcsdE_knownGood(6,6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dcsdE_knownGood = 0.0_pReal + allocate(CPFEM_cs( 6,theMesh%elem%nIPs,theMesh%Nelems), source= 0.0_pReal) + allocate(CPFEM_dcsdE( 6,6,theMesh%elem%nIPs,theMesh%Nelems), source= 0.0_pReal) + allocate(CPFEM_dcsdE_knownGood(6,6,theMesh%elem%nIPs,theMesh%Nelems), source= 0.0_pReal) ! *** restore the last converged values of each essential variable from the binary file if (restartRead) then @@ -289,8 +287,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt math_6toSym33 use mesh, only: & mesh_FEasCP, & - mesh_NcpElems, & - mesh_maxNips, & + theMesh, & mesh_element use material, only: & microstructure_elemhomo, & @@ -401,7 +398,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt enddo; enddo if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) then write(6,'(a)') '<< CPFEM >> aging states' - if (debug_e <= mesh_NcpElems .and. debug_i <= mesh_maxNips) then + if (debug_e <= theMesh%Nelems .and. debug_i <= theMesh%elem%nIPs) then write(6,'(a,1x,i8,1x,i2,1x,i4,/,(12x,6(e20.8,1x)),/)') & '<< CPFEM >> aged state of elFE ip grain',debug_e, debug_i, 1, & plasticState(phaseAt(1,debug_i,debug_e))%state(:,phasememberAt(1,debug_i,debug_e)) diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 91cc08296..b2aa2f598 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -95,8 +95,6 @@ subroutine CPFEM_init use prec, only: & pInt, pReal, pLongInt use IO, only: & - IO_read_realFile,& - IO_read_intFile, & IO_timeStamp, & IO_error use numerics, only: & diff --git a/src/C_routines.c b/src/C_routines.c index e3891765a..3dccb7644 100644 --- a/src/C_routines.c +++ b/src/C_routines.c @@ -6,9 +6,11 @@ #include #include #include +#include /* http://stackoverflow.com/questions/30279228/is-there-an-alternative-to-getcwd-in-fortran-2003-2008 */ + int isdirectory_c(const char *dir){ struct stat statbuf; if(stat(dir, &statbuf) != 0) /* error */ @@ -44,3 +46,11 @@ void gethostname_c(char hostname[], int *stat){ int chdir_c(const char *dir){ return chdir(dir); } + +void signalusr1_c(void (*handler)(int)){ + signal(SIGUSR1, handler); +} + +void signalusr2_c(void (*handler)(int)){ + signal(SIGUSR2, handler); +} \ No newline at end of file diff --git a/src/DAMASK_abaqus.f b/src/DAMASK_abaqus.f index 9072de95d..8cd3a4930 100644 --- a/src/DAMASK_abaqus.f +++ b/src/DAMASK_abaqus.f @@ -30,6 +30,11 @@ contains !> @brief reports and sets working directory !-------------------------------------------------------------------------------------------------- subroutine DAMASK_interface_init +#if __INTEL_COMPILER >= 1800 + use, intrinsic :: iso_fortran_env, only: & + compiler_version, & + compiler_options +#endif use ifport, only: & CHDIR @@ -40,16 +45,25 @@ subroutine DAMASK_interface_init character(len=256) :: wd call date_and_time(values = dateAndTime) - write(6,'(/,a)') ' <<<+- DAMASK_abaqus_std -+>>>' - write(6,'(/,a)') ' Roters et al., Computational Materials Science, 2018' - write(6,'(/,a)') ' Version: '//DAMASKVERSION - write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',& - dateAndTime(2),'/',& - dateAndTime(1) - write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',& - dateAndTime(6),':',& - dateAndTime(7) - write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' + write(6,'(/,a)') ' <<<+- DAMASK_abaqus -+>>>' + write(6,'(/,a)') ' Roters et al., Computational Materials Science 158, 2018, 420-478' + write(6,'(a,/)') ' https://doi.org/10.1016/j.commatsci.2018.04.030' + + write(6,'(a,/)') ' Version: '//DAMASKVERSION + +! https://github.com/jeffhammond/HPCInfo/blob/master/docs/Preprocessor-Macros.md +#if __INTEL_COMPILER >= 1800 + write(6,*) 'Compiled with: ', compiler_version() + write(6,*) 'Compiler options: ', compiler_options() +#else + write(6,'(a,i4.4,a,i8.8)') ' Compiled with Intel fortran version :', __INTEL_COMPILER,& + ', build date :', __INTEL_COMPILER_BUILD_DATE +#endif + + write(6,*) 'Compiled on ', __DATE__,' at ',__TIME__ + + write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',dateAndTime(2),'/', dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':', dateAndTime(6),':', dateAndTime(7) call getoutdir(wd, lenOutDir) ierr = CHDIR(wd) diff --git a/src/DAMASK_interface.f90 b/src/DAMASK_interface.f90 index a2b4f53f2..630b5b921 100644 --- a/src/DAMASK_interface.f90 +++ b/src/DAMASK_interface.f90 @@ -12,9 +12,9 @@ module DAMASK_interface use prec, only: & pInt - implicit none private + logical, public, protected :: SIGUSR1,SIGUSR2 integer(pInt), public, protected :: & interface_restartInc = 0_pInt !< Increment at which calculation starts character(len=1024), public, protected :: & @@ -42,6 +42,8 @@ contains subroutine DAMASK_interface_init() use, intrinsic :: & iso_fortran_env + use :: & + iso_c_binding #include #if defined(__GFORTRAN__) && __GNUC__ < 5 =================================================================================================== @@ -81,6 +83,8 @@ subroutine DAMASK_interface_init() use PETScSys use system_routines, only: & + signalusr1_C, & + signalusr2_C, & getHostName, & getCWD @@ -139,16 +143,27 @@ subroutine DAMASK_interface_init() call date_and_time(values = dateAndTime) write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' - write(6,'(a,/)') ' Roters et al., Computational Materials Science, 2018' - write(6,'(/,a)') ' Version: '//DAMASKVERSION - write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',& - dateAndTime(2),'/',& - dateAndTime(1) - write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',& - dateAndTime(6),':',& - dateAndTime(7) - write(6,'(/,a,i4.1)') ' MPI processes: ',worldsize -#include "compilation_info.f90" + write(6,'(/,a)') ' Roters et al., Computational Materials Science 158, 2018, 420-478' + write(6,'(a,/)') ' https://doi.org/10.1016/j.commatsci.2018.04.030' + + write(6,'(a,/)') ' Version: '//DAMASKVERSION + +! https://github.com/jeffhammond/HPCInfo/blob/master/docs/Preprocessor-Macros.md +#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 + write(6,*) 'Compiled with: ', compiler_version() + write(6,*) 'Compiler options: ', compiler_options() +#elif defined(__INTEL_COMPILER) + write(6,'(a,i4.4,a,i8.8)') ' Compiled with Intel fortran version :', __INTEL_COMPILER,& + ', build date :', __INTEL_COMPILER_BUILD_DATE +#elif defined(__PGI) + write(6,'(a,i4.4,a,i8.8)') ' Compiled with PGI fortran version :', __PGIC__,& + '.', __PGIC_MINOR__ +#endif + + write(6,*) 'Compiled on ', __DATE__,' at ',__TIME__ + + write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',dateAndTime(2),'/', dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':', dateAndTime(6),':', dateAndTime(7) call get_command(commandLine) chunkPos = IIO_stringPos(commandLine) @@ -215,9 +230,11 @@ subroutine DAMASK_interface_init() call get_environment_variable('USER',userName) ! ToDo: https://stackoverflow.com/questions/8953424/how-to-get-the-username-in-c-c-in-linux - write(6,'(a,a)') ' Host name: ', trim(getHostName()) - write(6,'(a,a)') ' User name: ', trim(userName) - write(6,'(a,a)') ' Command line call: ', trim(commandLine) + write(6,'(/,a,i4.1)') ' MPI processes: ',worldsize + write(6,'(a,a)') ' Host name: ', trim(getHostName()) + write(6,'(a,a)') ' User name: ', trim(userName) + + write(6,'(/a,a)') ' Command line call: ', trim(commandLine) if (len(trim(workingDirArg)) > 0) & write(6,'(a,a)') ' Working dir argument: ', trim(workingDirArg) write(6,'(a,a)') ' Geometry argument: ', trim(geometryArg) @@ -229,6 +246,12 @@ subroutine DAMASK_interface_init() if (interface_restartInc > 0_pInt) & write(6,'(a,i6.6)') ' Restart from increment: ', interface_restartInc + call signalusr1_c(c_funloc(setSIGUSR1)) + call signalusr2_c(c_funloc(setSIGUSR2)) + SIGUSR1 = .false. + SIGUSR2 = .false. + + end subroutine DAMASK_interface_init @@ -412,6 +435,35 @@ character(len=1024) function makeRelativePath(a,b) end function makeRelativePath +!-------------------------------------------------------------------------------------------------- +!> @brief sets global variable SIGUSR1 to .true. if program receives SIGUSR1 +!-------------------------------------------------------------------------------------------------- +subroutine setSIGUSR1(signal) bind(C) + use :: iso_c_binding + + implicit none + integer(C_INT), value :: signal + SIGUSR1 = .true. + + write(6,*) 'received signal ',signal, 'set SIGUSR1' + +end subroutine setSIGUSR1 + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets global variable SIGUSR2 to .true. if program receives SIGUSR2 +!-------------------------------------------------------------------------------------------------- +subroutine setSIGUSR2(signal) bind(C) + use :: iso_c_binding + + implicit none + integer(C_INT), value :: signal + SIGUSR2 = .true. + + write(6,*) 'received signal ',signal, 'set SIGUSR2' + +end subroutine setSIGUSR2 + !-------------------------------------------------------------------------------------------------- !> @brief taken from IO, check IO_stringValue for documentation @@ -469,7 +521,6 @@ pure function IIO_stringPos(string) do while (verify(string(right+1:),SEP)>0) left = right + verify(string(right+1:),SEP) right = left + scan(string(left:),SEP) - 2 - if ( string(left:left) == '#' ) exit IIO_stringPos = [IIO_stringPos,int(left, pInt), int(right, pInt)] IIO_stringPos(1) = IIO_stringPos(1)+1_pInt enddo diff --git a/src/DAMASK_marc.f90 b/src/DAMASK_marc.f90 index 0c7d1adeb..892b2cbc4 100644 --- a/src/DAMASK_marc.f90 +++ b/src/DAMASK_marc.f90 @@ -43,6 +43,11 @@ contains !> @brief reports and sets working directory !-------------------------------------------------------------------------------------------------- subroutine DAMASK_interface_init +#if __INTEL_COMPILER >= 1800 + use, intrinsic :: iso_fortran_env, only: & + compiler_version, & + compiler_options +#endif use ifport, only: & CHDIR @@ -53,17 +58,26 @@ subroutine DAMASK_interface_init character(len=1024) :: wd call date_and_time(values = dateAndTime) - write(6,'(/,a)') ' <<<+- DAMASK_Marc -+>>>' - write(6,'(/,a)') ' Roters et al., Computational Materials Science, 2018' - write(6,'(/,a)') ' Version: '//DAMASKVERSION - write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',& - dateAndTime(2),'/',& - dateAndTime(1) - write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',& - dateAndTime(6),':',& - dateAndTime(7) - write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' -#include "compilation_info.f90" + write(6,'(/,a)') ' <<<+- DAMASK_abaqus -+>>>' + write(6,'(/,a)') ' Roters et al., Computational Materials Science 158, 2018, 420-478' + write(6,'(a,/)') ' https://doi.org/10.1016/j.commatsci.2018.04.030' + + write(6,'(a,/)') ' Version: '//DAMASKVERSION + +! https://github.com/jeffhammond/HPCInfo/blob/master/docs/Preprocessor-Macros.md +#if __INTEL_COMPILER >= 1800 + write(6,*) 'Compiled with: ', compiler_version() + write(6,*) 'Compiler options: ', compiler_options() +#else + write(6,'(a,i4.4,a,i8.8)') ' Compiled with Intel fortran version :', __INTEL_COMPILER,& + ', build date :', __INTEL_COMPILER_BUILD_DATE +#endif + + write(6,*) 'Compiled on ', __DATE__,' at ',__TIME__ + + write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',dateAndTime(2),'/', dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':', dateAndTime(6),':', dateAndTime(7) + inquire(5, name=wd) ! determine inputputfile wd = wd(1:scan(wd,'/',back=.true.)) ierr = CHDIR(wd) @@ -134,6 +148,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & debug_info, & debug_reset use mesh, only: & + theMesh, & mesh_FEasCP, & mesh_element, & mesh_node0, & @@ -141,8 +156,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & mesh_Ncellnodes, & mesh_cellnode, & mesh_build_cellnodes, & - mesh_build_ipCoordinates, & - FE_Nnodes + mesh_build_ipCoordinates use CPFEM, only: & CPFEM_general, & CPFEM_init_done, & @@ -314,7 +328,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & computationMode = ior(computationMode,CPFEM_BACKUPJACOBIAN) ! collect and backup Jacobian after convergence lastIncConverged = .false. ! reset flag endif - do node = 1,FE_Nnodes(mesh_element(2,cp_en)) + do node = 1,theMesh%elem%nNodes CPnodeID = mesh_element(4_pInt+node,cp_en) mesh_node(1:ndeg,CPnodeID) = mesh_node0(1:ndeg,CPnodeID) + numerics_unitlength * dispt(1:ndeg,node) enddo diff --git a/src/FEM_utilities.f90 b/src/FEM_utilities.f90 index 1db950e63..2087054bd 100644 --- a/src/FEM_utilities.f90 +++ b/src/FEM_utilities.f90 @@ -162,7 +162,6 @@ subroutine utilities_init() character(len=1024) :: petsc_optionsPhysics integer(pInt) :: dimPlex - integer(pInt) :: headerID = 205_pInt PetscInt, allocatable :: nEntities(:), nOutputCells(:), nOutputNodes(:) PetscInt :: dim PetscErrorCode :: ierr @@ -213,13 +212,6 @@ subroutine utilities_init() nOutputCells(worldrank+1) = count(material_homog > 0_pInt) call MPI_Allreduce(MPI_IN_PLACE,nOutputNodes,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) call MPI_Allreduce(MPI_IN_PLACE,nOutputCells,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) - if (worldrank == 0_pInt) then - open(unit=headerID, file=trim(getSolverJobName())//'.header', & - form='FORMATTED', status='REPLACE') - write(headerID, '(a,i0)') 'dimension : ', dimPlex - write(headerID, '(a,i0)') 'number of nodes : ', sum(nOutputNodes) - write(headerID, '(a,i0)') 'number of cells : ', sum(nOutputCells) - endif end subroutine utilities_init @@ -503,7 +495,6 @@ subroutine utilities_indexActiveSet(field,section,x_local,f_local,localIS,global CHKERRQ(ierr) call ISDestroy(dummyIS,ierr); CHKERRQ(ierr) endif - deallocate(localIndices) end subroutine utilities_indexActiveSet diff --git a/src/FEM_zoo.f90 b/src/FEM_zoo.f90 index 67c518c47..6abdfe883 100644 --- a/src/FEM_zoo.f90 +++ b/src/FEM_zoo.f90 @@ -9,11 +9,11 @@ module FEM_Zoo private integer(pInt), parameter, public:: & maxOrder = 5 !< current max interpolation set at cubic (intended to be arbitrary) - real(pReal), dimension(2,3), private, protected :: & + real(pReal), dimension(2,3), private, parameter :: & triangle = reshape([-1.0_pReal, -1.0_pReal, & 1.0_pReal, -1.0_pReal, & -1.0_pReal, 1.0_pReal], shape=[2,3]) - real(pReal), dimension(3,4), private, protected :: & + real(pReal), dimension(3,4), private, parameter :: & tetrahedron = 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, & diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 2a05f101c..0582318ce 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -18,7 +18,8 @@ module HDF5_utilities HDF5_ERR_TYPE = 4_pInt !< kind of the integer return in the HDF5 library !-------------------------------------------------------------------------------------------------- -!> @brief reads pInt or pReal data of defined shape from file +!> @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 @@ -40,7 +41,8 @@ module HDF5_utilities end interface HDF5_read !-------------------------------------------------------------------------------------------------- -!> @brief writes pInt or pReal data of defined shape to file +!> @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 @@ -445,1356 +447,587 @@ subroutine HDF5_setLink(loc_id,target_name,link_name) end subroutine HDF5_setLink + !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 1 dimensions +!> @brief read dataset of type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - real(pReal), intent(inout), dimension(:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(1) :: myStart - -!------------------------------------------------------------------------------------------------- -! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return - -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(1) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,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='HDF5_read_pReal1: MPI_allreduce') - endif; endif -#endif - myStart = int([sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:0),sum(readSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), 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') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sclose_f/memspace_id') - -end subroutine HDF5_read_pReal1 - - -!-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 2 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize - - 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr + globalShape !< shape of the dataset (all processes) integer(HDF5_ERR_TYPE) :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(2) :: myStart -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(2) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pReal2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,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='HDF5_read_pReal2: MPI_allreduce') - endif; endif -#endif - myStart = int([0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:1),sum(readSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + 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_pReal1 + !-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sclose_f/memspace_id') +!> @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(HDF5_ERR_TYPE) :: 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_pReal2 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 3 dimensions +!> @brief read dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - real(pReal), intent(inout), dimension(:,:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(3) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(3) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pReal3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,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='HDF5_read_pReal3: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:2),sum(readSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& +!--------------------------------------------------------------------------------------------------- +! 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_pReal3: h5dread_f') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sclose_f/memspace_id') + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal3 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 4 dimensions +!> @brief read dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - real(pReal), intent(inout), dimension(:,:,:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(4) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(4) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pReal4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,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='HDF5_read_pReal4: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:3),sum(readSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sclose_f/memspace_id') + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal4 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 5 dimensions +!> @brief read dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(5) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(5) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pReal5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,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='HDF5_read_pReal5: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:4),sum(readSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sclose_f/memspace_id') + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal5 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 6 dimensions +!> @brief read dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(6) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(6) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pReal6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,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='HDF5_read_pReal6: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:5),sum(readSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sclose_f/memspace_id') + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal6 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pReal with 7 dimensions +!> @brief read dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(7) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(7) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pReal7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,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='HDF5_read_pReal7: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:6),sum(readSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5pset_all_coll_metadata_ops_f') -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,HSIZE_T), hdferr,& + 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sclose_f/memspace_id') + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pReal7 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 1 dimensions +!> @brief read dataset of type pInt with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - integer(pInt), intent(inout), dimension(:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(1) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!-------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(1) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt1: MPI_allreduce') - endif; endif -#endif - - myStart = int([sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:0),sum(readSize)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5sclose_f/memspace_id') - + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + end subroutine HDF5_read_pInt1 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 2 dimensions +!> @brief read dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - integer(pInt), intent(inout), dimension(:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(2) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!-------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(2) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt2: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:1),sum(readSize)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + 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') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5sclose_f/memspace_id') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt2 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 3 dimensions +!> @brief read dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - integer(pInt), intent(inout), dimension(:,:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(3) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!-------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(3) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt3: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:2),sum(readSize)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + 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') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5sclose_f/memspace_id') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt3 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 4 dimensions +!> @brief read dataset of type pInt withh 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(4) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!-------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(4) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt4: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:3),sum(readSize)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + 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') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5sclose_f/memspace_id') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt4 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 5 dimensions +!> @brief read dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(5) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!-------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(5) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt5: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:4),sum(readSize)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + 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') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5sclose_f/memspace_id') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt5 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 6 dimensions +!> @brief read dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(6) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!-------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(6) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt6: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:5),sum(readSize)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + 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') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5sclose_f/memspace_id') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt6 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for reading dataset of type pInt with 7 dimensions +!> @brief read dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + 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(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - readSize !< contribution of all processes - integer :: ierr - integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(7) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) + integer(HDF5_ERR_TYPE) :: hdferr -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +!--------------------------------------------------------------------------------------------------- +! 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 -!-------------------------------------------------------------------------------------------------- -! creating a property list for data access properties - call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) -!-------------------------------------------------------------------------------------------------- - allocate(readSize(worldsize), source = 0_pInt) - readSize(worldrank+1) = localShape(7) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_read_pInt7: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,0,0,0,sum(readSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:6),sum(readSize)] - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt{}: h5screate_simple_f/memspace_id') -!-------------------------------------------------------------------------------------------------- -! set I/O mode for read operations to collective - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5pset_all_coll_metadata_ops_f') - -!-------------------------------------------------------------------------------------------------- -! open the dataset in the file - call h5dopen_f(loc_id,datasetName,dset_id,hdferr,dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! get the space_id of dataset in the file - call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! read - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,HSIZE_T), hdferr, & + 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') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5sclose_f/memspace_id') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_pInt7 + !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 1 dimensions +!> @brief write dataset of type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:) :: dataset @@ -1803,89 +1036,38 @@ subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(1) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(1) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_write_pReal1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_write_pReal1: MPI_allreduce') - endif; endif -#endif - - myStart = int([sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:0),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal1 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 2 dimensions +!> @brief write dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:) :: dataset @@ -1894,89 +1076,38 @@ subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(2) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(2) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_write_pReal2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_write_pReal2: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:1),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal2 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 3 dimensions +!> @brief write dataset of type pReal with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:) :: dataset @@ -1985,89 +1116,38 @@ subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(3) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(3) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_write_pReal3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_write_pReal3: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:2),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal3 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 4 dimensions +!> @brief write dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:) :: dataset @@ -2076,89 +1156,39 @@ subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(4) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(4) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_write_pReal4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_write_pReal4: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:3),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal4 !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 5 dimensions +!> @brief write dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset @@ -2167,89 +1197,38 @@ subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(5) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(5) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_write_pReal5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_write_pReal5: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:4),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal5 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 6 dimensions +!> @brief write dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset @@ -2258,89 +1237,38 @@ subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(6) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(6) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_write_pReal6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_write_pReal6: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:5),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal6 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pReal with 7 dimensions +!> @brief write dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset @@ -2349,91 +1277,39 @@ subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(7) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(7) - -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_write_pReal7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_write_pReal7: MPI_allreduce') - endif; endif -#endif - - myStart = int([0,0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:6),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_DOUBLE, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pReal7 - - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 1 dimensions +!> @brief write dataset of type pInt with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:) :: dataset @@ -2442,87 +1318,38 @@ subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(1) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(1) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt1: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_read_pInt1: MPI_allreduce') - endif; endif -#endif - myStart = int([sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:0),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt1 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 2 dimensions +!> @brief write dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:) :: dataset @@ -2531,87 +1358,38 @@ subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(2) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(2) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt2: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_read_pInt2: MPI_allreduce') - endif; endif -#endif - myStart = int([0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:1),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt2 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 3 dimensions +!> @brief write dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:) :: dataset @@ -2620,87 +1398,38 @@ subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(3) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(3) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt3: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_read_pInt3: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:2),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt3 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 4 dimensions +!> @brief write dataset of type pInt with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset @@ -2709,87 +1438,38 @@ subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(4) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(4) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt4: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_read_pInt4: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:3),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt4 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 5 dimensions +!> @brief write dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset @@ -2798,87 +1478,38 @@ subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(5) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(5) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt5: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_read_pInt5: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:4),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt5 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 6 dimensions +!> @brief write dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset @@ -2887,87 +1518,38 @@ subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(6) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(6) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt6: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_read_pInt6: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:5),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt6 - !-------------------------------------------------------------------------------------------------- -!> @brief subroutine for writing dataset of type pInt with 7 dimensions +!> @brief write dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) - use numerics, only: & - worldrank, & - worldsize implicit none integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset @@ -2976,93 +1558,216 @@ subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) logical, intent(in), optional :: parallel - integer(pInt), dimension(:), allocatable :: & - globalShape, & !< shape of the dataset (all processes) - localShape, & !< shape of the dataset (this process) - outputSize !< contribution of all processes - integer :: ierr integer(HDF5_ERR_TYPE) :: hdferr integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(7) :: myStart + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + localShape, & !< shape of the dataset (this process) + globalShape !< shape of the dataset (all processes) -!------------------------------------------------------------------------------------------------- +!--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = shape(dataset) - if (any(localShape(1:size(localShape)) == 0)) return + localShape = int(shape(dataset),HSIZE_T) + if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -!------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + 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 -!-------------------------------------------------------------------------------------------------- - allocate(outputSize(worldsize), source = 0_pInt) - outputSize(worldrank+1) = localShape(7) -#ifdef PETSc - if (present(parallel)) then; 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='HDF5_read_pInt7: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,outputSize,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='HDF5_read_pInt7: MPI_allreduce') - endif; endif -#endif - myStart = int([0,0,0,0,0,0,sum(outputSize(1:worldrank))],HSIZE_T) - globalShape = [localShape(1:6),sum(outputSize)] - - -!-------------------------------------------------------------------------------------------------- -! create dataspace in memory (local shape) - call h5screate_simple_f(size(localShape), int(localShape,HSIZE_T), memspace_id, hdferr, & - int(localShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dopen_f') - -!-------------------------------------------------------------------------------------------------- -! create dataspace in file (global shape) - call h5screate_simple_f(size(globalShape), int(globalShape,HSIZE_T), filespace_id, hdferr, & - int(globalShape,HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dget_space_f') - -!-------------------------------------------------------------------------------------------------- -! create dataset - call h5dcreate_f(loc_id, trim(datasetName), H5T_NATIVE_INTEGER, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: 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, int(localShape,HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! write 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') -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: plist_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dclose_f') - call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/filespace_id') - call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5sclose_f/memspace_id') + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_pInt7 +!-------------------------------------------------------------------------------------------------- +!> @brief initialize HDF5 handles, determines global shape and start for parallel read +!-------------------------------------------------------------------------------------------------- +subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, globalShape, & + loc_id,localShape,datasetName,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(HSIZE_T), intent(in), dimension(:) :: & + localShape + integer(HSIZE_T), intent(out), dimension(size(localShape,1)):: & + myStart, & + globalShape !< shape of the dataset (all processes) + integer(HID_T), intent(out) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + + integer(pInt), dimension(worldsize) :: & + readSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties (is collective for MPI) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pcreate_f') + +!-------------------------------------------------------------------------------------------------- + readSize = 0_pInt + readSize(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_read: h5pset_dxpl_mpio_f') + call MPI_allreduce(MPI_IN_PLACE,readSize,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_read: MPI_allreduce') + endif +#endif + myStart = int(0,HSIZE_T) + myStart(ubound(myStart)) = int(sum(readSize(1:worldrank)),HSIZE_T) + globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(readSize),HSIZE_T)] + +!-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) + call h5screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5screate_simple_f/memspace_id') + +!-------------------------------------------------------------------------------------------------- +! creating a property list for IO and set it to collective + call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pcreate_f') + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pset_all_coll_metadata_ops_f') + +!-------------------------------------------------------------------------------------------------- +! open the dataset in the file and get the space ID + call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5dopen_f') + call h5dget_space_f(dset_id, filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5dget_space_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) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5sselect_hyperslab_f') + +end subroutine initialize_read + + +!-------------------------------------------------------------------------------------------------- +!> @brief closes HDF5 handles +!-------------------------------------------------------------------------------------------------- +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(HDF5_ERR_TYPE) :: hdferr + + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: plist_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) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: h5sclose_f/memspace_id') + +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) + 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 + integer(HSIZE_T), intent(in), dimension(:) :: & + localShape + integer(HSIZE_T), intent(out), dimension(size(localShape,1)):: & + myStart, & + globalShape !< shape of the dataset (all processes) + integer(HID_T), intent(out) :: dset_id, filespace_id, memspace_id, plist_id + + integer(pInt), dimension(worldsize) :: & + writeSize !< contribution of all processes + integer :: ierr + integer(HDF5_ERR_TYPE) :: hdferr + +!------------------------------------------------------------------------------------------------- +! creating a property list for transfer properties + 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') + 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)] + +!-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape) and in file (global shape) + call h5screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) + 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) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dget_space_f') + +!-------------------------------------------------------------------------------------------------- +! create dataset + 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) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5sselect_hyperslab_f') + +end subroutine initialize_write + + +!-------------------------------------------------------------------------------------------------- +!> @brief closes HDF5 handles +!-------------------------------------------------------------------------------------------------- +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(HDF5_ERR_TYPE) :: hdferr + + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: plist_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: h5dclose_f') + call h5sclose_f(filespace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: h5sclose_f/filespace_id') + call h5sclose_f(memspace_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: h5sclose_f/memspace_id') + +end subroutine finalize_write + end module HDF5_Utilities - - - - - - - - - - - - - - - diff --git a/src/IO.f90 b/src/IO.f90 index c8fe26735..3d330a2df 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -27,28 +27,17 @@ module IO IO_open_file_stat, & IO_open_jobFile_stat, & IO_open_file, & - IO_open_jobFile, & IO_write_jobFile, & IO_write_jobRealFile, & - IO_write_jobIntFile, & IO_read_realFile, & IO_read_intFile, & IO_isBlank, & IO_getTag, & IO_stringPos, & IO_stringValue, & - IO_fixedStringValue ,& IO_floatValue, & - IO_fixedNoEFloatValue, & IO_intValue, & - IO_fixedIntValue, & IO_lc, & - IO_skipChunks, & - IO_extractValue, & - IO_countDataLines, & - IO_countNumericalDataLines, & - IO_countContinuousIntValues, & - IO_continuousIntValues, & IO_error, & IO_warning, & IO_intOut, & @@ -56,39 +45,35 @@ module IO #if defined(Marc4DAMASK) || defined(Abaqus) public :: & IO_open_inputFile, & - IO_open_logFile + IO_open_logFile, & + IO_countContinuousIntValues, & + IO_continuousIntValues, & +#if defined(Abaqus) + IO_extractValue, & + IO_countDataLines +#elif defined(Marc4DAMASK) + IO_skipChunks, & + IO_fixedNoEFloatValue, & + IO_fixedIntValue, & + IO_countNumericalDataLines #endif -#ifdef Abaqus - public :: & - IO_abaqus_hasNoPart #endif private :: & - IO_fixedFloatValue, & IO_verifyFloatValue, & IO_verifyIntValue -#ifdef Abaqus - private :: & - abaqus_assembleInputFile -#endif contains !-------------------------------------------------------------------------------------------------- -!> @brief only outputs revision number +!> @brief does nothing. +! ToDo: needed? !-------------------------------------------------------------------------------------------------- subroutine IO_init -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif implicit none write(6,'(/,a)') ' <<<+- IO init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" end subroutine IO_init @@ -99,7 +84,7 @@ end subroutine IO_init !> @details unstable and buggy !-------------------------------------------------------------------------------------------------- recursive function IO_read(fileUnit,reset) result(line) - +!ToDo: remove recursion once material.config handling is done fully via config module implicit none integer(pInt), intent(in) :: fileUnit !< file unit logical, intent(in), optional :: reset @@ -167,6 +152,7 @@ recursive function IO_read(fileUnit,reset) result(line) end function IO_read + !-------------------------------------------------------------------------------------------------- !> @brief recursively reads a text file. !! Recursion is triggered by "{path/to/inputfile}" in a line @@ -290,7 +276,7 @@ end subroutine IO_open_file !> @details Like IO_open_file, but error is handled via return value and not via call to IO_error !-------------------------------------------------------------------------------------------------- logical function IO_open_file_stat(fileUnit,path) - +!ToDo: DEPRECATED once material.config handling is done fully via config module implicit none integer(pInt), intent(in) :: fileUnit !< file unit character(len=*), intent(in) :: path !< relative path from working directory @@ -304,30 +290,6 @@ logical function IO_open_file_stat(fileUnit,path) end function IO_open_file_stat -!-------------------------------------------------------------------------------------------------- -!> @brief opens existing file for reading to given unit. File is named after solver job name -!! plus given extension and located in current working directory -!> @details like IO_open_jobFile_stat, but error is handled via call to IO_error and not via return -!! value -!-------------------------------------------------------------------------------------------------- -subroutine IO_open_jobFile(fileUnit,ext) - use DAMASK_interface, only: & - getSolverJobName - - implicit none - integer(pInt), intent(in) :: fileUnit !< file unit - character(len=*), intent(in) :: ext !< extension of file - - integer(pInt) :: myStat - character(len=1024) :: path - - path = trim(getSolverJobName())//'.'//ext - open(fileUnit,status='old',iostat=myStat,file=path,action='read',position='rewind') - if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) - -end subroutine IO_open_jobFile - - !-------------------------------------------------------------------------------------------------- !> @brief opens existing file for reading to given unit. File is named after solver job name !! plus given extension and located in current working directory @@ -368,7 +330,7 @@ subroutine IO_open_inputFile(fileUnit,modelName) integer(pInt) :: myStat character(len=1024) :: path -#ifdef Abaqus +#if defined(Abaqus) integer(pInt) :: fileType fileType = 1_pInt ! assume .pes @@ -386,8 +348,60 @@ subroutine IO_open_inputFile(fileUnit,modelName) if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) if (.not.abaqus_assembleInputFile(fileUnit,fileUnit+1_pInt)) call IO_error(103_pInt) ! strip comments and concatenate any "include"s close(fileUnit+1_pInt) -#endif -#ifdef Marc4DAMASK + + contains + +!-------------------------------------------------------------------------------------------------- +!> @brief create a new input file for abaqus simulations by removing all comment lines and +!> including "include"s +!-------------------------------------------------------------------------------------------------- +recursive function abaqus_assembleInputFile(unit1,unit2) result(createSuccess) + + implicit none + integer(pInt), intent(in) :: unit1, & + unit2 + + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: line,fname + logical :: createSuccess,fexist + + + do + read(unit2,'(A65536)',END=220) line + chunkPos = IO_stringPos(line) + + if (IO_lc(IO_StringValue(line,chunkPos,1_pInt))=='*include') then + fname = trim(line(9+scan(line(9:),'='):)) + inquire(file=fname, exist=fexist) + if (.not.(fexist)) then + !$OMP CRITICAL (write2out) + write(6,*)'ERROR: file does not exist error in abaqus_assembleInputFile' + write(6,*)'filename: ', trim(fname) + !$OMP END CRITICAL (write2out) + createSuccess = .false. + return + endif + open(unit2+1,err=200,status='old',file=fname) + if (abaqus_assembleInputFile(unit1,unit2+1_pInt)) then + createSuccess=.true. + close(unit2+1) + else + createSuccess=.false. + return + endif + else if (line(1:2) /= '**' .OR. line(1:8)=='**damask') then + write(unit1,'(A)') trim(line) + endif + enddo + +220 createSuccess = .true. + return + +200 createSuccess =.false. + +end function abaqus_assembleInputFile +#elif defined(Marc4DAMASK) path = trim(modelName)//inputFileExtension open(fileUnit,status='old',iostat=myStat,file=path) if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) @@ -471,36 +485,6 @@ subroutine IO_write_jobRealFile(fileUnit,ext,recMultiplier) end subroutine IO_write_jobRealFile -!-------------------------------------------------------------------------------------------------- -!> @brief opens binary file containing array of pInt numbers to given unit for writing. File is -!! named after solver job name plus given extension and located in current working directory -!-------------------------------------------------------------------------------------------------- -subroutine IO_write_jobIntFile(fileUnit,ext,recMultiplier) - use DAMASK_interface, only: & - getSolverJobName - - implicit none - integer(pInt), intent(in) :: fileUnit !< file unit - character(len=*), intent(in) :: ext !< extension of file - integer(pInt), intent(in), optional :: recMultiplier !< record length (multiple of pReal Numbers, if not given set to one) - - integer(pInt) :: myStat - character(len=1024) :: path - - path = trim(getSolverJobName())//'.'//ext - if (present(recMultiplier)) then - open(fileUnit,status='replace',form='unformatted',access='direct', & - recl=pInt*recMultiplier,iostat=myStat,file=path) - else - open(fileUnit,status='replace',form='unformatted',access='direct', & - recl=pInt,iostat=myStat,file=path) - endif - - if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) - -end subroutine IO_write_jobIntFile - - !-------------------------------------------------------------------------------------------------- !> @brief opens binary file containing array of pReal numbers to given unit for reading. File is !! located in current working directory @@ -557,35 +541,6 @@ subroutine IO_read_intFile(fileUnit,ext,modelName,recMultiplier) end subroutine IO_read_intFile -#ifdef Abaqus -!-------------------------------------------------------------------------------------------------- -!> @brief check if the input file for Abaqus contains part info -!-------------------------------------------------------------------------------------------------- -logical function IO_abaqus_hasNoPart(fileUnit) - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=65536) :: line - - IO_abaqus_hasNoPart = .true. - -610 FORMAT(A65536) - rewind(fileUnit) - do - read(fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) then - IO_abaqus_hasNoPart = .false. - exit - endif - enddo - -620 end function IO_abaqus_hasNoPart -#endif - - !-------------------------------------------------------------------------------------------------- !> @brief identifies strings without content !-------------------------------------------------------------------------------------------------- @@ -703,22 +658,6 @@ function IO_stringValue(string,chunkPos,myChunk,silent) end function IO_stringValue -!-------------------------------------------------------------------------------------------------- -!> @brief reads string value at myChunk from fixed format string -!-------------------------------------------------------------------------------------------------- -pure function IO_fixedStringValue (string,ends,myChunk) - - implicit none - integer(pInt), intent(in) :: myChunk !< position number of desired chunk - integer(pInt), dimension(:), intent(in) :: ends !< positions of end of each tag/chunk in given string - character(len=ends(myChunk+1)-ends(myChunk)) :: IO_fixedStringValue - character(len=*), intent(in) :: string !< raw input with known ends of each chunk - - IO_fixedStringValue = string(ends(myChunk)+1:ends(myChunk+1)) - -end function IO_fixedStringValue - - !-------------------------------------------------------------------------------------------------- !> @brief reads float value at myChunk from string !-------------------------------------------------------------------------------------------------- @@ -745,24 +684,30 @@ end function IO_floatValue !-------------------------------------------------------------------------------------------------- -!> @brief reads float value at myChunk from fixed format string +!> @brief reads integer value at myChunk from string !-------------------------------------------------------------------------------------------------- -real(pReal) function IO_fixedFloatValue (string,ends,myChunk) +integer(pInt) function IO_intValue(string,chunkPos,myChunk) implicit none - character(len=*), intent(in) :: string !< raw input with known ends of each chunk + character(len=*), intent(in) :: string !< raw input with known start and end of each chunk integer(pInt), intent(in) :: myChunk !< position number of desired chunk - integer(pInt), dimension(:), intent(in) :: ends !< positions of end of each tag/chunk in given string - character(len=20), parameter :: MYNAME = 'IO_fixedFloatValue: ' - character(len=17), parameter :: VALIDCHARACTERS = '0123456789eEdD.+-' + integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string + character(len=13), parameter :: MYNAME = 'IO_intValue: ' + character(len=12), parameter :: VALIDCHARACTERS = '0123456789+-' - IO_fixedFloatValue = & - IO_verifyFloatValue(trim(adjustl(string(ends(myChunk)+1_pInt:ends(myChunk+1_pInt)))),& - VALIDCHARACTERS,MYNAME) + IO_intValue = 0_pInt -end function IO_fixedFloatValue + valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1_pInt) then + call IO_warning(201,el=myChunk,ext_msg=MYNAME//trim(string)) + else valuePresent + IO_intValue = IO_verifyIntValue(trim(adjustl(string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)))),& + VALIDCHARACTERS,MYNAME) + endif valuePresent + +end function IO_intValue +#ifdef Marc4DAMASK !-------------------------------------------------------------------------------------------------- !> @brief reads float x.y+z value at myChunk from format string !-------------------------------------------------------------------------------------------------- @@ -796,30 +741,6 @@ real(pReal) function IO_fixedNoEFloatValue (string,ends,myChunk) end function IO_fixedNoEFloatValue -!-------------------------------------------------------------------------------------------------- -!> @brief reads integer value at myChunk from string -!-------------------------------------------------------------------------------------------------- -integer(pInt) function IO_intValue(string,chunkPos,myChunk) - - implicit none - character(len=*), intent(in) :: string !< raw input with known start and end of each chunk - integer(pInt), intent(in) :: myChunk !< position number of desired chunk - integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string - character(len=13), parameter :: MYNAME = 'IO_intValue: ' - character(len=12), parameter :: VALIDCHARACTERS = '0123456789+-' - - IO_intValue = 0_pInt - - valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1_pInt) then - call IO_warning(201,el=myChunk,ext_msg=MYNAME//trim(string)) - else valuePresent - IO_intValue = IO_verifyIntValue(trim(adjustl(string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)))),& - VALIDCHARACTERS,MYNAME) - endif valuePresent - -end function IO_intValue - - !-------------------------------------------------------------------------------------------------- !> @brief reads integer value at myChunk from fixed format string !-------------------------------------------------------------------------------------------------- @@ -836,6 +757,7 @@ integer(pInt) function IO_fixedIntValue(string,ends,myChunk) VALIDCHARACTERS,MYNAME) end function IO_fixedIntValue +#endif !-------------------------------------------------------------------------------------------------- @@ -861,292 +783,6 @@ pure function IO_lc(string) end function IO_lc -!-------------------------------------------------------------------------------------------------- -!> @brief reads file to skip (at least) N chunks (may be over multiple lines) -!-------------------------------------------------------------------------------------------------- -subroutine IO_skipChunks(fileUnit,N) - - implicit none - integer(pInt), intent(in) :: fileUnit, & !< file handle - N !< minimum number of chunks to skip - - integer(pInt) :: remainingChunks - character(len=65536) :: line - - line = '' - remainingChunks = N - - do while (trim(line) /= IO_EOF .and. remainingChunks > 0) - line = IO_read(fileUnit) - remainingChunks = remainingChunks - (size(IO_stringPos(line))-1_pInt)/2_pInt - enddo -end subroutine IO_skipChunks - - -!-------------------------------------------------------------------------------------------------- -!> @brief extracts string value from key=value pair and check whether key matches -!-------------------------------------------------------------------------------------------------- -character(len=300) pure function IO_extractValue(pair,key) - - implicit none - character(len=*), intent(in) :: pair, & !< key=value pair - key !< key to be expected - - character(len=*), parameter :: SEP = achar(61) ! '=' - - integer :: myChunk !< position number of desired chunk - - IO_extractValue = '' - - myChunk = scan(pair,SEP) - if (myChunk > 0 .and. pair(:myChunk-1) == key) IO_extractValue = pair(myChunk+1:) ! extract value if key matches - -end function IO_extractValue - - -!-------------------------------------------------------------------------------------------------- -!> @brief count lines containig data up to next *keyword -!-------------------------------------------------------------------------------------------------- -integer(pInt) function IO_countDataLines(fileUnit) - - implicit none - integer(pInt), intent(in) :: fileUnit !< file handle - - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=65536) :: line, & - tmp - - IO_countDataLines = 0_pInt - line = '' - - do while (trim(line) /= IO_EOF) - line = IO_read(fileUnit) - chunkPos = IO_stringPos(line) - tmp = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) - if (tmp(1:1) == '*' .and. tmp(2:2) /= '*') then ! found keyword - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - else - if (tmp(2:2) /= '*') IO_countDataLines = IO_countDataLines + 1_pInt - endif - enddo - backspace(fileUnit) - -end function IO_countDataLines - - -!-------------------------------------------------------------------------------------------------- -!> @brief count lines containig data up to next *keyword -!-------------------------------------------------------------------------------------------------- -integer(pInt) function IO_countNumericalDataLines(fileUnit) - - implicit none - integer(pInt), intent(in) :: fileUnit !< file handle - - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=65536) :: line, & - tmp - - IO_countNumericalDataLines = 0_pInt - line = '' - - do while (trim(line) /= IO_EOF) - line = IO_read(fileUnit) - chunkPos = IO_stringPos(line) - tmp = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) - if (verify(trim(tmp),'0123456789') == 0) then ! numerical values - IO_countNumericalDataLines = IO_countNumericalDataLines + 1_pInt - else - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - enddo - backspace(fileUnit) - -end function IO_countNumericalDataLines - -!-------------------------------------------------------------------------------------------------- -!> @brief count items in consecutive lines depending on lines -!> @details Marc: ints concatenated by "c" as last char or range of values a "to" b -!> Abaqus: triplet of start,stop,inc -!> Spectral: ints concatenated range of a "to" b, multiple entries with a "of" b -!-------------------------------------------------------------------------------------------------- -integer(pInt) function IO_countContinuousIntValues(fileUnit) - - implicit none - integer(pInt), intent(in) :: fileUnit - -#ifdef Abaqus - integer(pInt) :: l,c -#endif - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=65536) :: line - - IO_countContinuousIntValues = 0_pInt - line = '' - -#ifndef Abaqus - do while (trim(line) /= IO_EOF) - line = IO_read(fileUnit) - chunkPos = IO_stringPos(line) - if (chunkPos(1) < 1_pInt) then ! empty line - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - elseif (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'to' ) then ! found range indicator - IO_countContinuousIntValues = 1_pInt + abs( IO_intValue(line,chunkPos,3_pInt) & - - IO_intValue(line,chunkPos,1_pInt)) - line = IO_read(fileUnit, .true.) ! reset IO_read - exit ! only one single range indicator allowed - else if (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'of' ) then ! found multiple entries indicator - IO_countContinuousIntValues = IO_intValue(line,chunkPos,1_pInt) - line = IO_read(fileUnit, .true.) ! reset IO_read - exit ! only one single multiplier allowed - else - IO_countContinuousIntValues = IO_countContinuousIntValues+chunkPos(1)-1_pInt ! add line's count when assuming 'c' - if ( IO_lc(IO_stringValue(line,chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value - IO_countContinuousIntValues = IO_countContinuousIntValues+1_pInt - line = IO_read(fileUnit, .true.) ! reset IO_read - exit ! data ended - endif - endif - enddo -#else - c = IO_countDataLines(fileUnit) - do l = 1_pInt,c - backspace(fileUnit) ! ToDo: substitute by rewind? - enddo - - l = 1_pInt - do while (trim(line) /= IO_EOF .and. l <= c) ! ToDo: is this correct - l = l + 1_pInt - line = IO_read(fileUnit) - chunkPos = IO_stringPos(line) - IO_countContinuousIntValues = IO_countContinuousIntValues + 1_pInt + & ! assuming range generation - (IO_intValue(line,chunkPos,2_pInt)-IO_intValue(line,chunkPos,1_pInt))/& - max(1_pInt,IO_intValue(line,chunkPos,3_pInt)) - enddo -#endif - -end function IO_countContinuousIntValues - - -!-------------------------------------------------------------------------------------------------- -!> @brief return integer list corresponding to items in consecutive lines. -!! First integer in array is counter -!> @details Marc: ints concatenated by "c" as last char, range of a "to" b, or named set -!! Abaqus: triplet of start,stop,inc or named set -!! Spectral: ints concatenated range of a "to" b, multiple entries with a "of" b -!-------------------------------------------------------------------------------------------------- -function IO_continuousIntValues(fileUnit,maxN,lookupName,lookupMap,lookupMaxN) - - implicit none - integer(pInt), intent(in) :: maxN - integer(pInt), dimension(1+maxN) :: IO_continuousIntValues - - integer(pInt), intent(in) :: fileUnit, & - lookupMaxN - integer(pInt), dimension(:,:), intent(in) :: lookupMap - character(len=64), dimension(:), intent(in) :: lookupName - integer(pInt) :: i,first,last -#ifdef Abaqus - integer(pInt) :: j,l,c -#endif - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=65536) line - logical rangeGeneration - - IO_continuousIntValues = 0_pInt - rangeGeneration = .false. - -#ifndef Abaqus - do - read(fileUnit,'(A65536)',end=100) line - chunkPos = IO_stringPos(line) - if (chunkPos(1) < 1_pInt) then ! empty line - exit - elseif (verify(IO_stringValue(line,chunkPos,1_pInt),'0123456789') > 0) then ! a non-int, i.e. set name - do i = 1_pInt, lookupMaxN ! loop over known set names - if (IO_stringValue(line,chunkPos,1_pInt) == lookupName(i)) then ! found matching name - IO_continuousIntValues = lookupMap(:,i) ! return resp. entity list - exit - endif - enddo - exit - else if (chunkPos(1) > 2_pInt .and. IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'to' ) then ! found range indicator - first = IO_intValue(line,chunkPos,1_pInt) - last = IO_intValue(line,chunkPos,3_pInt) - do i = first, last, sign(1_pInt,last-first) - IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt - IO_continuousIntValues(1+IO_continuousIntValues(1)) = i - enddo - exit - else if (chunkPos(1) > 2_pInt .and. IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'of' ) then ! found multiple entries indicator - IO_continuousIntValues(1) = IO_intValue(line,chunkPos,1_pInt) - IO_continuousIntValues(2:IO_continuousIntValues(1)+1) = IO_intValue(line,chunkPos,3_pInt) - exit - else - do i = 1_pInt,chunkPos(1)-1_pInt ! interpret up to second to last value - IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt - IO_continuousIntValues(1+IO_continuousIntValues(1)) = IO_intValue(line,chunkPos,i) - enddo - if ( IO_lc(IO_stringValue(line,chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value - IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt - IO_continuousIntValues(1+IO_continuousIntValues(1)) = IO_intValue(line,chunkPos,chunkPos(1)) - exit - endif - endif - enddo -#else - c = IO_countDataLines(fileUnit) - do l = 1_pInt,c - backspace(fileUnit) - enddo - -!-------------------------------------------------------------------------------------------------- -! check if the element values in the elset are auto generated - backspace(fileUnit) - read(fileUnit,'(A65536)',end=100) line - chunkPos = IO_stringPos(line) - do i = 1_pInt,chunkPos(1) - if (IO_lc(IO_stringValue(line,chunkPos,i)) == 'generate') rangeGeneration = .true. - enddo - - do l = 1_pInt,c - read(fileUnit,'(A65536)',end=100) line - chunkPos = IO_stringPos(line) - if (verify(IO_stringValue(line,chunkPos,1_pInt),'0123456789') > 0) then ! a non-int, i.e. set names follow on this line - do i = 1_pInt,chunkPos(1) ! loop over set names in line - do j = 1_pInt,lookupMaxN ! look through known set names - if (IO_stringValue(line,chunkPos,i) == lookupName(j)) then ! found matching name - first = 2_pInt + IO_continuousIntValues(1) ! where to start appending data - last = first + lookupMap(1,j) - 1_pInt ! up to where to append data - IO_continuousIntValues(first:last) = lookupMap(2:1+lookupMap(1,j),j) ! add resp. entity list - IO_continuousIntValues(1) = IO_continuousIntValues(1) + lookupMap(1,j) ! count them - endif - enddo - enddo - else if (rangeGeneration) then ! range generation - do i = IO_intValue(line,chunkPos,1_pInt),& - IO_intValue(line,chunkPos,2_pInt),& - max(1_pInt,IO_intValue(line,chunkPos,3_pInt)) - IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt - IO_continuousIntValues(1+IO_continuousIntValues(1)) = i - enddo - else ! read individual elem nums - do i = 1_pInt,chunkPos(1) - IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt - IO_continuousIntValues(1+IO_continuousIntValues(1)) = IO_intValue(line,chunkPos,i) - enddo - endif - enddo -#endif - -100 end function IO_continuousIntValues - - !-------------------------------------------------------------------------------------------------- !> @brief returns format string for integer values without leading zeros !-------------------------------------------------------------------------------------------------- @@ -1344,11 +980,9 @@ subroutine IO_error(error_ID,el,ip,g,instance,ext_msg) ! DAMASK_marc errors case (700_pInt) msg = 'invalid materialpoint result requested' - case (701_pInt) - msg = 'not supported input file format, use Marc 2016 or earlier' !------------------------------------------------------------------------------------------------- -! errors related to spectral solver +! errors related to the grid solver case (809_pInt) msg = 'initializing FFTW' case (810_pInt) @@ -1370,13 +1004,9 @@ subroutine IO_error(error_ID,el,ip,g,instance,ext_msg) case (841_pInt) msg = 'missing header length info in spectral mesh' case (842_pInt) - msg = 'homogenization in spectral mesh' - case (843_pInt) - msg = 'grid in spectral mesh' - case (844_pInt) - msg = 'size in spectral mesh' - case (845_pInt) msg = 'incomplete information in spectral mesh header' + case (843_pInt) + msg = 'microstructure count mismatch' case (846_pInt) msg = 'rotation for load case rotation ill-defined (R:RT != I)' case (847_pInt) @@ -1542,6 +1172,289 @@ subroutine IO_warning(warning_ID,el,ip,g,ext_msg) end subroutine IO_warning +#if defined(Abaqus) || defined(Marc4DAMASK) + +#ifdef Abaqus +!-------------------------------------------------------------------------------------------------- +!> @brief extracts string value from key=value pair and check whether key matches +!-------------------------------------------------------------------------------------------------- +character(len=300) pure function IO_extractValue(pair,key) + + implicit none + character(len=*), intent(in) :: pair, & !< key=value pair + key !< key to be expected + + character(len=*), parameter :: SEP = achar(61) ! '=' + + integer :: myChunk !< position number of desired chunk + + IO_extractValue = '' + + myChunk = scan(pair,SEP) + if (myChunk > 0 .and. pair(:myChunk-1) == key) IO_extractValue = pair(myChunk+1:) ! extract value if key matches + +end function IO_extractValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief count lines containig data up to next *keyword +!-------------------------------------------------------------------------------------------------- +integer(pInt) function IO_countDataLines(fileUnit) + + implicit none + integer(pInt), intent(in) :: fileUnit !< file handle + + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: line, & + tmp + + IO_countDataLines = 0_pInt + line = '' + + do while (trim(line) /= IO_EOF) + line = IO_read(fileUnit) + chunkPos = IO_stringPos(line) + tmp = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) + if (tmp(1:1) == '*' .and. tmp(2:2) /= '*') then ! found keyword + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + else + if (tmp(2:2) /= '*') IO_countDataLines = IO_countDataLines + 1_pInt + endif + enddo + backspace(fileUnit) + +end function IO_countDataLines +#endif + + +#ifdef Marc4DAMASK +!-------------------------------------------------------------------------------------------------- +!> @brief count lines containig data up to next *keyword +!-------------------------------------------------------------------------------------------------- +integer(pInt) function IO_countNumericalDataLines(fileUnit) + + implicit none + integer(pInt), intent(in) :: fileUnit !< file handle + + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: line, & + tmp + + IO_countNumericalDataLines = 0_pInt + line = '' + + do while (trim(line) /= IO_EOF) + line = IO_read(fileUnit) + chunkPos = IO_stringPos(line) + tmp = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) + if (verify(trim(tmp),'0123456789') == 0) then ! numerical values + IO_countNumericalDataLines = IO_countNumericalDataLines + 1_pInt + else + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + enddo + backspace(fileUnit) + +end function IO_countNumericalDataLines + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads file to skip (at least) N chunks (may be over multiple lines) +!-------------------------------------------------------------------------------------------------- +subroutine IO_skipChunks(fileUnit,N) + + implicit none + integer(pInt), intent(in) :: fileUnit, & !< file handle + N !< minimum number of chunks to skip + + integer(pInt) :: remainingChunks + character(len=65536) :: line + + line = '' + remainingChunks = N + + do while (trim(line) /= IO_EOF .and. remainingChunks > 0) + line = IO_read(fileUnit) + remainingChunks = remainingChunks - (size(IO_stringPos(line))-1_pInt)/2_pInt + enddo +end subroutine IO_skipChunks +#endif + + +!-------------------------------------------------------------------------------------------------- +!> @brief count items in consecutive lines depending on lines +!> @details Marc: ints concatenated by "c" as last char or range of values a "to" b +!> Abaqus: triplet of start,stop,inc +!-------------------------------------------------------------------------------------------------- +integer(pInt) function IO_countContinuousIntValues(fileUnit) + + implicit none + integer(pInt), intent(in) :: fileUnit + +#ifdef Abaqus + integer(pInt) :: l,c +#endif + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: line + + IO_countContinuousIntValues = 0_pInt + line = '' + +#if defined(Marc4DAMASK) + do while (trim(line) /= IO_EOF) + line = IO_read(fileUnit) + chunkPos = IO_stringPos(line) + if (chunkPos(1) < 1_pInt) then ! empty line + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + elseif (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'to' ) then ! found range indicator + IO_countContinuousIntValues = 1_pInt + abs( IO_intValue(line,chunkPos,3_pInt) & + - IO_intValue(line,chunkPos,1_pInt)) + line = IO_read(fileUnit, .true.) ! reset IO_read + exit ! only one single range indicator allowed + else + IO_countContinuousIntValues = IO_countContinuousIntValues+chunkPos(1)-1_pInt ! add line's count when assuming 'c' + if ( IO_lc(IO_stringValue(line,chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value + IO_countContinuousIntValues = IO_countContinuousIntValues+1_pInt + line = IO_read(fileUnit, .true.) ! reset IO_read + exit ! data ended + endif + endif + enddo +#elif defined(Abaqus) + c = IO_countDataLines(fileUnit) + do l = 1_pInt,c + backspace(fileUnit) + enddo + + l = 1_pInt + do while (trim(line) /= IO_EOF .and. l <= c) ! ToDo: is this correct? + l = l + 1_pInt + line = IO_read(fileUnit) + chunkPos = IO_stringPos(line) + IO_countContinuousIntValues = IO_countContinuousIntValues + 1_pInt + & ! assuming range generation + (IO_intValue(line,chunkPos,2_pInt)-IO_intValue(line,chunkPos,1_pInt))/& + max(1_pInt,IO_intValue(line,chunkPos,3_pInt)) + enddo +#endif + +end function IO_countContinuousIntValues + + +!-------------------------------------------------------------------------------------------------- +!> @brief return integer list corresponding to items in consecutive lines. +!! First integer in array is counter +!> @details Marc: ints concatenated by "c" as last char, range of a "to" b, or named set +!! Abaqus: triplet of start,stop,inc or named set +!-------------------------------------------------------------------------------------------------- +function IO_continuousIntValues(fileUnit,maxN,lookupName,lookupMap,lookupMaxN) + + implicit none + integer(pInt), intent(in) :: maxN + integer(pInt), dimension(1+maxN) :: IO_continuousIntValues + + integer(pInt), intent(in) :: fileUnit, & + lookupMaxN + integer(pInt), dimension(:,:), intent(in) :: lookupMap + character(len=64), dimension(:), intent(in) :: lookupName + integer(pInt) :: i,first,last +#ifdef Abaqus + integer(pInt) :: j,l,c +#endif + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) line + logical rangeGeneration + + IO_continuousIntValues = 0_pInt + rangeGeneration = .false. + +#if defined(Marc4DAMASK) + do + read(fileUnit,'(A65536)',end=100) line + chunkPos = IO_stringPos(line) + if (chunkPos(1) < 1_pInt) then ! empty line + exit + elseif (verify(IO_stringValue(line,chunkPos,1_pInt),'0123456789') > 0) then ! a non-int, i.e. set name + do i = 1_pInt, lookupMaxN ! loop over known set names + if (IO_stringValue(line,chunkPos,1_pInt) == lookupName(i)) then ! found matching name + IO_continuousIntValues = lookupMap(:,i) ! return resp. entity list + exit + endif + enddo + exit + else if (chunkPos(1) > 2_pInt .and. IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'to' ) then ! found range indicator + first = IO_intValue(line,chunkPos,1_pInt) + last = IO_intValue(line,chunkPos,3_pInt) + do i = first, last, sign(1_pInt,last-first) + IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt + IO_continuousIntValues(1+IO_continuousIntValues(1)) = i + enddo + exit + else + do i = 1_pInt,chunkPos(1)-1_pInt ! interpret up to second to last value + IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt + IO_continuousIntValues(1+IO_continuousIntValues(1)) = IO_intValue(line,chunkPos,i) + enddo + if ( IO_lc(IO_stringValue(line,chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value + IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt + IO_continuousIntValues(1+IO_continuousIntValues(1)) = IO_intValue(line,chunkPos,chunkPos(1)) + exit + endif + endif + enddo +#elif defined(Abaqus) + c = IO_countDataLines(fileUnit) + do l = 1_pInt,c + backspace(fileUnit) + enddo + +!-------------------------------------------------------------------------------------------------- +! check if the element values in the elset are auto generated + backspace(fileUnit) + read(fileUnit,'(A65536)',end=100) line + chunkPos = IO_stringPos(line) + do i = 1_pInt,chunkPos(1) + if (IO_lc(IO_stringValue(line,chunkPos,i)) == 'generate') rangeGeneration = .true. + enddo + + do l = 1_pInt,c + read(fileUnit,'(A65536)',end=100) line + chunkPos = IO_stringPos(line) + if (verify(IO_stringValue(line,chunkPos,1_pInt),'0123456789') > 0) then ! a non-int, i.e. set names follow on this line + do i = 1_pInt,chunkPos(1) ! loop over set names in line + do j = 1_pInt,lookupMaxN ! look through known set names + if (IO_stringValue(line,chunkPos,i) == lookupName(j)) then ! found matching name + first = 2_pInt + IO_continuousIntValues(1) ! where to start appending data + last = first + lookupMap(1,j) - 1_pInt ! up to where to append data + IO_continuousIntValues(first:last) = lookupMap(2:1+lookupMap(1,j),j) ! add resp. entity list + IO_continuousIntValues(1) = IO_continuousIntValues(1) + lookupMap(1,j) ! count them + endif + enddo + enddo + else if (rangeGeneration) then ! range generation + do i = IO_intValue(line,chunkPos,1_pInt),& + IO_intValue(line,chunkPos,2_pInt),& + max(1_pInt,IO_intValue(line,chunkPos,3_pInt)) + IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt + IO_continuousIntValues(1+IO_continuousIntValues(1)) = i + enddo + else ! read individual elem nums + do i = 1_pInt,chunkPos(1) + IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt + IO_continuousIntValues(1+IO_continuousIntValues(1)) = IO_intValue(line,chunkPos,i) + enddo + endif + enddo +#endif + +100 end function IO_continuousIntValues +#endif + !-------------------------------------------------------------------------------------------------- ! internal helper functions @@ -1601,57 +1514,4 @@ real(pReal) function IO_verifyFloatValue (string,validChars,myName) end function IO_verifyFloatValue -#ifdef Abaqus -!-------------------------------------------------------------------------------------------------- -!> @brief create a new input file for abaqus simulations by removing all comment lines and -!> including "include"s -!-------------------------------------------------------------------------------------------------- -recursive function abaqus_assembleInputFile(unit1,unit2) result(createSuccess) - - implicit none - integer(pInt), intent(in) :: unit1, & - unit2 - - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=65536) :: line,fname - logical :: createSuccess,fexist - - - do - read(unit2,'(A65536)',END=220) line - chunkPos = IO_stringPos(line) - - if (IO_lc(IO_StringValue(line,chunkPos,1_pInt))=='*include') then - fname = trim(line(9+scan(line(9:),'='):)) - inquire(file=fname, exist=fexist) - if (.not.(fexist)) then - !$OMP CRITICAL (write2out) - write(6,*)'ERROR: file does not exist error in abaqus_assembleInputFile' - write(6,*)'filename: ', trim(fname) - !$OMP END CRITICAL (write2out) - createSuccess = .false. - return - endif - open(unit2+1,err=200,status='old',file=fname) - if (abaqus_assembleInputFile(unit1,unit2+1_pInt)) then - createSuccess=.true. - close(unit2+1) - else - createSuccess=.false. - return - endif - else if (line(1:2) /= '**' .OR. line(1:8)=='**damask') then - write(unit1,'(A)') trim(line) - endif - enddo - -220 createSuccess = .true. - return - -200 createSuccess =.false. - -end function abaqus_assembleInputFile -#endif - end module IO diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 353ca1497..1ef68b3cd 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -15,7 +15,14 @@ #include "Lambert.f90" #include "rotations.f90" #include "FEsolving.f90" -#include "mesh.f90" +#include "element.f90" +#include "mesh_base.f90" +#ifdef Abaqus +#include "mesh_abaqus.f90" +#endif +#ifdef Marc4DAMASK +#include "mesh_marc.f90" +#endif #include "material.f90" #include "lattice.f90" #include "source_thermal_dissipation.f90" diff --git a/src/compilation_info.f90 b/src/compilation_info.f90 index f0ca4d4cc..e69de29bb 100644 --- a/src/compilation_info.f90 +++ b/src/compilation_info.f90 @@ -1,10 +0,0 @@ -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - write(6,*) 'Compiled with ', compiler_version() - write(6,*) 'With options ', compiler_options() -#else - write(6,'(a,i4.4,a,i8.8)') ' Compiled with Intel fortran version ', __INTEL_COMPILER,& - ', build date ', __INTEL_COMPILER_BUILD_DATE -#endif -write(6,*) 'Compiled on ', __DATE__,' at ',__TIME__ -write(6,*) -flush(6) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 9483f2610..3b7d57efe 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -56,12 +56,9 @@ subroutine constitutive_init() IO_checkAndRewind, & IO_open_jobFile_stat, & IO_write_jobFile, & - IO_write_jobIntFile, & IO_timeStamp use config, only: & config_phase - use mesh, only: & - FE_geomtype use config, only: & material_Nphase, & material_localFileExt, & @@ -163,16 +160,16 @@ subroutine constitutive_init() call IO_checkAndRewind(FILEUNIT) if (any(phase_source == SOURCE_thermal_dissipation_ID)) call source_thermal_dissipation_init(FILEUNIT) if (any(phase_source == SOURCE_thermal_externalheat_ID)) call source_thermal_externalheat_init(FILEUNIT) - if (any(phase_source == SOURCE_damage_isoBrittle_ID)) call source_damage_isoBrittle_init(FILEUNIT) - if (any(phase_source == SOURCE_damage_isoDuctile_ID)) call source_damage_isoDuctile_init(FILEUNIT) - if (any(phase_source == SOURCE_damage_anisoBrittle_ID)) call source_damage_anisoBrittle_init(FILEUNIT) - if (any(phase_source == SOURCE_damage_anisoDuctile_ID)) call source_damage_anisoDuctile_init(FILEUNIT) - + if (any(phase_source == SOURCE_damage_isoBrittle_ID)) call source_damage_isoBrittle_init + if (any(phase_source == SOURCE_damage_isoDuctile_ID)) call source_damage_isoDuctile_init + if (any(phase_source == SOURCE_damage_anisoBrittle_ID)) call source_damage_anisoBrittle_init + if (any(phase_source == SOURCE_damage_anisoDuctile_ID)) call source_damage_anisoDuctile_init + !-------------------------------------------------------------------------------------------------- ! parse kinematic mechanisms from config file call IO_checkAndRewind(FILEUNIT) - if (any(phase_kinematics == KINEMATICS_cleavage_opening_ID)) call kinematics_cleavage_opening_init(FILEUNIT) - if (any(phase_kinematics == KINEMATICS_slipplane_opening_ID)) call kinematics_slipplane_opening_init(FILEUNIT) + if (any(phase_kinematics == KINEMATICS_cleavage_opening_ID)) call kinematics_cleavage_opening_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(FILEUNIT) close(FILEUNIT) @@ -609,9 +606,9 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, S6, Fi, ipc, ip, e KinematicsLoop: do k = 1_pInt, 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, S6, ipc, ip, el) + call kinematics_cleavage_opening_LiAndItsTangent(my_Li, my_dLi_dS, math_6toSym33(S6), ipc, ip, el) case (KINEMATICS_slipplane_opening_ID) kinematicsType - call kinematics_slipplane_opening_LiAndItsTangent(my_Li, my_dLi_dS, S6, ipc, ip, el) + call kinematics_slipplane_opening_LiAndItsTangent(my_Li, my_dLi_dS, math_6toSym33(S6), ipc, ip, el) case (KINEMATICS_thermal_expansion_ID) kinematicsType call kinematics_thermal_expansion_LiAndItsTangent(my_Li, my_dLi_dS, ipc, ip, el) case default kinematicsType @@ -788,8 +785,7 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac math_sym33to6, & math_mul33x33 use mesh, only: & - mesh_NcpElems, & - mesh_maxNips + theMesh use material, only: & phasememberAt, & phase_plasticityInstance, & @@ -840,9 +836,9 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac el !< element real(pReal), intent(in) :: & subdt !< timestep - real(pReal), intent(in), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + real(pReal), intent(in), dimension(homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & subfracArray !< subfraction of timestep - real(pReal), intent(in), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + real(pReal), intent(in), dimension(3,3,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & FeArray, & !< elastic deformation gradient FpArray !< plastic deformation gradient real(pReal), intent(in), dimension(3,3) :: & @@ -899,7 +895,7 @@ subroutine constitutive_collectDotState(S6, FeArray, Fi, FpArray, subdt, subfrac sourceType: select case (phase_source(s,material_phase(ipc,ip,el))) case (SOURCE_damage_anisoBrittle_ID) sourceType - call source_damage_anisoBrittle_dotState (S6, ipc, ip, el) !< correct stress? + call source_damage_anisoBrittle_dotState (math_6toSym33(S6), ipc, ip, el) !< correct stress? case (SOURCE_damage_isoDuctile_ID) sourceType call source_damage_isoDuctile_dotState ( ipc, ip, el) @@ -1002,8 +998,7 @@ function constitutive_postResults(S6, Fi, FeArray, ipc, ip, el) math_6toSym33, & math_mul33x33 use mesh, only: & - mesh_NcpElems, & - mesh_maxNips + theMesh use material, only: & phasememberAt, & phase_plasticityInstance, & @@ -1059,7 +1054,7 @@ function constitutive_postResults(S6, Fi, FeArray, ipc, ip, el) constitutive_postResults real(pReal), intent(in), dimension(3,3) :: & Fi !< intermediate deformation gradient - real(pReal), intent(in), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + real(pReal), intent(in), dimension(3,3,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & FeArray !< elastic deformation gradient real(pReal), intent(in), dimension(6) :: & S6 !< 2nd Piola Kirchhoff stress (vector notation) @@ -1121,16 +1116,18 @@ function constitutive_postResults(S6, Fi, FeArray, ipc, ip, el) SourceLoop: do s = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) startPos = endPos + 1_pInt endPos = endPos + sourceState(material_phase(ipc,ip,el))%p(s)%sizePostResults + of = phasememberAt(ipc,ip,el) sourceType: select case (phase_source(s,material_phase(ipc,ip,el))) case (SOURCE_damage_isoBrittle_ID) sourceType - constitutive_postResults(startPos:endPos) = source_damage_isoBrittle_postResults(ipc, ip, el) + constitutive_postResults(startPos:endPos) = source_damage_isoBrittle_postResults(material_phase(ipc,ip,el),of) case (SOURCE_damage_isoDuctile_ID) sourceType - constitutive_postResults(startPos:endPos) = source_damage_isoDuctile_postResults(ipc, ip, el) + constitutive_postResults(startPos:endPos) = source_damage_isoDuctile_postResults(material_phase(ipc,ip,el),of) case (SOURCE_damage_anisoBrittle_ID) sourceType - constitutive_postResults(startPos:endPos) = source_damage_anisoBrittle_postResults(ipc, ip, el) + constitutive_postResults(startPos:endPos) = source_damage_anisoBrittle_postResults(material_phase(ipc,ip,el),of) case (SOURCE_damage_anisoDuctile_ID) sourceType - constitutive_postResults(startPos:endPos) = source_damage_anisoDuctile_postResults(ipc, ip, el) + constitutive_postResults(startPos:endPos) = source_damage_anisoDuctile_postResults(material_phase(ipc,ip,el),of) end select sourceType + enddo SourceLoop end function constitutive_postResults diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 013c28a38..d93950b99 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -17,8 +17,6 @@ module crystallite use FEsolving, only: & FEsolving_execElem, & FEsolving_execIP - use mesh, only: & - mesh_element use material, only: & homogenization_Ngrains @@ -157,10 +155,8 @@ subroutine crystallite_init math_inv33, & math_mul33x33 use mesh, only: & - mesh_element, & - mesh_NcpElems, & - mesh_maxNips, & - mesh_maxNipNeighbors + theMesh, & + mesh_element use IO, only: & IO_timeStamp, & IO_stringValue, & @@ -198,8 +194,8 @@ subroutine crystallite_init #include "compilation_info.f90" cMax = homogenization_maxNgrains - iMax = mesh_maxNips - eMax = mesh_NcpElems + iMax = theMesh%elem%nIPs + eMax = theMesh%nElems ! --------------------------------------------------------------------------- ! ToDo (when working on homogenization): should be 3x3 tensor called S @@ -330,7 +326,7 @@ subroutine crystallite_init case(elasmatrix_ID) mySize = 36_pInt case(neighboringip_ID,neighboringelement_ID) - mySize = mesh_maxNipNeighbors + mySize = theMesh%elem%nIPneighbors case default mySize = 0_pInt end select @@ -411,7 +407,7 @@ subroutine crystallite_init write(6,'(a42,1x,i10)') ' # of elements: ', eMax write(6,'(a42,1x,i10)') 'max # of integration points/element: ', iMax write(6,'(a42,1x,i10)') 'max # of constituents/integration point: ', cMax - write(6,'(a42,1x,i10)') 'max # of neigbours/integration point: ', mesh_maxNipNeighbors + write(6,'(a42,1x,i10)') 'max # of neigbours/integration point: ', theMesh%elem%nIPneighbors write(6,'(a42,1x,i10)') ' # of nonlocal constituents: ',count(.not. crystallite_localPlasticity) flush(6) endif @@ -426,7 +422,7 @@ end subroutine crystallite_init !-------------------------------------------------------------------------------------------------- !> @brief calculate stress (P) !-------------------------------------------------------------------------------------------------- -function crystallite_stress() +function crystallite_stress(a) use prec, only: & tol_math_check, & dNeq0 @@ -454,10 +450,8 @@ function crystallite_stress() math_6toSym33, & math_sym33to6 use mesh, only: & - mesh_NcpElems, & - mesh_element, & - mesh_maxNips, & - FE_geomtype + theMesh, & + mesh_element use material, only: & homogenization_Ngrains, & plasticState, & @@ -470,7 +464,8 @@ function crystallite_stress() constitutive_LiAndItsTangents implicit none - logical, dimension(mesh_maxNips,mesh_NcpElems) :: crystallite_stress + logical, dimension(theMesh%elem%nIPs,theMesh%Nelems) :: crystallite_stress + real(pReal), intent(in), optional :: a !ToDo: for some reason this prevents an internal compiler error in GNU. Very strange real(pReal) :: & formerSubStep integer(pInt) :: & @@ -537,7 +532,7 @@ function crystallite_stress() endIP = startIP else singleRun startIP = 1_pInt - endIP = mesh_maxNips + endIP = theMesh%elem%nIPs endif singleRun NiterationCrystallite = 0_pInt @@ -723,8 +718,7 @@ subroutine crystallite_stressTangent() math_invert2, & math_det33 use mesh, only: & - mesh_element, & - FE_geomtype + mesh_element use material, only: & homogenization_Ngrains use constitutive, only: & @@ -923,7 +917,7 @@ function crystallite_push33ToRef(ipc,ip,el, tensor33) math_inv33, & math_EulerToR use material, only: & - material_EulerAngles + material_EulerAngles ! ToDo: Why stored? We also have crystallite_orientation0 implicit none real(pReal), dimension(3,3) :: crystallite_push33ToRef @@ -954,13 +948,10 @@ function crystallite_postResults(ipc, ip, el) inDeg, & math_6toSym33 use mesh, only: & + theMesh, & mesh_element, & mesh_ipVolume, & - mesh_maxNipNeighbors, & - mesh_ipNeighborhood, & - FE_NipNeighbors, & - FE_geomtype, & - FE_celltype + mesh_ipNeighborhood use material, only: & plasticState, & sourceState, & @@ -1064,14 +1055,14 @@ function crystallite_postResults(ipc, ip, el) mySize = 36_pInt crystallite_postResults(c+1:c+mySize) = reshape(constitutive_homogenizedC(ipc,ip,el),[mySize]) case(neighboringelement_ID) - mySize = mesh_maxNipNeighbors + mySize = theMesh%elem%nIPneighbors crystallite_postResults(c+1:c+mySize) = 0.0_pReal - forall (n = 1_pInt:FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el))))) & + forall (n = 1_pInt:mySize) & crystallite_postResults(c+n) = real(mesh_ipNeighborhood(1,n,ip,el),pReal) case(neighboringip_ID) - mySize = mesh_maxNipNeighbors + mySize = theMesh%elem%nIPneighbors crystallite_postResults(c+1:c+mySize) = 0.0_pReal - forall (n = 1_pInt:FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el))))) & + forall (n = 1_pInt:mySize) & crystallite_postResults(c+n) = real(mesh_ipNeighborhood(2,n,ip,el),pReal) end select c = c + mySize @@ -1748,9 +1739,8 @@ end subroutine integrateStateEuler !-------------------------------------------------------------------------------------------------- subroutine integrateStateAdaptiveEuler() use mesh, only: & - mesh_element, & - mesh_NcpElems, & - mesh_maxNips + theMesh, & + mesh_element use material, only: & homogenization_Ngrains, & plasticState, & @@ -1774,11 +1764,11 @@ subroutine integrateStateAdaptiveEuler() ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of adaptive Euler real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & - homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & residuum_plastic real(pReal), dimension(constitutive_source_maxSizeDotState,& maxval(phase_Nsources), & - homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & residuum_source !-------------------------------------------------------------------------------------------------- @@ -1925,8 +1915,7 @@ end subroutine integrateStateRK4 subroutine integrateStateRKCK45() use mesh, only: & mesh_element, & - mesh_NcpElems, & - mesh_maxNips + theMesh use material, only: & homogenization_Ngrains, & plasticState, & @@ -1973,11 +1962,11 @@ subroutine integrateStateRKCK45() ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of RKCK45 real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & - homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & residuum_plastic ! relative residuum from evolution in microstructure real(pReal), dimension(constitutive_source_maxSizeDotState, & maxval(phase_Nsources), & - homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & residuum_source ! relative residuum from evolution in microstructure @@ -2122,7 +2111,8 @@ end subroutine nonlocalConvergenceCheck !> @details: For explicitEuler, RK4 and RKCK45, adaptive Euler and FPI have their on criteria !-------------------------------------------------------------------------------------------------- subroutine setConvergenceFlag() - + use mesh, only: & + mesh_element implicit none integer(pInt) :: & e, & !< element index in element loop @@ -2162,7 +2152,8 @@ end subroutine setConvergenceFlag !> @brief Standard forwarding of state as state = state0 + dotState * (delta t) !-------------------------------------------------------------------------------------------------- subroutine update_stress(timeFraction) - + use mesh, only: & + mesh_element implicit none real(pReal), intent(in) :: & timeFraction @@ -2194,6 +2185,8 @@ end subroutine update_stress !> @brief tbd !-------------------------------------------------------------------------------------------------- subroutine update_dependentState() + use mesh, only: & + mesh_element use constitutive, only: & constitutive_dependentState => constitutive_microstructure @@ -2225,6 +2218,8 @@ subroutine update_state(timeFraction) sourceState, & phase_Nsources, & phaseAt, phasememberAt + use mesh, only: & + mesh_element implicit none real(pReal), intent(in) :: & @@ -2274,6 +2269,8 @@ subroutine update_dotState(timeFraction) sourceState, & phaseAt, phasememberAt, & phase_Nsources + use mesh, only: & + mesh_element use constitutive, only: & constitutive_collectDotState @@ -2327,6 +2324,8 @@ subroutine update_deltaState IEEE_arithmetic use prec, only: & dNeq0 + use mesh, only: & + mesh_element use material, only: & plasticState, & sourceState, & @@ -2422,6 +2421,8 @@ logical function stateJump(ipc,ip,el) sourceState, & phase_Nsources, & phaseAt, phasememberAt + use mesh, only: & + mesh_element use constitutive, only: & constitutive_collectDeltaState use math, only: & diff --git a/src/damage_local.f90 b/src/damage_local.f90 index 74bcb00db..6569347c2 100644 --- a/src/damage_local.f90 +++ b/src/damage_local.f90 @@ -225,6 +225,7 @@ subroutine damage_local_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, el homogenization_Ngrains, & mappingHomogenization, & phaseAt, & + phasememberAt, & phase_source, & phase_Nsources, & SOURCE_damage_isoBrittle_ID, & @@ -249,7 +250,8 @@ subroutine damage_local_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, el integer(pInt) :: & phase, & grain, & - source + source, & + constituent real(pReal) :: & phiDot, dPhiDot_dPhi, localphiDot, dLocalphiDot_dPhi @@ -257,19 +259,20 @@ subroutine damage_local_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, el dPhiDot_dPhi = 0.0_pReal do grain = 1, homogenization_Ngrains(mappingHomogenization(2,ip,el)) phase = phaseAt(grain,ip,el) + constituent = phasememberAt(grain,ip,el) do source = 1, phase_Nsources(phase) select case(phase_source(source,phase)) case (SOURCE_damage_isoBrittle_ID) - call source_damage_isobrittle_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + call source_damage_isobrittle_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) case (SOURCE_damage_isoDuctile_ID) - call source_damage_isoductile_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + call source_damage_isoductile_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) case (SOURCE_damage_anisoBrittle_ID) - call source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + call source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) case (SOURCE_damage_anisoDuctile_ID) - call source_damage_anisoductile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + call source_damage_anisoductile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) case default localphiDot = 0.0_pReal diff --git a/src/damage_nonlocal.f90 b/src/damage_nonlocal.f90 index 6b9093ef1..eab808266 100644 --- a/src/damage_nonlocal.f90 +++ b/src/damage_nonlocal.f90 @@ -186,6 +186,7 @@ subroutine damage_nonlocal_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, homogenization_Ngrains, & mappingHomogenization, & phaseAt, & + phasememberAt, & phase_source, & phase_Nsources, & SOURCE_damage_isoBrittle_ID, & @@ -210,7 +211,8 @@ subroutine damage_nonlocal_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, integer(pInt) :: & phase, & grain, & - source + source, & + constituent real(pReal) :: & phiDot, dPhiDot_dPhi, localphiDot, dLocalphiDot_dPhi @@ -218,19 +220,20 @@ subroutine damage_nonlocal_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, dPhiDot_dPhi = 0.0_pReal do grain = 1, homogenization_Ngrains(mappingHomogenization(2,ip,el)) phase = phaseAt(grain,ip,el) + constituent = phasememberAt(grain,ip,el) do source = 1_pInt, phase_Nsources(phase) select case(phase_source(source,phase)) case (SOURCE_damage_isoBrittle_ID) - call source_damage_isobrittle_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + call source_damage_isobrittle_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) case (SOURCE_damage_isoDuctile_ID) - call source_damage_isoductile_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + call source_damage_isoductile_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) case (SOURCE_damage_anisoBrittle_ID) - call source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + call source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) case (SOURCE_damage_anisoDuctile_ID) - call source_damage_anisoductile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + call source_damage_anisoductile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) case default localphiDot = 0.0_pReal diff --git a/src/element.f90 b/src/element.f90 new file mode 100644 index 000000000..473d9c73c --- /dev/null +++ b/src/element.f90 @@ -0,0 +1,921 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Koords, Max-Planck-Institut für Eisenforschung GmbH +!-------------------------------------------------------------------------------------------------- +module element + use prec, only: & + pInt, & + pReal + + implicit none + private + +!--------------------------------------------------------------------------------------------------- +!> Properties of a single element (the element used in the mesh) +!--------------------------------------------------------------------------------------------------- + type, public :: tElement + integer(pInt) :: & + elemType, & + geomType, & ! geometry type (same for same dimension and same number of integration points) + cellType, & + Nnodes, & + Ncellnodes, & + NcellnodesPerCell, & + nIPs, & + nIPneighbors, & ! ToDo: MD: Do all IPs in one element type have the same number of neighbors? + maxNnodeAtIP + integer(pInt), dimension(:,:), allocatable :: & + Cell, & ! intra-element (cell) nodes that constitute a cell + NnodeAtIP, & + IPneighbor, & + cellFace + real(pReal), dimension(:,:), allocatable :: & + ! center of gravity of the weighted nodes gives the position of the cell node. + ! example: face-centered cell node with face nodes 1,2,5,6 to be used in, + ! e.g., an 8 node element, would be encoded: + ! 1, 1, 0, 0, 1, 1, 0, 0 + cellNodeParentNodeWeights + contains + procedure :: init => tElement_init + end type + + integer(pInt), parameter, private :: & + NELEMTYPE = 13_pInt + + integer(pInt), dimension(NelemType), parameter, private :: NNODE = & + int([ & + 3, & ! 2D 3node 1ip + 6, & ! 2D 6node 3ip + 4, & ! 2D 4node 4ip + 8, & ! 2D 8node 9ip + 8, & ! 2D 8node 4ip + !-------------------- + 4, & ! 3D 4node 1ip + 5, & ! 3D 5node 4ip + 10, & ! 3D 10node 4ip + 6, & ! 3D 6node 6ip + 8, & ! 3D 8node 1ip + 8, & ! 3D 8node 8ip + 20, & ! 3D 20node 8ip + 20 & ! 3D 20node 27ip + ],pInt) !< number of nodes that constitute a specific type of element + + integer(pInt), dimension(NelemType), parameter, public :: GEOMTYPE = & + int([ & + 1, & ! 2D 3node 1ip + 2, & ! 2D 6node 3ip + 3, & ! 2D 4node 4ip + 4, & ! 2D 8node 9ip + 3, & ! 2D 8node 4ip + !-------------------- + 5, & ! 3D 4node 1ip + 6, & ! 3D 5node 4ip + 6, & ! 3D 10node 4ip + 7, & ! 3D 6node 6ip + 8, & ! 3D 8node 1ip + 9, & ! 3D 8node 8ip + 9, & ! 3D 20node 8ip + 10 & ! 3D 20node 27ip + ],pInt) !< geometry type of particular element type + + !integer(pInt), dimension(maxval(geomType)), parameter, private :: NCELLNODE = & ! Intel 16.0 complains + integer(pInt), dimension(10), parameter, private :: NCELLNODE = & + int([ & + 3, & + 7, & + 9, & + 16, & + 4, & + 15, & + 21, & + 8, & + 27, & + 64 & + ],pInt) !< number of cell nodes in a specific geometry type + + !integer(pInt), dimension(maxval(geomType)), parameter, private :: NIP = & ! Intel 16.0 complains + integer(pInt), dimension(10), parameter, private :: NIP = & + int([ & + 1, & + 3, & + 4, & + 9, & + 1, & + 4, & + 6, & + 1, & + 8, & + 27 & + ],pInt) !< number of IPs in a specific geometry type + + !integer(pInt), dimension(maxval(geomType)), parameter, private :: CELLTYPE = & ! Intel 16.0 complains + integer(pInt), dimension(10), parameter, private :: CELLTYPE = & !< cell type that is used by each geometry type + int([ & + 1, & ! 2D 3node + 2, & ! 2D 4node + 2, & ! 2D 4node + 2, & ! 2D 4node + 3, & ! 3D 4node + 4, & ! 3D 8node + 4, & ! 3D 8node + 4, & ! 3D 8node + 4, & ! 3D 8node + 4 & ! 3D 8node + ],pInt) + + !integer(pInt), dimension(maxval(cellType)), parameter, private :: nIPNeighbor = & ! causes problem with Intel 16.0 + integer(pInt), dimension(4), parameter, private :: NIPNEIGHBOR = & !< number of ip neighbors / cell faces in a specific cell type + int([& + 3, & ! 2D 3node + 4, & ! 2D 4node + 4, & ! 3D 4node + 6 & ! 3D 8node + ],pInt) + + !integer(pInt), dimension(maxval(cellType)), parameter, private :: NCELLNODESPERCELLFACE = & + integer(pInt), dimension(4), parameter, private :: NCELLNODEPERCELLFACE = & !< number of cell nodes in a specific cell type + int([ & + 2, & ! 2D 3node + 2, & ! 2D 4node + 3, & ! 3D 4node + 4 & ! 3D 8node + ],pInt) + + !integer(pInt), dimension(maxval(geomType)), parameter, private :: maxNodeAtIP = & ! causes problem with Intel 16.0 + integer(pInt), dimension(10), parameter, private :: maxNnodeAtIP = & !< maximum number of parent nodes that belong to an IP for a specific type of element + int([ & + 3, & + 1, & + 1, & + 2, & + 4, & + 1, & + 1, & + 8, & + 1, & + 4 & + ],pInt) + + + !integer(pInt), dimension(maxval(CELLTYPE)), parameter, private :: NCELLNODEPERCELL = & ! Intel 16.0 complains + integer(pInt), dimension(4), parameter, private :: NCELLNODEPERCELL = & !< number of cell nodes in a specific cell type + int([ & + 3, & ! 2D 3node + 4, & ! 2D 4node + 4, & ! 3D 4node + 8 & ! 3D 8node + ],pInt) + + integer(pInt), dimension(maxNnodeAtIP(1),nIP(1)), parameter, private :: NnodeAtIP1 = & + reshape(int([& + 1,2,3 & + ],pInt),[maxNnodeAtIP(1),nIP(1)]) + + integer(pInt), dimension(maxNnodeAtIP(2),nIP(2)), parameter, private :: NnodeAtIP2 = & + reshape(int([& + 1, & + 2, & + 3 & + ],pInt),[maxNnodeAtIP(2),nIP(2)]) + + integer(pInt), dimension(maxNnodeAtIP(3),nIP(3)), parameter, private :: NnodeAtIP3 = & + reshape(int([& + 1, & + 2, & + 4, & + 3 & + ],pInt),[maxNnodeAtIP(3),nIP(3)]) + + integer(pInt), dimension(maxNnodeAtIP(4),nIP(4)), parameter, private :: NnodeAtIP4 = & + reshape(int([& + 1,0, & + 1,2, & + 2,0, & + 1,4, & + 0,0, & + 2,3, & + 4,0, & + 3,4, & + 3,0 & + ],pInt),[maxNnodeAtIP(4),nIP(4)]) + + integer(pInt), dimension(maxNnodeAtIP(5),nIP(5)), parameter, private :: NnodeAtIP5 = & + reshape(int([& + 1,2,3,4 & + ],pInt),[maxNnodeAtIP(5),nIP(5)]) + + integer(pInt), dimension(maxNnodeAtIP(6),nIP(6)), parameter, private :: NnodeAtIP6 = & + reshape(int([& + 1, & + 2, & + 3, & + 4 & + ],pInt),[maxNnodeAtIP(6),nIP(6)]) + + integer(pInt), dimension(maxNnodeAtIP(7),nIP(7)), parameter, private :: NnodeAtIP7 = & + reshape(int([& + 1, & + 2, & + 3, & + 4, & + 5, & + 6 & + ],pInt),[maxNnodeAtIP(7),nIP(7)]) + + integer(pInt), dimension(maxNnodeAtIP(8),nIP(8)), parameter, private :: NnodeAtIP8 = & + reshape(int([& + 1,2,3,4,5,6,7,8 & + ],pInt),[maxNnodeAtIP(8),nIP(8)]) + + integer(pInt), dimension(maxNnodeAtIP(9),nIP(9)), parameter, private :: NnodeAtIP9 = & + reshape(int([& + 1, & + 2, & + 4, & + 3, & + 5, & + 6, & + 8, & + 7 & + ],pInt),[maxNnodeAtIP(9),nIP(9)]) + + integer(pInt), dimension(maxNnodeAtIP(10),nIP(10)), parameter, private :: NnodeAtIP10 = & + reshape(int([& + 1,0, 0,0, & + 1,2, 0,0, & + 2,0, 0,0, & + 1,4, 0,0, & + 1,3, 2,4, & + 2,3, 0,0, & + 4,0, 0,0, & + 3,4, 0,0, & + 3,0, 0,0, & + 1,5, 0,0, & + 1,6, 2,5, & + 2,6, 0,0, & + 1,8, 4,5, & + 0,0, 0,0, & + 2,7, 3,6, & + 4,8, 0,0, & + 3,8, 4,7, & + 3,7, 0,0, & + 5,0, 0,0, & + 5,6, 0,0, & + 6,0, 0,0, & + 5,8, 0,0, & + 5,7, 6,8, & + 6,7, 0,0, & + 8,0, 0,0, & + 7,8, 0,0, & + 7,0, 0,0 & + ],pInt),[maxNnodeAtIP(10),nIP(10)]) + + ! *** FE_ipNeighbor *** + ! is a list of the neighborhood of each IP. + ! It is sorted in (local) +x,-x, +y,-y, +z,-z direction. + ! Positive integers denote an intra-FE IP identifier. + ! Negative integers denote the interface behind which the neighboring (extra-FE) IP will be located. + + + integer(pInt), dimension(nIPneighbor(cellType(1)),nIP(1)), parameter, private :: IPneighbor1 = & + reshape(int([& + -2,-3,-1 & + ],pInt),[nIPneighbor(cellType(1)),nIP(1)]) + + integer(pInt), dimension(nIPneighbor(cellType(2)),nIP(2)), parameter, private :: IPneighbor2 = & + reshape(int([& + 2,-3, 3,-1, & + -2, 1, 3,-1, & + 2,-3,-2, 1 & + ],pInt),[nIPneighbor(cellType(2)),nIP(2)]) + + integer(pInt), dimension(nIPneighbor(cellType(3)),nIP(3)), parameter, private :: IPneighbor3 = & + reshape(int([& + 2,-4, 3,-1, & + -2, 1, 4,-1, & + 4,-4,-3, 1, & + -2, 3,-3, 2 & + ],pInt),[nIPneighbor(cellType(3)),nIP(3)]) + + integer(pInt), dimension(nIPneighbor(cellType(4)),nIP(4)), parameter, private :: IPneighbor4 = & + reshape(int([& + 2,-4, 4,-1, & + 3, 1, 5,-1, & + -2, 2, 6,-1, & + 5,-4, 7, 1, & + 6, 4, 8, 2, & + -2, 5, 9, 3, & + 8,-4,-3, 4, & + 9, 7,-3, 5, & + -2, 8,-3, 6 & + ],pInt),[nIPneighbor(cellType(4)),nIP(4)]) + + integer(pInt), dimension(nIPneighbor(cellType(5)),nIP(5)), parameter, private :: IPneighbor5 = & + reshape(int([& + -1,-2,-3,-4 & + ],pInt),[nIPneighbor(cellType(5)),nIP(5)]) + + integer(pInt), dimension(nIPneighbor(cellType(6)),nIP(6)), parameter, private :: IPneighbor6 = & + reshape(int([& + 2,-4, 3,-2, 4,-1, & + -2, 1, 3,-2, 4,-1, & + 2,-4,-3, 1, 4,-1, & + 2,-4, 3,-2,-3, 1 & + ],pInt),[nIPneighbor(cellType(6)),nIP(6)]) + + integer(pInt), dimension(nIPneighbor(cellType(7)),nIP(7)), parameter, private :: IPneighbor7 = & + reshape(int([& + 2,-4, 3,-2, 4,-1, & + -3, 1, 3,-2, 5,-1, & + 2,-4,-3, 1, 6,-1, & + 5,-4, 6,-2,-5, 1, & + -3, 4, 6,-2,-5, 2, & + 5,-4,-3, 4,-5, 3 & + ],pInt),[nIPneighbor(cellType(7)),nIP(7)]) + + integer(pInt), dimension(nIPneighbor(cellType(8)),nIP(8)), parameter, private :: IPneighbor8 = & + reshape(int([& + -3,-5,-4,-2,-6,-1 & + ],pInt),[nIPneighbor(cellType(8)),nIP(8)]) + + integer(pInt), dimension(nIPneighbor(cellType(9)),nIP(9)), parameter, private :: IPneighbor9 = & + reshape(int([& + 2,-5, 3,-2, 5,-1, & + -3, 1, 4,-2, 6,-1, & + 4,-5,-4, 1, 7,-1, & + -3, 3,-4, 2, 8,-1, & + 6,-5, 7,-2,-6, 1, & + -3, 5, 8,-2,-6, 2, & + 8,-5,-4, 5,-6, 3, & + -3, 7,-4, 6,-6, 4 & + ],pInt),[nIPneighbor(cellType(9)),nIP(9)]) + + integer(pInt), dimension(nIPneighbor(cellType(10)),nIP(10)), parameter, private :: IPneighbor10 = & + reshape(int([& + 2,-5, 4,-2,10,-1, & + 3, 1, 5,-2,11,-1, & + -3, 2, 6,-2,12,-1, & + 5,-5, 7, 1,13,-1, & + 6, 4, 8, 2,14,-1, & + -3, 5, 9, 3,15,-1, & + 8,-5,-4, 4,16,-1, & + 9, 7,-4, 5,17,-1, & + -3, 8,-4, 6,18,-1, & + 11,-5,13,-2,19, 1, & + 12,10,14,-2,20, 2, & + -3,11,15,-2,21, 3, & + 14,-5,16,10,22, 4, & + 15,13,17,11,23, 5, & + -3,14,18,12,24, 6, & + 17,-5,-4,13,25, 7, & + 18,16,-4,14,26, 8, & + -3,17,-4,15,27, 9, & + 20,-5,22,-2,-6,10, & + 21,19,23,-2,-6,11, & + -3,20,24,-2,-6,12, & + 23,-5,25,19,-6,13, & + 24,22,26,20,-6,14, & + -3,23,27,21,-6,15, & + 26,-5,-4,22,-6,16, & + 27,25,-4,23,-6,17, & + -3,26,-4,24,-6,18 & + ],pInt),[nIPneighbor(cellType(10)),nIP(10)]) + + + real(pReal), dimension(nNode(1),NcellNode(geomType(1))), parameter :: cellNodeParentNodeWeights1 = & + reshape(real([& + 1, 0, 0, & + 0, 1, 0, & + 0, 0, 1 & + ],pReal),[nNode(1),NcellNode(geomType(1))]) ! 2D 3node 1ip + + real(pReal), dimension(nNode(2),NcellNode(geomType(2))), parameter :: cellNodeParentNodeWeights2 = & + reshape(real([& + 1, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, & + 0, 0, 0, 0, 1, 0, & + 0, 0, 0, 0, 0, 1, & + 1, 1, 1, 2, 2, 2 & + ],pReal),[nNode(2),NcellNode(geomType(2))]) ! 2D 6node 3ip + + real(pReal), dimension(nNode(3),NcellNode(geomType(3))), parameter :: cellNodeParentNodeWeights3 = & + reshape(real([& + 1, 0, 0, 0, & + 0, 1, 0, 0, & + 0, 0, 1, 0, & + 0, 0, 0, 1, & + 1, 1, 0, 0, & + 0, 1, 1, 0, & + 0, 0, 1, 1, & + 1, 0, 0, 1, & + 1, 1, 1, 1 & + ],pReal),[nNode(3),NcellNode(geomType(3))]) ! 2D 6node 3ip + + real(pReal), dimension(nNode(4),NcellNode(geomType(4))), parameter :: cellNodeParentNodeWeights4 = & + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, 0, 0, & + 1, 0, 0, 0, 2, 0, 0, 0, & + 0, 1, 0, 0, 2, 0, 0, 0, & + 0, 1, 0, 0, 0, 2, 0, 0, & + 0, 0, 1, 0, 0, 2, 0, 0, & + 0, 0, 1, 0, 0, 0, 2, 0, & + 0, 0, 0, 1, 0, 0, 2, 0, & + 0, 0, 0, 1, 0, 0, 0, 2, & + 1, 0, 0, 0, 0, 0, 0, 2, & + 4, 1, 1, 1, 8, 2, 2, 8, & + 1, 4, 1, 1, 8, 8, 2, 2, & + 1, 1, 4, 1, 2, 8, 8, 2, & + 1, 1, 1, 4, 2, 2, 8, 8 & + ],pReal),[nNode(4),NcellNode(geomType(4))]) ! 2D 8node 9ip + + real(pReal), dimension(nNode(5),NcellNode(geomType(5))), parameter :: cellNodeParentNodeWeights5 = & + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, 0, 0, & + 0, 0, 0, 0, 1, 0, 0, 0, & + 0, 0, 0, 0, 0, 1, 0, 0, & + 0, 0, 0, 0, 0, 0, 1, 0, & + 0, 0, 0, 0, 0, 0, 0, 1, & + 1, 1, 1, 1, 2, 2, 2, 2 & + ],pReal),[nNode(5),NcellNode(geomType(5))]) ! 2D 8node 4ip + + real(pReal), dimension(nNode(6),NcellNode(geomType(6))), parameter :: cellNodeParentNodeWeights6 = & + reshape(real([& + 1, 0, 0, 0, & + 0, 1, 0, 0, & + 0, 0, 1, 0, & + 0, 0, 0, 1 & + ],pReal),[nNode(6),NcellNode(geomType(6))]) ! 3D 4node 1ip + + real(pReal), dimension(nNode(7),NcellNode(geomType(7))), parameter :: cellNodeParentNodeWeights7 = & + reshape(real([& + 1, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, & + 0, 0, 1, 0, 0, & + 0, 0, 0, 1, 0, & + 1, 1, 0, 0, 0, & + 0, 1, 1, 0, 0, & + 1, 0, 1, 0, 0, & + 1, 0, 0, 1, 0, & + 0, 1, 0, 1, 0, & + 0, 0, 1, 1, 0, & + 1, 1, 1, 0, 0, & + 1, 1, 0, 1, 0, & + 0, 1, 1, 1, 0, & + 1, 0, 1, 1, 0, & + 0, 0, 0, 0, 1 & + ],pReal),[nNode(7),NcellNode(geomType(7))]) ! 3D 5node 4ip + + real(pReal), dimension(nNode(8),NcellNode(geomType(8))), parameter :: cellNodeParentNodeWeights8 = & + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, & + 1, 1, 1, 0, 2, 2, 2, 0, 0, 0, & + 1, 1, 0, 1, 2, 0, 0, 2, 2, 0, & + 0, 1, 1, 1, 0, 2, 0, 0, 2, 2, & + 1, 0, 1, 1, 0, 0, 2, 2, 0, 2, & + 3, 3, 3, 3, 4, 4, 4, 4, 4, 4 & + ],pReal),[nNode(8),NcellNode(geomType(8))]) ! 3D 10node 4ip + + real(pReal), dimension(nNode(9),NcellNode(geomType(9))), parameter :: cellNodeParentNodeWeights9 = & + reshape(real([& + 1, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, & + 0, 0, 0, 0, 1, 0, & + 0, 0, 0, 0, 0, 1, & + 1, 1, 0, 0, 0, 0, & + 0, 1, 1, 0, 0, 0, & + 1, 0, 1, 0, 0, 0, & + 1, 0, 0, 1, 0, 0, & + 0, 1, 0, 0, 1, 0, & + 0, 0, 1, 0, 0, 1, & + 0, 0, 0, 1, 1, 0, & + 0, 0, 0, 0, 1, 1, & + 0, 0, 0, 1, 0, 1, & + 1, 1, 1, 0, 0, 0, & + 1, 1, 0, 1, 1, 0, & + 0, 1, 1, 0, 1, 1, & + 1, 0, 1, 1, 0, 1, & + 0, 0, 0, 1, 1, 1, & + 1, 1, 1, 1, 1, 1 & + ],pReal),[nNode(9),NcellNode(geomType(9))]) ! 3D 6node 6ip + + real(pReal), dimension(nNode(10),NcellNode(geomType(10))), parameter :: cellNodeParentNodeWeights10 = & + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, 0, 0, & + 0, 0, 0, 0, 1, 0, 0, 0, & + 0, 0, 0, 0, 0, 1, 0, 0, & + 0, 0, 0, 0, 0, 0, 1, 0, & + 0, 0, 0, 0, 0, 0, 0, 1 & + ],pReal),[nNode(10),NcellNode(geomType(10))]) ! 3D 8node 1ip + + real(pReal), dimension(nNode(11),NcellNode(geomType(11))), parameter :: cellNodeParentNodeWeights11 = & + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 0, 0, 0, & ! 5 + 0, 0, 0, 0, 0, 1, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 1, & ! + 1, 1, 0, 0, 0, 0, 0, 0, & ! + 0, 1, 1, 0, 0, 0, 0, 0, & ! 10 + 0, 0, 1, 1, 0, 0, 0, 0, & ! + 1, 0, 0, 1, 0, 0, 0, 0, & ! + 1, 0, 0, 0, 1, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 1, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 1, 0, & ! 15 + 0, 0, 0, 1, 0, 0, 0, 1, & ! + 0, 0, 0, 0, 1, 1, 0, 0, & ! + 0, 0, 0, 0, 0, 1, 1, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 1, & ! + 0, 0, 0, 0, 1, 0, 0, 1, & ! 20 + 1, 1, 1, 1, 0, 0, 0, 0, & ! + 1, 1, 0, 0, 1, 1, 0, 0, & ! + 0, 1, 1, 0, 0, 1, 1, 0, & ! + 0, 0, 1, 1, 0, 0, 1, 1, & ! + 1, 0, 0, 1, 1, 0, 0, 1, & ! 25 + 0, 0, 0, 0, 1, 1, 1, 1, & ! + 1, 1, 1, 1, 1, 1, 1, 1 & ! + ],pReal),[nNode(11),NcellNode(geomType(11))]) ! 3D 8node 8ip + + real(pReal), dimension(nNode(12),NcellNode(geomType(12))), parameter :: cellNodeParentNodeWeights12 = & + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! 5 + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! 10 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, & ! 15 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, & ! 20 + 1, 1, 1, 1, 0, 0, 0, 0, 2, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 1, 1, 0, 0, 1, 1, 0, 0, 2, 0, 0, 0, 2, 0, 0, 0, 2, 2, 0, 0, & ! + 0, 1, 1, 0, 0, 1, 1, 0, 0, 2, 0, 0, 0, 2, 0, 0, 0, 2, 2, 0, & ! + 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 2, 0, 0, 0, 2, 0, 0, 0, 2, 2, & ! + 1, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 2, 0, 0, 0, 2, 2, 0, 0, 2, & ! 25 + 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 2, 2, 2, 2, 0, 0, 0, 0, & ! + 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 & ! + ],pReal),[nNode(12),NcellNode(geomType(12))]) ! 3D 20node 8ip + + real(pReal), dimension(nNode(13),NcellNode(geomType(13))), parameter :: cellNodeParentNodeWeights13 = & + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! 5 + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! 10 + 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, & ! 15 + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, & ! 20 + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, & ! + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, & ! 25 + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, & ! 30 + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, & ! + 4, 1, 1, 1, 0, 0, 0, 0, 8, 2, 2, 8, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 1, 4, 1, 1, 0, 0, 0, 0, 8, 8, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 1, 1, 4, 1, 0, 0, 0, 0, 2, 8, 8, 2, 0, 0, 0, 0, 0, 0, 0, 0, & ! 35 + 1, 1, 1, 4, 0, 0, 0, 0, 2, 2, 8, 8, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 4, 1, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 8, 2, 0, 0, & ! + 1, 4, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 2, 8, 0, 0, & ! + 0, 4, 1, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 8, 2, 0, & ! + 0, 1, 4, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 2, 8, 0, & ! 40 + 0, 0, 4, 1, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 8, 2, & ! + 0, 0, 1, 4, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 2, 8, & ! + 1, 0, 0, 4, 1, 0, 0, 1, 0, 0, 0, 8, 0, 0, 0, 2, 2, 0, 0, 8, & ! + 4, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 8, 0, 0, 0, 2, 8, 0, 0, 2, & ! + 1, 1, 0, 0, 4, 1, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 8, 2, 0, 0, & ! 45 + 1, 1, 0, 0, 1, 4, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 2, 8, 0, 0, & ! + 0, 1, 1, 0, 0, 4, 1, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 8, 2, 0, & ! + 0, 1, 1, 0, 0, 1, 4, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 2, 8, 0, & ! + 0, 0, 1, 1, 0, 0, 4, 1, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 8, 2, & ! + 0, 0, 1, 1, 0, 0, 1, 4, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 2, 8, & ! 50 + 1, 0, 0, 1, 1, 0, 0, 4, 0, 0, 0, 2, 0, 0, 0, 8, 2, 0, 0, 8, & ! + 1, 0, 0, 1, 4, 0, 0, 1, 0, 0, 0, 2, 0, 0, 0, 8, 8, 0, 0, 2, & ! + 0, 0, 0, 0, 4, 1, 1, 1, 0, 0, 0, 0, 8, 2, 2, 8, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 4, 1, 1, 0, 0, 0, 0, 8, 8, 2, 2, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 1, 4, 1, 0, 0, 0, 0, 2, 8, 8, 2, 0, 0, 0, 0, & ! 55 + 0, 0, 0, 0, 1, 1, 1, 4, 0, 0, 0, 0, 2, 2, 8, 8, 0, 0, 0, 0, & ! + 24, 8, 4, 8, 8, 4, 3, 4, 32,12,12,32, 12, 4, 4,12, 32,12, 4,12, & ! + 8,24, 8, 4, 4, 8, 4, 3, 32,32,12,12, 12,12, 4, 4, 12,32,12, 4, & ! + 4, 8,24, 8, 3, 4, 8, 4, 12,32,32,12, 4,12,12, 4, 4,12,32,12, & ! + 8, 4, 8,24, 4, 3, 4, 8, 12,12,32,32, 4, 4,12,12, 12, 4,12,32, & ! 60 + 8, 4, 3, 4, 24, 8, 4, 8, 12, 4, 4,12, 32,12,12,32, 32,12, 4,12, & ! + 4, 8, 4, 3, 8,24, 8, 4, 12,12, 4, 4, 32,32,12,12, 12,32,12, 4, & ! + 3, 4, 8, 4, 4, 8,24, 8, 4,12,12, 4, 12,32,32,12, 4,12,32,12, & ! + 4, 3, 4, 8, 8, 4, 8,24, 4, 4,12,12, 12,12,32,32, 12, 4,12,32 & ! + ],pReal),[nNode(13),NcellNode(geomType(13))]) ! 3D 20node 27ip + + + integer(pInt), dimension(NCELLNODEPERCELL(CELLTYPE(1)),NIP(1)), parameter :: CELL1 = & + reshape(int([& + 1,2,3 & + ],pInt),[NCELLNODEPERCELL(CELLTYPE(1)),NIP(1)]) + + integer(pInt), dimension(NCELLNODEPERCELL(CELLTYPE(2)),NIP(2)), parameter :: CELL2 = & + reshape(int([& + 1, 4, 7, 6, & + 2, 5, 7, 4, & + 3, 6, 7, 5 & + ],pInt),[NCELLNODEPERCELL(CELLTYPE(2)),NIP(2)]) + + integer(pInt), dimension(NCELLNODEPERCELL(CELLTYPE(3)),NIP(3)), parameter :: CELL3 = & + reshape(int([& + 1, 5, 9, 8, & + 5, 2, 6, 9, & + 8, 9, 7, 4, & + 9, 6, 3, 7 & + ],pInt),[NCELLNODEPERCELL(CELLTYPE(3)),NIP(3)]) + + integer(pInt), dimension(NCELLNODEPERCELL(CELLTYPE(4)),NIP(4)), parameter :: CELL4 = & + reshape(int([& + 1, 5,13,12, & + 5, 6,14,13, & + 6, 2, 7,14, & + 12,13,16,11, & + 13,14,15,16, & + 14, 7, 8,15, & + 11,16,10, 4, & + 16,15, 9,10, & + 15, 8, 3, 9 & + ],pInt),[NCELLNODEPERCELL(CELLTYPE(4)),NIP(4)]) + + integer(pInt), dimension(NCELLNODEPERCELL(CELLTYPE(5)),NIP(5)), parameter :: CELL5 = & + reshape(int([& + 1, 2, 3, 4 & + ],pInt),[NCELLNODEPERCELL(CELLTYPE(5)),NIP(5)]) + + integer(pInt), dimension(NCELLNODEPERCELL(CELLTYPE(6)),NIP(6)), parameter :: CELL6 = & + reshape(int([& + 1, 5,11, 7, 8,12,15,14, & + 5, 2, 6,11,12, 9,13,15, & + 7,11, 6, 3,14,15,13,10, & + 8,12,15, 4, 4, 9,13,10 & + ],pInt),[NCELLNODEPERCELL(CELLTYPE(6)),NIP(6)]) + + integer(pInt), dimension(NCELLNODEPERCELL(CELLTYPE(7)),NIP(7)), parameter :: CELL7 = & + reshape(int([& + 1, 7,16, 9,10,17,21,19, & + 7, 2, 8,16,17,11,18,21, & + 9,16, 8, 3,19,21,18,12, & + 10,17,21,19, 4,13,20,15, & + 17,11,18,21,13, 5,14,20, & + 19,21,18,12,15,20,14, 6 & + ],pInt),[NCELLNODEPERCELL(CELLTYPE(7)),NIP(7)]) + + integer(pInt), dimension(NCELLNODEPERCELL(CELLTYPE(8)),NIP(8)), parameter :: CELL8 = & + reshape(int([& + 1, 2, 3, 4, 5, 6, 7, 8 & + ],pInt),[NCELLNODEPERCELL(CELLTYPE(8)),NIP(8)]) + + integer(pInt), dimension(NCELLNODEPERCELL(CELLTYPE(9)),NIP(9)), parameter :: CELL9 = & + reshape(int([& + 1, 9,21,12,13,22,27,25, & + 9, 2,10,21,22,14,23,27, & + 12,21,11, 4,25,27,24,16, & + 21,10, 3,11,27,23,15,24, & + 13,22,27,25, 5,17,26,20, & + 22,14,23,27,17, 6,18,26, & + 25,27,24,16,20,26,19, 8, & + 27,23,15,24,26,18, 7,19 & + ],pInt),[NCELLNODEPERCELL(CELLTYPE(9)),NIP(9)]) + + integer(pInt), dimension(NCELLNODEPERCELL(CELLTYPE(10)),NIP(10)), parameter :: CELL10 = & + reshape(int([& + 1, 9,33,16,17,37,57,44, & + 9,10,34,33,37,38,58,57, & + 10, 2,11,34,38,18,39,58, & + 16,33,36,15,44,57,60,43, & + 33,34,35,36,57,58,59,60, & + 34,11,12,35,58,39,40,59, & + 15,36,14, 4,43,60,42,20, & + 36,35,13,14,60,59,41,42, & + 35,12, 3,13,59,40,19,41, & + 17,37,57,44,21,45,61,52, & + 37,38,58,57,45,46,62,61, & + 38,18,39,58,46,22,47,62, & + 44,57,60,43,52,61,64,51, & + 57,58,59,60,61,62,63,64, & + 58,39,40,59,62,47,48,63, & + 43,60,42,20,51,64,50,24, & + 60,59,41,42,64,63,49,50, & + 59,40,19,41,63,48,23,49, & + 21,45,61,52, 5,25,53,32, & + 45,46,62,61,25,26,54,53, & + 46,22,47,62,26, 6,27,54, & + 52,61,64,51,32,53,56,31, & + 61,62,63,64,53,54,55,56, & + 62,47,48,63,54,27,28,55, & + 51,64,50,24,31,56,30, 8, & + 64,63,49,50,56,55,29,30, & + 63,48,23,49,55,28, 7,29 & + ],pInt),[NCELLNODEPERCELL(CELLTYPE(10)),NIP(10)]) + + + integer(pInt), dimension(NCELLNODEPERCELLFACE(1),NIPNEIGHBOR(1)), parameter :: CELLFACE1 = & + reshape(int([& + 2,3, & + 3,1, & + 1,2 & + ],pInt),[NCELLNODEPERCELLFACE(1),NIPNEIGHBOR(1)]) ! 2D 3node, VTK_TRIANGLE (5) + + integer(pInt), dimension(NCELLNODEPERCELLFACE(2),NIPNEIGHBOR(2)), parameter :: CELLFACE2 = & + reshape(int([& + 2,3, & + 4,1, & + 3,4, & + 1,2 & + ],pInt),[NCELLNODEPERCELLFACE(2),NIPNEIGHBOR(2)]) ! 2D 4node, VTK_QUAD (9) + + integer(pInt), dimension(NCELLNODEPERCELLFACE(3),NIPNEIGHBOR(3)), parameter :: CELLFACE3 = & + reshape(int([& + 1,3,2, & + 1,2,4, & + 2,3,4, & + 1,4,3 & + ],pInt),[NCELLNODEPERCELLFACE(3),NIPNEIGHBOR(3)]) ! 3D 4node, VTK_TETRA (10) + + integer(pInt), dimension(NCELLNODEPERCELLFACE(4),NIPNEIGHBOR(4)), parameter :: CELLFACE4 = & + reshape(int([& + 2,3,7,6, & + 4,1,5,8, & + 3,4,8,7, & + 1,2,6,5, & + 5,6,7,8, & + 1,4,3,2 & + ],pInt),[NCELLNODEPERCELLFACE(4),NIPNEIGHBOR(4)]) ! 3D 8node, VTK_HEXAHEDRON (12) + + +contains + + subroutine tElement_init(self,elemType) + implicit none + class(tElement) :: self + integer(pInt), intent(in) :: elemType + self%elemType = elemType + + self%Nnodes = Nnode (self%elemType) + self%geomType = geomType (self%elemType) + select case (self%elemType) + case(1_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights1 + case(2_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights2 + case(3_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights3 + case(4_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights4 + case(5_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights5 + case(6_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights6 + case(7_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights7 + case(8_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights8 + case(9_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights9 + case(10_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights10 + case(11_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights11 + case(12_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights12 + case(13_pInt) + self%cellNodeParentNodeWeights = cellNodeParentNodeWeights13 + case default + print*, 'Mist' + end select + + + self%NcellNodes = NcellNode (self%geomType) + self%maxNnodeAtIP = maxNnodeAtIP (self%geomType) + self%nIPs = nIP (self%geomType) + self%cellType = cellType (self%geomType) + + + select case (self%geomType) + case(1_pInt) + self%NnodeAtIP = NnodeAtIP1 + self%IPneighbor = IPneighbor1 + self%cell = CELL1 + case(2_pInt) + self%NnodeAtIP = NnodeAtIP2 + self%IPneighbor = IPneighbor2 + self%cell = CELL2 + case(3_pInt) + self%NnodeAtIP = NnodeAtIP3 + self%IPneighbor = IPneighbor3 + self%cell = CELL3 + case(4_pInt) + self%NnodeAtIP = NnodeAtIP4 + self%IPneighbor = IPneighbor4 + self%cell = CELL4 + case(5_pInt) + self%NnodeAtIP = NnodeAtIP5 + self%IPneighbor = IPneighbor5 + self%cell = CELL5 + case(6_pInt) + self%NnodeAtIP = NnodeAtIP6 + self%IPneighbor = IPneighbor6 + self%cell = CELL6 + case(7_pInt) + self%NnodeAtIP = NnodeAtIP7 + self%IPneighbor = IPneighbor7 + self%cell = CELL7 + case(8_pInt) + self%NnodeAtIP = NnodeAtIP8 + self%IPneighbor = IPneighbor8 + self%cell = CELL8 + case(9_pInt) + self%NnodeAtIP = NnodeAtIP9 + self%IPneighbor = IPneighbor9 + self%cell = CELL9 + case(10_pInt) + self%NnodeAtIP = NnodeAtIP10 + self%IPneighbor = IPneighbor10 + self%cell = CELL10 + end select + self%NcellNodesPerCell = NCELLNODEPERCELL(self%cellType) + + select case(self%cellType) + case(1_pInt) + self%cellFace = CELLFACE1 + case(2_pInt) + self%cellFace = CELLFACE2 + case(3_pInt) + self%cellFace = CELLFACE3 + case(4_pInt) + self%cellFace = CELLFACE4 + end select + + self%nIPneighbors = size(self%IPneighbor,1) + + write(6,'(/,a)') ' <<<+- element_init -+>>>' + + write(6,*)' element type ',self%elemType + write(6,*)' geom type ',self%geomType + write(6,*)' cell type ',self%cellType + write(6,*)' # node ',self%Nnodes + write(6,*)' # IP ',self%nIPs + write(6,*)' # cellnode ',self%Ncellnodes + write(6,*)' # cellnode/cell ',self%NcellnodesPerCell + write(6,*)' # IP neighbor ',self%nIPneighbors + write(6,*)' max # node at IP ',self%maxNnodeAtIP + + end subroutine tElement_init + +end module element diff --git a/src/homogenization.f90 b/src/homogenization.f90 index ac41158a1..8edecbc88 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -71,11 +71,8 @@ subroutine homogenization_init debug_e, & debug_g use mesh, only: & - mesh_maxNips, & - mesh_NcpElems, & - mesh_element, & - FE_Nips, & - FE_geomtype + theMesh, & + mesh_element use constitutive, only: & constitutive_plasticity_maxSizePostResults, & constitutive_source_maxSizePostResults @@ -244,20 +241,20 @@ subroutine homogenization_init !-------------------------------------------------------------------------------------------------- ! allocate and initialize global variables - allocate(materialpoint_dPdF(3,3,3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) - allocate(materialpoint_F0(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) - materialpoint_F0 = spread(spread(math_I3,3,mesh_maxNips),4,mesh_NcpElems) ! initialize to identity - allocate(materialpoint_F(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(materialpoint_dPdF(3,3,3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + allocate(materialpoint_F0(3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + materialpoint_F0 = spread(spread(math_I3,3,theMesh%elem%nIPs),4,theMesh%nElems) ! initialize to identity + allocate(materialpoint_F(3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) materialpoint_F = materialpoint_F0 ! initialize to identity - allocate(materialpoint_subF0(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) - allocate(materialpoint_subF(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) - allocate(materialpoint_P(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) - allocate(materialpoint_subFrac(mesh_maxNips,mesh_NcpElems), source=0.0_pReal) - allocate(materialpoint_subStep(mesh_maxNips,mesh_NcpElems), source=0.0_pReal) - allocate(materialpoint_subdt(mesh_maxNips,mesh_NcpElems), source=0.0_pReal) - allocate(materialpoint_requested(mesh_maxNips,mesh_NcpElems), source=.false.) - allocate(materialpoint_converged(mesh_maxNips,mesh_NcpElems), source=.true.) - allocate(materialpoint_doneAndHappy(2,mesh_maxNips,mesh_NcpElems), source=.true.) + allocate(materialpoint_subF0(3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + allocate(materialpoint_subF(3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + allocate(materialpoint_P(3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + allocate(materialpoint_subFrac(theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + allocate(materialpoint_subStep(theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + allocate(materialpoint_subdt(theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + allocate(materialpoint_requested(theMesh%elem%nIPs,theMesh%nElems), source=.false.) + allocate(materialpoint_converged(theMesh%elem%nIPs,theMesh%nElems), source=.true.) + allocate(materialpoint_doneAndHappy(2,theMesh%elem%nIPs,theMesh%nElems), source=.true.) !-------------------------------------------------------------------------------------------------- ! allocate and initialize global state and postresutls variables @@ -277,7 +274,7 @@ subroutine homogenization_init + homogenization_maxNgrains * (1 + crystallite_maxSizePostResults & ! crystallite size & crystallite results + 1 + constitutive_plasticity_maxSizePostResults & ! constitutive size & constitutive results + constitutive_source_maxSizePostResults) - allocate(materialpoint_results(materialpoint_sizeResults,mesh_maxNips,mesh_NcpElems)) + allocate(materialpoint_results(materialpoint_sizeResults,theMesh%elem%nIPs,theMesh%nElems)) write(6,'(/,a)') ' <<<+- homogenization init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() @@ -346,7 +343,6 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) crystallite_Lp, & crystallite_Li0, & crystallite_Li, & - crystallite_dPdF, & crystallite_Tstar0_v, & crystallite_Tstar_v, & crystallite_partionedF0, & @@ -600,7 +596,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) IpLooping2: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) if ( materialpoint_requested(i,e) .and. & ! process requested but... .not. materialpoint_doneAndHappy(1,i,e)) then ! ...not yet done material points - call partitionDeformation(i,e) ! partition deformation onto constituents + call partitionDeformation(i,e) ! partition deformation onto constituents crystallite_dt(1:myNgrains,i,e) = materialpoint_subdt(i,e) ! propagate materialpoint dt to grains crystallite_requested(1:myNgrains,i,e) = .true. ! request calculation for constituents else @@ -614,7 +610,8 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) ! crystallite integration ! based on crystallite_partionedF0,.._partionedF ! incrementing by crystallite_dt - materialpoint_converged = crystallite_stress() !ToDo: MD not sure if that is the best logic + + materialpoint_converged = crystallite_stress() !ToDo: MD not sure if that is the best logic !-------------------------------------------------------------------------------------------------- ! state update diff --git a/src/kinematics_cleavage_opening.f90 b/src/kinematics_cleavage_opening.f90 index 998b19562..7a3677ec1 100644 --- a/src/kinematics_cleavage_opening.f90 +++ b/src/kinematics_cleavage_opening.f90 @@ -11,20 +11,22 @@ module kinematics_cleavage_opening implicit none private - integer(pInt), dimension(:), allocatable, public, protected :: & - kinematics_cleavage_opening_sizePostResults, & !< cumulative size of post results - kinematics_cleavage_opening_offset, & !< which kinematics is my current damage mechanism? - kinematics_cleavage_opening_instance !< instance of damage kinematics mechanism + integer(pInt), dimension(:), allocatable, private :: kinematics_cleavage_opening_instance - integer(pInt), dimension(:,:), allocatable, target, public :: & - kinematics_cleavage_opening_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - kinematics_cleavage_opening_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - kinematics_cleavage_opening_Noutput !< number of outputs per instance of this damage + type, private :: tParameters !< container type for internal constitutive parameters + integer(pInt) :: & + totalNcleavage + integer(pInt), dimension(:), allocatable :: & + Ncleavage !< active number of cleavage systems per family + real(pReal) :: & + sdot0, & + n + real(pReal), dimension(:), allocatable :: & + critDisp, & + critLoad + end type +! Begin Deprecated integer(pInt), dimension(:), allocatable, private :: & kinematics_cleavage_opening_totalNcleavage !< total number of cleavage systems @@ -38,6 +40,7 @@ module kinematics_cleavage_opening real(pReal), dimension(:,:), allocatable, private :: & kinematics_cleavage_opening_critDisp, & kinematics_cleavage_opening_critLoad +! End Deprecated public :: & kinematics_cleavage_opening_init, & @@ -50,7 +53,7 @@ contains !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- -subroutine kinematics_cleavage_opening_init(fileUnit) +subroutine kinematics_cleavage_opening_init() #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 use, intrinsic :: iso_fortran_env, only: & compiler_version, & @@ -60,41 +63,25 @@ subroutine kinematics_cleavage_opening_init(fileUnit) debug_level,& debug_constitutive,& debug_levelBasic + use config, only: & + config_phase use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & IO_warning, & IO_error, & - IO_timeStamp, & - IO_EOF + IO_timeStamp use material, only: & phase_kinematics, & - phase_Nkinematics, & - phase_Noutput, & KINEMATICS_cleavage_opening_label, & KINEMATICS_cleavage_opening_ID - use config, only: & - material_Nphase, & - MATERIAL_partPhase use lattice, only: & lattice_maxNcleavageFamily, & lattice_NcleavageSystem implicit none - integer(pInt), intent(in) :: fileUnit + integer(pInt), allocatable, dimension(:) :: tempInt + real(pReal), allocatable, dimension(:) :: tempFloat - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,phase,instance,kinematics - integer(pInt) :: Nchunks_CleavageFamilies = 0_pInt, j - character(len=65536) :: & - tag = '', & - line = '' + integer(pInt) :: maxNinstance,p,instance,kinematics write(6,'(/,a)') ' <<<+- kinematics_'//KINEMATICS_cleavage_opening_LABEL//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() @@ -106,21 +93,11 @@ subroutine kinematics_cleavage_opening_init(fileUnit) if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - allocate(kinematics_cleavage_opening_offset(material_Nphase), source=0_pInt) - allocate(kinematics_cleavage_opening_instance(material_Nphase), source=0_pInt) - do phase = 1, material_Nphase - kinematics_cleavage_opening_instance(phase) = count(phase_kinematics(:,1:phase) == kinematics_cleavage_opening_ID) - do kinematics = 1, phase_Nkinematics(phase) - if (phase_kinematics(kinematics,phase) == kinematics_cleavage_opening_ID) & - kinematics_cleavage_opening_offset(phase) = kinematics - enddo + allocate(kinematics_cleavage_opening_instance(size(config_phase)), source=0_pInt) + do p = 1_pInt, size(config_phase) + kinematics_cleavage_opening_instance(p) = count(phase_kinematics(:,1:p) == kinematics_cleavage_opening_ID) ! ToDo: count correct? enddo - allocate(kinematics_cleavage_opening_sizePostResults(maxNinstance), source=0_pInt) - allocate(kinematics_cleavage_opening_sizePostResult(maxval(phase_Noutput),maxNinstance), source=0_pInt) - allocate(kinematics_cleavage_opening_output(maxval(phase_Noutput),maxNinstance)) - kinematics_cleavage_opening_output = '' - allocate(kinematics_cleavage_opening_Noutput(maxNinstance), source=0_pInt) allocate(kinematics_cleavage_opening_critDisp(lattice_maxNcleavageFamily,maxNinstance), source=0.0_pReal) allocate(kinematics_cleavage_opening_critLoad(lattice_maxNcleavageFamily,maxNinstance), source=0.0_pReal) allocate(kinematics_cleavage_opening_Ncleavage(lattice_maxNcleavageFamily,maxNinstance), source=0_pInt) @@ -128,90 +105,51 @@ subroutine kinematics_cleavage_opening_init(fileUnit) allocate(kinematics_cleavage_opening_sdot_0(maxNinstance), source=0.0_pReal) allocate(kinematics_cleavage_opening_N(maxNinstance), source=0.0_pReal) - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo - - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - if (phase > 0_pInt ) then; if (any(phase_kinematics(:,phase) == KINEMATICS_cleavage_opening_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - instance = kinematics_cleavage_opening_instance(phase) ! which instance of my damage is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('anisobrittle_sdot0') - kinematics_cleavage_opening_sdot_0(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('anisobrittle_ratesensitivity') - kinematics_cleavage_opening_N(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('ncleavage') ! - Nchunks_CleavageFamilies = chunkPos(1) - 1_pInt - do j = 1_pInt, Nchunks_CleavageFamilies - kinematics_cleavage_opening_Ncleavage(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) - enddo + do p = 1_pInt, size(config_phase) + if (all(phase_kinematics(:,p) /= KINEMATICS_cleavage_opening_ID)) cycle + instance = kinematics_cleavage_opening_instance(p) + kinematics_cleavage_opening_sdot_0(instance) = config_phase(p)%getFloat('anisobrittle_sdot0') + kinematics_cleavage_opening_N(instance) = config_phase(p)%getFloat('anisobrittle_ratesensitivity') + tempInt = config_phase(p)%getInts('ncleavage') + kinematics_cleavage_opening_Ncleavage(1:size(tempInt),instance) = tempInt - case ('anisobrittle_criticaldisplacement') - do j = 1_pInt, Nchunks_CleavageFamilies - kinematics_cleavage_opening_critDisp(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo + tempFloat = config_phase(p)%getFloats('anisobrittle_criticaldisplacement',requiredSize=size(tempInt)) + kinematics_cleavage_opening_critDisp(1:size(tempInt),instance) = tempFloat - case ('anisobrittle_criticalload') - do j = 1_pInt, Nchunks_CleavageFamilies - kinematics_cleavage_opening_critLoad(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo + tempFloat = config_phase(p)%getFloats('anisobrittle_criticalload',requiredSize=size(tempInt)) + kinematics_cleavage_opening_critLoad(1:size(tempInt),instance) = tempFloat - end select - endif; endif - enddo parsingFile - -!-------------------------------------------------------------------------------------------------- -! sanity checks - sanityChecks: do phase = 1_pInt, material_Nphase - myPhase: if (any(phase_kinematics(:,phase) == KINEMATICS_cleavage_opening_ID)) then - instance = kinematics_cleavage_opening_instance(phase) - kinematics_cleavage_opening_Ncleavage(1:lattice_maxNcleavageFamily,instance) = & - min(lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,phase),& ! limit active cleavage systems per family to min of available and requested + kinematics_cleavage_opening_Ncleavage(1:lattice_maxNcleavageFamily,instance) = & + min(lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,p),& ! limit active cleavage systems per family to min of available and requested kinematics_cleavage_opening_Ncleavage(1:lattice_maxNcleavageFamily,instance)) kinematics_cleavage_opening_totalNcleavage(instance) = sum(kinematics_cleavage_opening_Ncleavage(:,instance)) ! how many cleavage systems altogether if (kinematics_cleavage_opening_sdot_0(instance) <= 0.0_pReal) & call IO_error(211_pInt,el=instance,ext_msg='sdot_0 ('//KINEMATICS_cleavage_opening_LABEL//')') - if (any(kinematics_cleavage_opening_critDisp(1:Nchunks_CleavageFamilies,instance) < 0.0_pReal)) & + if (any(kinematics_cleavage_opening_critDisp(1:size(tempInt),instance) < 0.0_pReal)) & call IO_error(211_pInt,el=instance,ext_msg='critical_displacement ('//KINEMATICS_cleavage_opening_LABEL//')') - if (any(kinematics_cleavage_opening_critLoad(1:Nchunks_CleavageFamilies,instance) < 0.0_pReal)) & + if (any(kinematics_cleavage_opening_critLoad(1:size(tempInt),instance) < 0.0_pReal)) & call IO_error(211_pInt,el=instance,ext_msg='critical_load ('//KINEMATICS_cleavage_opening_LABEL//')') if (kinematics_cleavage_opening_N(instance) <= 0.0_pReal) & call IO_error(211_pInt,el=instance,ext_msg='rate_sensitivity ('//KINEMATICS_cleavage_opening_LABEL//')') - endif myPhase - enddo sanityChecks + enddo end subroutine kinematics_cleavage_opening_init !-------------------------------------------------------------------------------------------------- !> @brief contains the constitutive equation for calculating the velocity gradient !-------------------------------------------------------------------------------------------------- -subroutine kinematics_cleavage_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tstar_v, ipc, ip, el) +subroutine kinematics_cleavage_opening_LiAndItsTangent(Ld, dLd_dTstar, S, ipc, ip, el) use prec, only: & tol_math_check + use math, only: & + math_mul33xx33 use material, only: & - phaseAt, phasememberAt, & + material_phase, & material_homog, & damage, & damageMapping use lattice, only: & lattice_Scleavage, & - lattice_Scleavage_v, & lattice_maxNcleavageFamily, & lattice_NcleavageSystem @@ -220,36 +158,33 @@ subroutine kinematics_cleavage_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tstar ipc, & !< grain number ip, & !< integration point number el !< element number - real(pReal), intent(in), dimension(6) :: & - Tstar_v !< 2nd Piola-Kirchhoff stress + real(pReal), intent(in), dimension(3,3) :: & + S real(pReal), intent(out), dimension(3,3) :: & Ld !< damage velocity gradient real(pReal), intent(out), dimension(3,3,3,3) :: & - dLd_dTstar3333 !< derivative of Ld with respect to Tstar (4th-order tensor) + dLd_dTstar !< derivative of Ld with respect to Tstar (4th-order tensor) integer(pInt) :: & - phase, & - constituent, & - instance, & + instance, phase, & homog, damageOffset, & f, i, index_myFamily, k, l, m, n real(pReal) :: & traction_d, traction_t, traction_n, traction_crit, & udotd, dudotd_dt, udott, dudott_dt, udotn, dudotn_dt - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) + phase = material_phase(ipc,ip,el) instance = kinematics_cleavage_opening_instance(phase) homog = material_homog(ip,el) damageOffset = damageMapping(homog)%p(ip,el) Ld = 0.0_pReal - dLd_dTstar3333 = 0.0_pReal + dLd_dTstar = 0.0_pReal do f = 1_pInt,lattice_maxNcleavageFamily index_myFamily = sum(lattice_NcleavageSystem(1:f-1_pInt,phase)) ! at which index starts my family do i = 1_pInt,kinematics_cleavage_opening_Ncleavage(f,instance) ! process each (active) cleavage system in family - traction_d = dot_product(Tstar_v,lattice_Scleavage_v(1:6,1,index_myFamily+i,phase)) - traction_t = dot_product(Tstar_v,lattice_Scleavage_v(1:6,2,index_myFamily+i,phase)) - traction_n = dot_product(Tstar_v,lattice_Scleavage_v(1:6,3,index_myFamily+i,phase)) + traction_d = math_mul33xx33(S,lattice_Scleavage(1:3,1:3,1,index_myFamily+i,phase)) + traction_t = math_mul33xx33(S,lattice_Scleavage(1:3,1:3,2,index_myFamily+i,phase)) + traction_n = math_mul33xx33(S,lattice_Scleavage(1:3,1:3,3,index_myFamily+i,phase)) traction_crit = kinematics_cleavage_opening_critLoad(f,instance)* & damage(homog)%p(damageOffset)*damage(homog)%p(damageOffset) udotd = & @@ -261,7 +196,7 @@ subroutine kinematics_cleavage_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tstar dudotd_dt = sign(1.0_pReal,traction_d)*udotd*kinematics_cleavage_opening_N(instance)/ & max(0.0_pReal, abs(traction_d) - traction_crit) forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dLd_dTstar(k,l,m,n) = dLd_dTstar(k,l,m,n) + & dudotd_dt*lattice_Scleavage(k,l,1,index_myFamily+i,phase)* & lattice_Scleavage(m,n,1,index_myFamily+i,phase) endif @@ -275,7 +210,7 @@ subroutine kinematics_cleavage_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tstar dudott_dt = sign(1.0_pReal,traction_t)*udott*kinematics_cleavage_opening_N(instance)/ & max(0.0_pReal, abs(traction_t) - traction_crit) forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dLd_dTstar(k,l,m,n) = dLd_dTstar(k,l,m,n) + & dudott_dt*lattice_Scleavage(k,l,2,index_myFamily+i,phase)* & lattice_Scleavage(m,n,2,index_myFamily+i,phase) endif @@ -289,11 +224,10 @@ subroutine kinematics_cleavage_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tstar dudotn_dt = sign(1.0_pReal,traction_n)*udotn*kinematics_cleavage_opening_N(instance)/ & max(0.0_pReal, abs(traction_n) - traction_crit) forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dLd_dTstar(k,l,m,n) = dLd_dTstar(k,l,m,n) + & dudotn_dt*lattice_Scleavage(k,l,3,index_myFamily+i,phase)* & lattice_Scleavage(m,n,3,index_myFamily+i,phase) endif - enddo enddo diff --git a/src/kinematics_slipplane_opening.f90 b/src/kinematics_slipplane_opening.f90 index 61ff84b9f..86be20c9d 100644 --- a/src/kinematics_slipplane_opening.f90 +++ b/src/kinematics_slipplane_opening.f90 @@ -11,20 +11,22 @@ module kinematics_slipplane_opening implicit none private - integer(pInt), dimension(:), allocatable, public, protected :: & - kinematics_slipplane_opening_sizePostResults, & !< cumulative size of post results - kinematics_slipplane_opening_offset, & !< which kinematics is my current damage mechanism? - kinematics_slipplane_opening_instance !< instance of damage kinematics mechanism - - integer(pInt), dimension(:,:), allocatable, target, public :: & - kinematics_slipplane_opening_sizePostResult !< size of each post result output - - character(len=64), dimension(:,:), allocatable, target, public :: & - kinematics_slipplane_opening_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - kinematics_slipplane_opening_Noutput !< number of outputs per instance of this damage + integer(pInt), dimension(:), allocatable, private :: kinematics_slipplane_opening_instance + type, private :: tParameters !< container type for internal constitutive parameters + integer(pInt) :: & + totalNslip + integer(pInt), dimension(:), allocatable :: & + Nslip !< active number of slip systems per family + real(pReal) :: & + sdot0, & + n + real(pReal), dimension(:), allocatable :: & + critDisp, & + critPlasticStrain + end type + +! Begin Deprecated integer(pInt), dimension(:), allocatable, private :: & kinematics_slipplane_opening_totalNslip !< total number of slip systems @@ -38,6 +40,7 @@ module kinematics_slipplane_opening real(pReal), dimension(:,:), allocatable, private :: & kinematics_slipplane_opening_critPlasticStrain, & kinematics_slipplane_opening_critLoad +! End Deprecated public :: & kinematics_slipplane_opening_init, & @@ -50,7 +53,7 @@ contains !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- -subroutine kinematics_slipplane_opening_init(fileUnit) +subroutine kinematics_slipplane_opening_init() #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 use, intrinsic :: iso_fortran_env, only: & compiler_version, & @@ -60,41 +63,25 @@ subroutine kinematics_slipplane_opening_init(fileUnit) debug_level,& debug_constitutive,& debug_levelBasic + use config, only: & + config_phase use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & IO_warning, & IO_error, & - IO_timeStamp, & - IO_EOF + IO_timeStamp use material, only: & phase_kinematics, & - phase_Nkinematics, & - phase_Noutput, & KINEMATICS_slipplane_opening_label, & KINEMATICS_slipplane_opening_ID - use config, only: & - material_Nphase, & - MATERIAL_partPhase use lattice, only: & lattice_maxNslipFamily, & lattice_NslipSystem implicit none - integer(pInt), intent(in) :: fileUnit + integer(pInt), allocatable, dimension(:) :: tempInt + real(pReal), allocatable, dimension(:) :: tempFloat - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,phase,instance,kinematics - integer(pInt) :: Nchunks_SlipFamilies = 0_pInt, j - character(len=65536) :: & - tag = '', & - line = '' + integer(pInt) :: maxNinstance,p,instance,kinematics write(6,'(/,a)') ' <<<+- kinematics_'//KINEMATICS_slipplane_opening_LABEL//' init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() @@ -106,21 +93,11 @@ subroutine kinematics_slipplane_opening_init(fileUnit) if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance - allocate(kinematics_slipplane_opening_offset(material_Nphase), source=0_pInt) - allocate(kinematics_slipplane_opening_instance(material_Nphase), source=0_pInt) - do phase = 1, material_Nphase - kinematics_slipplane_opening_instance(phase) = count(phase_kinematics(:,1:phase) == kinematics_slipplane_opening_ID) - do kinematics = 1, phase_Nkinematics(phase) - if (phase_kinematics(kinematics,phase) == kinematics_slipplane_opening_ID) & - kinematics_slipplane_opening_offset(phase) = kinematics - enddo + allocate(kinematics_slipplane_opening_instance(size(config_phase)), source=0_pInt) + do p = 1_pInt, size(config_phase) + kinematics_slipplane_opening_instance(p) = count(phase_kinematics(:,1:p) == kinematics_slipplane_opening_ID) ! ToDo: count correct? enddo - allocate(kinematics_slipplane_opening_sizePostResults(maxNinstance), source=0_pInt) - allocate(kinematics_slipplane_opening_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) - allocate(kinematics_slipplane_opening_output(maxval(phase_Noutput),maxNinstance)) - kinematics_slipplane_opening_output = '' - allocate(kinematics_slipplane_opening_Noutput(maxNinstance), source=0_pInt) allocate(kinematics_slipplane_opening_critLoad(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) allocate(kinematics_slipplane_opening_critPlasticStrain(lattice_maxNslipFamily,maxNinstance),source=0.0_pReal) allocate(kinematics_slipplane_opening_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) @@ -128,61 +105,22 @@ subroutine kinematics_slipplane_opening_init(fileUnit) allocate(kinematics_slipplane_opening_N(maxNinstance), source=0.0_pReal) allocate(kinematics_slipplane_opening_sdot_0(maxNinstance), source=0.0_pReal) - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo - - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - if (phase > 0_pInt ) then; if (any(phase_kinematics(:,phase) == KINEMATICS_slipplane_opening_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - instance = kinematics_slipplane_opening_instance(phase) ! which instance of my damage is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('nslip') ! - Nchunks_SlipFamilies = chunkPos(1) - 1_pInt - do j = 1_pInt, Nchunks_SlipFamilies - kinematics_slipplane_opening_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) - enddo + do p = 1_pInt, size(config_phase) + if (all(phase_kinematics(:,p) /= KINEMATICS_slipplane_opening_ID)) cycle + instance = kinematics_slipplane_opening_instance(p) + kinematics_slipplane_opening_sdot_0(instance) = config_phase(p)%getFloat('anisoductile_sdot0') + kinematics_slipplane_opening_N(instance) = config_phase(p)%getFloat('anisoductile_ratesensitivity') + tempInt = config_phase(p)%getInts('ncleavage') + kinematics_slipplane_opening_Nslip(1:size(tempInt),instance) = tempInt - case ('anisoductile_sdot0') - kinematics_slipplane_opening_sdot_0(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('anisoductile_criticalplasticstrain') - do j = 1_pInt, Nchunks_SlipFamilies - kinematics_slipplane_opening_critPlasticStrain(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo - - case ('anisoductile_ratesensitivity') - kinematics_slipplane_opening_N(instance) = IO_floatValue(line,chunkPos,2_pInt) + tempFloat = config_phase(p)%getFloats('anisoductile_criticalplasticstrain',requiredSize=size(tempInt)) + kinematics_slipplane_opening_critPlasticStrain(1:size(tempInt),instance) = tempFloat - case ('anisoductile_criticalload') - do j = 1_pInt, Nchunks_SlipFamilies - kinematics_slipplane_opening_critLoad(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo - - end select - endif; endif - enddo parsingFile + tempFloat = config_phase(p)%getFloats('anisoductile_criticalload',requiredSize=size(tempInt)) + kinematics_slipplane_opening_critLoad(1:size(tempInt),instance) = tempFloat -!-------------------------------------------------------------------------------------------------- -! sanity checks - sanityChecks: do phase = 1_pInt, material_Nphase - myPhase: if (any(phase_kinematics(:,phase) == KINEMATICS_slipplane_opening_ID)) then - instance = kinematics_slipplane_opening_instance(phase) kinematics_slipplane_opening_Nslip(1:lattice_maxNslipFamily,instance) = & - min(lattice_NslipSystem(1:lattice_maxNslipFamily,phase),& ! limit active cleavage systems per family to min of available and requested + min(lattice_NslipSystem(1:lattice_maxNslipFamily,p),& ! limit active cleavage systems per family to min of available and requested kinematics_slipplane_opening_Nslip(1:lattice_maxNslipFamily,instance)) kinematics_slipplane_opening_totalNslip(instance) = sum(kinematics_slipplane_opening_Nslip(:,instance)) if (kinematics_slipplane_opening_sdot_0(instance) <= 0.0_pReal) & @@ -191,18 +129,18 @@ subroutine kinematics_slipplane_opening_init(fileUnit) call IO_error(211_pInt,el=instance,ext_msg='criticaPlasticStrain ('//KINEMATICS_slipplane_opening_LABEL//')') if (kinematics_slipplane_opening_N(instance) <= 0.0_pReal) & call IO_error(211_pInt,el=instance,ext_msg='rate_sensitivity ('//KINEMATICS_slipplane_opening_LABEL//')') - endif myPhase - enddo sanityChecks + enddo - end subroutine kinematics_slipplane_opening_init !-------------------------------------------------------------------------------------------------- !> @brief contains the constitutive equation for calculating the velocity gradient !-------------------------------------------------------------------------------------------------- -subroutine kinematics_slipplane_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tstar_v, ipc, ip, el) +subroutine kinematics_slipplane_opening_LiAndItsTangent(Ld, dLd_dTstar, S, ipc, ip, el) use prec, only: & tol_math_check + use math, only: & + math_mul33xx33 use lattice, only: & lattice_maxNslipFamily, & lattice_NslipSystem, & @@ -210,53 +148,41 @@ subroutine kinematics_slipplane_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tsta lattice_st, & lattice_sn use material, only: & - phaseAt, phasememberAt, & + material_phase, & material_homog, & damage, & damageMapping use math, only: & - math_Plain3333to99, & - math_I3, & - math_identity4th, & - math_symmetric33, & - math_Mandel33to6, & - math_tensorproduct33, & - math_det33, & - math_mul33x33 + math_tensorproduct33 implicit none integer(pInt), intent(in) :: & ipc, & !< grain number ip, & !< integration point number el !< element number - real(pReal), intent(in), dimension(6) :: & - Tstar_v !< 2nd Piola-Kirchhoff stress + real(pReal), intent(in), dimension(3,3) :: & + S real(pReal), intent(out), dimension(3,3) :: & Ld !< damage velocity gradient real(pReal), intent(out), dimension(3,3,3,3) :: & - dLd_dTstar3333 !< derivative of Ld with respect to Tstar (4th-order tensor) + dLd_dTstar !< derivative of Ld with respect to Tstar (4th-order tensor) real(pReal), dimension(3,3) :: & projection_d, projection_t, projection_n !< projection modes 3x3 tensor - real(pReal), dimension(6) :: & - projection_d_v, projection_t_v, projection_n_v !< projection modes 3x3 vector integer(pInt) :: & - phase, & - constituent, & - instance, & + instance, phase, & homog, damageOffset, & f, i, index_myFamily, k, l, m, n real(pReal) :: & traction_d, traction_t, traction_n, traction_crit, & udotd, dudotd_dt, udott, dudott_dt, udotn, dudotn_dt - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) + phase = material_phase(ipc,ip,el) instance = kinematics_slipplane_opening_instance(phase) homog = material_homog(ip,el) damageOffset = damageMapping(homog)%p(ip,el) Ld = 0.0_pReal - dLd_dTstar3333 = 0.0_pReal + dLd_dTstar = 0.0_pReal do f = 1_pInt,lattice_maxNslipFamily index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,phase)) ! at which index starts my family do i = 1_pInt,kinematics_slipplane_opening_Nslip(f,instance) ! process each (active) slip system in family @@ -267,13 +193,10 @@ subroutine kinematics_slipplane_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tsta projection_n = math_tensorproduct33(lattice_sn(1:3,index_myFamily+i,phase),& lattice_sn(1:3,index_myFamily+i,phase)) - projection_d_v(1:6) = math_Mandel33to6(math_symmetric33(projection_d(1:3,1:3))) - projection_t_v(1:6) = math_Mandel33to6(math_symmetric33(projection_t(1:3,1:3))) - projection_n_v(1:6) = math_Mandel33to6(math_symmetric33(projection_n(1:3,1:3))) - traction_d = dot_product(Tstar_v,projection_d_v(1:6)) - traction_t = dot_product(Tstar_v,projection_t_v(1:6)) - traction_n = dot_product(Tstar_v,projection_n_v(1:6)) + traction_d = math_mul33xx33(S,projection_d) + traction_t = math_mul33xx33(S,projection_t) + traction_n = math_mul33xx33(S,projection_n) traction_crit = kinematics_slipplane_opening_critLoad(f,instance)* & damage(homog)%p(damageOffset) ! degrading critical load carrying capacity by damage @@ -287,7 +210,7 @@ subroutine kinematics_slipplane_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tsta Ld = Ld + udotd*projection_d dudotd_dt = udotd*kinematics_slipplane_opening_N(instance)/traction_d forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dLd_dTstar(k,l,m,n) = dLd_dTstar(k,l,m,n) + & dudotd_dt*projection_d(k,l)*projection_d(m,n) endif @@ -300,9 +223,10 @@ subroutine kinematics_slipplane_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tsta Ld = Ld + udott*projection_t dudott_dt = udott*kinematics_slipplane_opening_N(instance)/traction_t forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dLd_dTstar(k,l,m,n) = dLd_dTstar(k,l,m,n) + & dudott_dt*projection_t(k,l)*projection_t(m,n) endif + udotn = & kinematics_slipplane_opening_sdot_0(instance)* & (max(0.0_pReal,traction_n)/traction_crit - & @@ -311,7 +235,7 @@ subroutine kinematics_slipplane_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tsta Ld = Ld + udotn*projection_n dudotn_dt = udotn*kinematics_slipplane_opening_N(instance)/traction_n forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dLd_dTstar(k,l,m,n) = dLd_dTstar(k,l,m,n) + & dudotn_dt*projection_n(k,l)*projection_n(m,n) endif enddo diff --git a/src/kinematics_thermal_expansion.f90 b/src/kinematics_thermal_expansion.f90 index 3d1de3d0a..3696593ad 100644 --- a/src/kinematics_thermal_expansion.f90 +++ b/src/kinematics_thermal_expansion.f90 @@ -24,10 +24,10 @@ module kinematics_thermal_expansion integer(pInt), dimension(:), allocatable, target, public :: & kinematics_thermal_expansion_Noutput !< number of outputs per instance of this damage -! enum, bind(c) ! ToDo kinematics need state machinery to deal with sizePostResult -! enumerator :: undefined_ID, & ! possible remedy is to decouple having state vars from having output -! thermalexpansionrate_ID ! which means to separate user-defined types tState + tOutput... -! end enum + enum, bind(c) ! ToDo kinematics need state machinery to deal with sizePostResult + enumerator :: undefined_ID, & ! possible remedy is to decouple having state vars from having output + thermalexpansionrate_ID ! which means to separate user-defined types tState + tOutput... + end enum public :: & kinematics_thermal_expansion_init, & kinematics_thermal_expansion_initialStrain, & diff --git a/src/lattice.f90 b/src/lattice.f90 index 9be30a5d3..410c14628 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -31,8 +31,7 @@ module lattice lattice_Scleavage !< Schmid matrices for cleavage systems real(pReal), allocatable, dimension(:,:,:,:), protected, public :: & - lattice_Sslip_v, & !< Mandel notation of lattice_Sslip - lattice_Scleavage_v !< Mandel notation of lattice_Scleavege + lattice_Sslip_v !< Mandel notation of lattice_Sslip real(pReal), allocatable, dimension(:,:,:), protected, public :: & lattice_sn, & !< normal direction of slip system @@ -776,7 +775,6 @@ subroutine lattice_init allocate(lattice_interactionSlipSlip(lattice_maxNslip,lattice_maxNslip,Nphases),source=0_pInt) ! other:me allocate(lattice_Scleavage(3,3,3,lattice_maxNslip,Nphases),source=0.0_pReal) - allocate(lattice_Scleavage_v(6,3,lattice_maxNslip,Nphases),source=0.0_pReal) allocate(lattice_NcleavageSystem(lattice_maxNcleavageFamily,Nphases),source=0_pInt) allocate(CoverA(Nphases),source=0.0_pReal) @@ -1060,13 +1058,6 @@ subroutine lattice_initializeStructure(myPhase,CoverA) enddo enddo - do i = 1_pInt,myNcleavage ! store slip system vectors and Schmid matrix for my structure - do j = 1_pInt,3_pInt - lattice_Scleavage_v(1:6,j,i,myPhase) = & - math_sym33to6(math_symmetric33(lattice_Scleavage(1:3,1:3,j,i,myPhase))) - enddo - enddo - end subroutine lattice_initializeStructure diff --git a/src/material.f90 b/src/material.f90 index 3ae6c16a4..8a8f36a55 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -235,6 +235,7 @@ module material public :: & material_init, & material_allocatePlasticState, & + material_allocateSourceState, & ELASTICITY_hooke_ID ,& PLASTICITY_none_ID, & PLASTICITY_isotropic_ID, & @@ -305,9 +306,7 @@ subroutine material_init() texture_name use mesh, only: & mesh_homogenizationAt, & - mesh_NipsPerElem, & - mesh_NcpElems, & - FE_geomtype + theMesh implicit none integer(pInt), parameter :: FILEUNIT = 210_pInt @@ -399,10 +398,10 @@ subroutine material_init() call material_populateGrains ! BEGIN DEPRECATED - allocate(phaseAt ( homogenization_maxNgrains,mesh_nIPsPerElem,mesh_NcpElems),source=0_pInt) - allocate(phasememberAt ( homogenization_maxNgrains,mesh_nIPsPerElem,mesh_NcpElems),source=0_pInt) - allocate(mappingHomogenization (2, mesh_nIPsPerElem,mesh_NcpElems),source=0_pInt) - allocate(mappingHomogenizationConst( mesh_nIPsPerElem,mesh_NcpElems),source=1_pInt) + 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=mesh_homogenizationAt) @@ -410,9 +409,9 @@ subroutine material_init() allocate(CounterHomogenization(size(config_homogenization)),source=0_pInt) ! BEGIN DEPRECATED - do e = 1_pInt,mesh_NcpElems + do e = 1_pInt,theMesh%Nelems myHomog = mesh_homogenizationAt(e) - do i = 1_pInt, mesh_NipsPerElem + do i = 1_pInt, theMesh%elem%nIPs CounterHomogenization(myHomog) = CounterHomogenization(myHomog) + 1_pInt mappingHomogenization(1:2,i,e) = [CounterHomogenization(myHomog),myHomog] do g = 1_pInt,homogenization_Ngrains(myHomog) @@ -553,7 +552,7 @@ subroutine material_parseMicrostructure microstructure_name use mesh, only: & mesh_microstructureAt, & - mesh_NcpElems + theMesh implicit none character(len=65536), dimension(:), allocatable :: & @@ -571,7 +570,7 @@ subroutine material_parseMicrostructure if(any(mesh_microstructureAt > size(config_microstructure))) & call IO_error(155_pInt,ext_msg='More microstructures in geometry than sections in material.config') - forall (e = 1_pInt:mesh_NcpElems) & + forall (e = 1_pInt:theMesh%Nelems) & microstructure_active(mesh_microstructureAt(e)) = .true. ! current microstructure used in model? Elementwise view, maximum N operations for N elements do m=1_pInt, size(config_microstructure) @@ -966,6 +965,49 @@ subroutine material_allocatePlasticState(phase,NofMyPhase,& end subroutine material_allocatePlasticState +!-------------------------------------------------------------------------------------------------- +!> @brief allocates the source state of a phase +!-------------------------------------------------------------------------------------------------- +subroutine material_allocateSourceState(phase,of,NofMyPhase,& + sizeState,sizeDotState,sizeDeltaState) + use numerics, only: & + numerics_integrator2 => numerics_integrator ! compatibility hack + + implicit none + integer(pInt), intent(in) :: & + phase, & + of, & + NofMyPhase, & + sizeState, sizeDotState,sizeDeltaState + integer(pInt) :: numerics_integrator ! compatibility hack + numerics_integrator = numerics_integrator2(1) ! compatibility hack + + sourceState(phase)%p(of)%sizeState = sizeState + sourceState(phase)%p(of)%sizeDotState = sizeDotState + sourceState(phase)%p(of)%sizeDeltaState = sizeDeltaState + plasticState(phase)%offsetDeltaState = sizeState-sizeDeltaState ! deltaState occupies latter part of state by definition + + allocate(sourceState(phase)%p(of)%aTolState (sizeState), source=0.0_pReal) + allocate(sourceState(phase)%p(of)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(of)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(of)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(of)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(sourceState(phase)%p(of)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (numerics_integrator == 1_pInt) then + allocate(sourceState(phase)%p(of)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(of)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (numerics_integrator == 4_pInt) & + allocate(sourceState(phase)%p(of)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (numerics_integrator == 5_pInt) & + allocate(sourceState(phase)%p(of)%RKCK45dotState (6,sizeDotState,NofMyPhase), source=0.0_pReal) + + allocate(plasticState(phase)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + +end subroutine material_allocateSourceState + + !-------------------------------------------------------------------------------------------------- !> @brief populates the grains !> @details populates the grains by identifying active microstructure/homogenization pairs, @@ -984,13 +1026,10 @@ subroutine material_populateGrains math_sampleFiberOri, & math_symmetricEulers use mesh, only: & - mesh_NipsPerElem, & - mesh_elemType, & mesh_homogenizationAt, & mesh_microstructureAt, & - mesh_NcpElems, & - mesh_ipVolume, & - FE_geomtype + theMesh, & + mesh_ipVolume use config, only: & config_homogenization, & config_microstructure, & @@ -1026,24 +1065,24 @@ subroutine material_populateGrains myDebug = debug_level(debug_material) - allocate(material_volume(homogenization_maxNgrains,mesh_nIPsPerElem,mesh_NcpElems), source=0.0_pReal) - allocate(material_phase(homogenization_maxNgrains,mesh_nIPsPerElem,mesh_NcpElems), source=0_pInt) - allocate(material_homog(mesh_nIPsPerElem,mesh_NcpElems), source=0_pInt) - allocate(material_texture(homogenization_maxNgrains,mesh_nIPsPerElem,mesh_NcpElems), source=0_pInt) - allocate(material_EulerAngles(3,homogenization_maxNgrains,mesh_nIPsPerElem,mesh_NcpElems),source=0.0_pReal) + allocate(material_volume(homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems), source=0.0_pReal) + allocate(material_phase(homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems), source=0_pInt) + allocate(material_homog(theMesh%elem%nIPs,theMesh%Nelems), source=0_pInt) + allocate(material_texture(homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems), source=0_pInt) + allocate(material_EulerAngles(3,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0.0_pReal) allocate(Ngrains(size(config_homogenization),size(config_microstructure)), source=0_pInt) allocate(Nelems (size(config_homogenization),size(config_microstructure)), source=0_pInt) ! populating homogenization schemes in each !-------------------------------------------------------------------------------------------------- - do e = 1_pInt, mesh_NcpElems - material_homog(1_pInt:mesh_NipsPerElem,e) = mesh_homogenizationAt(e) + do e = 1_pInt, theMesh%Nelems + material_homog(1_pInt:theMesh%elem%nIPs,e) = mesh_homogenizationAt(e) enddo !-------------------------------------------------------------------------------------------------- ! precounting of elements for each homog/micro pair - do e = 1_pInt, mesh_NcpElems + do e = 1_pInt, theMesh%Nelems homog = mesh_homogenizationAt(e) micro = mesh_microstructureAt(e) Nelems(homog,micro) = Nelems(homog,micro) + 1_pInt @@ -1061,8 +1100,7 @@ subroutine material_populateGrains !-------------------------------------------------------------------------------------------------- ! identify maximum grain count per IP (from element) and find grains per homog/micro pair Nelems = 0_pInt ! reuse as counter - elementLooping: do e = 1_pInt,mesh_NcpElems - t = mesh_elemType + elementLooping: do e = 1_pInt,theMesh%Nelems homog = mesh_homogenizationAt(e) micro = mesh_microstructureAt(e) if (homog < 1_pInt .or. homog > size(config_homogenization)) & ! out of bounds @@ -1072,7 +1110,7 @@ subroutine material_populateGrains if (microstructure_elemhomo(micro)) then ! how many grains are needed at this element? dGrains = homogenization_Ngrains(homog) ! only one set of Ngrains (other IPs are plain copies) else - dGrains = homogenization_Ngrains(homog) * mesh_NipsPerElem ! each IP has Ngrains + dGrains = homogenization_Ngrains(homog) * theMesh%elem%nIPs ! each IP has Ngrains endif Ngrains(homog,micro) = Ngrains(homog,micro) + dGrains ! total grain count Nelems(homog,micro) = Nelems(homog,micro) + 1_pInt ! total element count @@ -1106,16 +1144,15 @@ subroutine material_populateGrains do hme = 1_pInt, Nelems(homog,micro) e = elemsOfHomogMicro(homog,micro)%p(hme) ! my combination of homog and micro, only perform calculations for elements with homog, micro combinations which is indexed in cpElemsindex - t = mesh_elemType if (microstructure_elemhomo(micro)) then ! homogeneous distribution of grains over each element's IPs - volumeOfGrain(grain+1_pInt:grain+dGrains) = sum(mesh_ipVolume(1:mesh_NipsPerElem,e))/& + volumeOfGrain(grain+1_pInt:grain+dGrains) = sum(mesh_ipVolume(1:theMesh%elem%nIPs,e))/& real(dGrains,pReal) ! each grain combines size of all IPs in that element grain = grain + dGrains ! wind forward by Ngrains@IP else - forall (i = 1_pInt:mesh_NipsPerElem) & ! loop over IPs + forall (i = 1_pInt:theMesh%elem%nIPs) & ! loop over IPs volumeOfGrain(grain+(i-1)*dGrains+1_pInt:grain+i*dGrains) = & mesh_ipVolume(i,e)/real(dGrains,pReal) ! assign IPvolume/Ngrains@IP to all grains of IP - grain = grain + mesh_NipsPerElem * dGrains ! wind forward by Nips*Ngrains@IP + grain = grain + theMesh%elem%nIPs * dGrains ! wind forward by Nips*Ngrains@IP endif enddo @@ -1261,11 +1298,10 @@ subroutine material_populateGrains do hme = 1_pInt, Nelems(homog,micro) e = elemsOfHomogMicro(homog,micro)%p(hme) ! only perform calculations for elements with homog, micro combinations which is indexed in cpElemsindex - t = mesh_elemType if (microstructure_elemhomo(micro)) then ! homogeneous distribution of grains over each element's IPs m = 1_pInt ! process only first IP else - m = mesh_NipsPerElem + m = theMesh%elem%nIPs endif do i = 1_pInt, m ! loop over necessary IPs @@ -1303,7 +1339,7 @@ subroutine material_populateGrains enddo - do i = i, mesh_NipsPerElem ! loop over IPs to (possibly) distribute copies from first IP + do i = i, theMesh%elem%nIPs ! loop over IPs to (possibly) distribute copies from first IP material_volume (1_pInt:dGrains,i,e) = material_volume (1_pInt:dGrains,1,e) material_phase (1_pInt:dGrains,i,e) = material_phase (1_pInt:dGrains,1,e) material_texture(1_pInt:dGrains,i,e) = material_texture(1_pInt:dGrains,1,e) diff --git a/src/math.f90 b/src/math.f90 index 2b73894a2..dde20077e 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -118,6 +118,9 @@ module math !--------------------------------------------------------------------------------------------------- public :: & +#if defined(__PGI) + norm2, & +#endif math_init, & math_qsort, & math_expand, & @@ -351,20 +354,38 @@ end subroutine math_check !-------------------------------------------------------------------------------------------------- !> @brief Quicksort algorithm for two-dimensional integer arrays -! Sorting is done with respect to array(1,:) -! and keeps array(2:N,:) linked to it. +! Sorting is done with respect to array(sort,:) and keeps array(/=sort,:) linked to it. +! default: sort=1 !-------------------------------------------------------------------------------------------------- -recursive subroutine math_qsort(a, istart, iend) +recursive subroutine math_qsort(a, istart, iend, sortDim) implicit none integer(pInt), dimension(:,:), intent(inout) :: a - integer(pInt), intent(in) :: istart,iend - integer(pInt) :: ipivot - - if (istart < iend) then - ipivot = qsort_partition(a,istart, iend) - call math_qsort(a, istart, ipivot-1_pInt) - call math_qsort(a, ipivot+1_pInt, iend) + integer(pInt), intent(in),optional :: istart,iend, sortDim + integer(pInt) :: ipivot,s,e,d + + if(present(istart)) then + s = istart + else + s = lbound(a,2) + endif + + if(present(iend)) then + e = iend + else + e = ubound(a,2) + endif + + if(present(sortDim)) then + d = sortDim + else + d = 1 + endif + + if (s < e) then + ipivot = qsort_partition(a,s, e, d) + call math_qsort(a, s, ipivot-1_pInt, d) + call math_qsort(a, ipivot+1_pInt, e, d) endif !-------------------------------------------------------------------------------------------------- @@ -373,37 +394,34 @@ recursive subroutine math_qsort(a, istart, iend) !------------------------------------------------------------------------------------------------- !> @brief Partitioning required for quicksort !------------------------------------------------------------------------------------------------- - integer(pInt) function qsort_partition(a, istart, iend) + integer(pInt) function qsort_partition(a, istart, iend, sort) implicit none integer(pInt), dimension(:,:), intent(inout) :: a - integer(pInt), intent(in) :: istart,iend - integer(pInt) :: i,j,k,tmp + integer(pInt), intent(in) :: istart,iend,sort + integer(pInt), dimension(size(a,1)) :: tmp + integer(pInt) :: i,j do - ! find the first element on the right side less than or equal to the pivot point + ! find the first element on the right side less than or equal to the pivot point do j = iend, istart, -1_pInt - if (a(1,j) <= a(1,istart)) exit + if (a(sort,j) <= a(sort,istart)) exit enddo - ! find the first element on the left side greater than the pivot point + ! find the first element on the left side greater than the pivot point do i = istart, iend - if (a(1,i) > a(1,istart)) exit + if (a(sort,i) > a(sort,istart)) exit enddo - if (i < j) then ! if the indexes do not cross, exchange values - do k = 1_pInt, int(size(a,1_pInt), pInt) - tmp = a(k,i) - a(k,i) = a(k,j) - a(k,j) = tmp - enddo - else ! if they do cross, exchange left value with pivot and return with the partition index - do k = 1_pInt, int(size(a,1_pInt), pInt) - tmp = a(k,istart) - a(k,istart) = a(k,j) - a(k,j) = tmp - enddo + cross: if (i >= j) then ! if the indices cross, exchange left value with pivot and return with the partition index + tmp = a(:,istart) + a(:,istart) = a(:,j) + a(:,j) = tmp qsort_partition = j return - endif + else cross ! if they do not cross, exchange values + tmp = a(:,i) + a(:,i) = a(:,j) + a(:,j) = tmp + endif cross enddo end function qsort_partition @@ -2706,4 +2724,19 @@ real(pReal) pure elemental function math_clip(a, left, right) end function math_clip + +#if defined(__PGI) +!-------------------------------------------------------------------------------------------------- +!> @brief substitute for the norm2 intrinsic which is not available in PGI 18.10 +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function norm2(v) + + implicit none + real(pReal), intent(in), dimension(3) :: v + + norm2 = sqrt(sum(v**2)) + +end function norm2 +#endif + end module math diff --git a/src/meshFEM.f90 b/src/mesh_FEM.f90 similarity index 93% rename from src/meshFEM.f90 rename to src/mesh_FEM.f90 index 1362063f8..ed80cbcba 100644 --- a/src/meshFEM.f90 +++ b/src/mesh_FEM.f90 @@ -12,7 +12,7 @@ module mesh #include #include use prec, only: pReal, pInt - + use mesh_base use PETScdmplex use PETScdmda use PETScis @@ -27,7 +27,6 @@ use PETScis mesh_NcpElems, & !< total number of CP elements in mesh mesh_NcpElemsGlobal, & mesh_Nnodes, & !< total number of nodes in mesh - mesh_NipsPerElem, & !< number of IPs in per element mesh_maxNipNeighbors !!!! BEGIN DEPRECATED !!!!! integer(pInt), public, protected :: & @@ -79,7 +78,17 @@ use PETScis integer(pInt), dimension(1_pInt), parameter, public :: FE_NipNeighbors = & !< number of ip neighbors / cell faces in a specific cell type int([6],pInt) + + type, public, extends(tMesh) :: tMesh_FEM + + contains + procedure, pass(self) :: tMesh_FEM_init + generic, public :: init => tMesh_FEM_init + end type tMesh_FEM + + type(tMesh_FEM), public, protected :: theMesh + public :: & mesh_init, & @@ -89,6 +98,25 @@ use PETScis contains +subroutine tMesh_FEM_init(self,dimen,order,nodes) + + implicit none + integer, intent(in) :: dimen + integer(pInt), intent(in) :: order + real(pReal), intent(in), dimension(:,:) :: nodes + class(tMesh_FEM) :: self + + if (dimen == 2_pInt) then + if (order == 1_pInt) call self%tMesh%init('mesh',1_pInt,nodes) + if (order == 2_pInt) call self%tMesh%init('mesh',2_pInt,nodes) + elseif(dimen == 3_pInt) then + if (order == 1_pInt) call self%tMesh%init('mesh',6_pInt,nodes) + if (order == 2_pInt) call self%tMesh%init('mesh',8_pInt,nodes) + endif + + end subroutine tMesh_FEM_init + + !-------------------------------------------------------------------------------------------------- !> @brief initializes the mesh by calling all necessary private routines the mesh module @@ -213,6 +241,8 @@ subroutine mesh_init() FE_Nips(FE_geomtype(1_pInt)) = FEM_Zoo_nQuadrature(dimPlex,integrationOrder) mesh_maxNips = FE_Nips(1_pInt) + + write(6,*) 'mesh_maxNips',mesh_maxNips call mesh_FEM_build_ipCoordinates(dimPlex,FEM_Zoo_QuadraturePoints(dimPlex,integrationOrder)%p) call mesh_FEM_build_ipVolumes(dimPlex) @@ -238,12 +268,14 @@ subroutine mesh_init() !!!! COMPATIBILITY HACK !!!! ! for a homogeneous mesh, all elements have the same number of IPs and and cell nodes. ! hence, xxPerElem instead of maxXX - mesh_NipsPerElem = mesh_maxNips ! better name mesh_homogenizationAt = mesh_element(3,:) mesh_microstructureAt = mesh_element(4,:) !!!!!!!!!!!!!!!!!!!!!!!! - + allocate(mesh_node0(3,mesh_Nnodes),source=0.0_pReal) + call theMesh%init(dimplex,integrationOrder,mesh_node0) + call theMesh%setNelems(mesh_NcpElems) + end subroutine mesh_init diff --git a/src/mesh.f90 b/src/mesh_abaqus.f90 similarity index 65% rename from src/mesh.f90 rename to src/mesh_abaqus.f90 index e55165d51..4e923606e 100644 --- a/src/mesh.f90 +++ b/src/mesh_abaqus.f90 @@ -6,8 +6,8 @@ !> @brief Sets up the mesh for the solvers MSC.Marc, Abaqus and the spectral solver !-------------------------------------------------------------------------------------------------- module mesh - use, intrinsic :: iso_c_binding use prec, only: pReal, pInt + use mesh_base implicit none private @@ -17,8 +17,6 @@ module mesh mesh_Nnodes, & !< total number of nodes in mesh mesh_Ncellnodes, & !< total number of cell nodes in mesh (including duplicates) mesh_Ncells, & !< total number of cells in mesh - mesh_NipsPerElem, & !< number of IPs in per element - mesh_NcellnodesPerElem, & !< number of cell nodes per element mesh_maxNipNeighbors, & !< max number of IP neighbors in any CP element mesh_maxNsharedElems !< max number of CP elements sharing a node !!!! BEGIN DEPRECATED !!!!! @@ -32,7 +30,6 @@ module mesh mesh_microstructureAt !< microstructure ID of each element integer(pInt), dimension(:,:), allocatable, public, protected :: & - mesh_CPnodeID, & !< nodes forming an element mesh_element, & !DEPRECATED mesh_sharedElem, & !< entryCount and list of elements containing node mesh_nodeTwins !< node twins are surface nodes that lie exactly on opposite sides of the mesh (surfaces nodes with equal coordinate values in two dimensions) @@ -62,11 +59,9 @@ module mesh logical, dimension(3), public, protected :: mesh_periodicSurface !< flag indicating periodic outer surfaces (used for fluxes) -#if defined(Marc4DAMASK) || defined(Abaqus) integer(pInt), private :: & mesh_maxNelemInSet, & mesh_Nmaterials -#endif integer(pInt), dimension(2), private :: & mesh_maxValStateVar = 0_pInt @@ -329,7 +324,6 @@ integer(pInt), dimension(:,:), allocatable, private :: & 6 & ! (3D 8node) ],pInt) - integer(pInt), dimension(FE_Ngeomtypes), parameter, private :: FE_maxNnodesAtIP = & !< maximum number of parent nodes that belong to an IP for a specific type of element int([ & 3, & ! element 6 (2D 3node 1ip) @@ -344,19 +338,6 @@ integer(pInt), dimension(:,:), allocatable, private :: & 4 & ! element 21 (3D 20node 27ip) ],pInt) -#if defined(Spectral) - integer(pInt), dimension(3), public, protected :: & - grid !< (global) grid - integer(pInt), public, protected :: & - mesh_NcpElemsGlobal, & !< total number of CP elements in global mesh - grid3, & !< (local) grid in 3rd direction - grid3Offset !< (local) grid offset in 3rd direction - real(pReal), dimension(3), public, protected :: & - geomSize - real(pReal), public, protected :: & - size3, & !< (local) size in 3rd direction - size3offset !< (local) size offset in 3rd direction -#elif defined(Marc4DAMASK) || defined(Abaqus) integer(pInt), private :: & mesh_Nelems, & !< total number of elements in mesh (including non-DAMASK elements) mesh_maxNnodes, & !< max number of nodes in any CP element @@ -370,17 +351,7 @@ integer(pInt), dimension(:,:), allocatable, private :: & integer(pInt), dimension(:,:), allocatable, target, private :: & mesh_mapFEtoCPelem, & !< [sorted FEid, corresponding CPid] mesh_mapFEtoCPnode !< [sorted FEid, corresponding CPid] -#endif -#if defined(Marc4DAMASK) - integer(pInt), private :: & - MarcVersion, & !< Version of input file format (Marc only) - hypoelasticTableStyle, & !< Table style (Marc only) - initialcondTableStyle !< Table style (Marc only) - integer(pInt), dimension(:), allocatable, private :: & - Marc_matNumber !< array of material numbers for hypoelastic material (Marc only) -#elif defined(Abaqus) logical, private :: noPart !< for cases where the ABAQUS input file does not use part/assembly information -#endif public :: & mesh_init, & @@ -388,50 +359,17 @@ integer(pInt), dimension(:,:), allocatable, private :: & mesh_build_ipVolumes, & mesh_build_ipCoordinates, & mesh_cellCenterCoordinates, & - mesh_get_Ncellnodes, & - mesh_get_unitlength, & - mesh_get_nodeAtIP, & -#if defined(Spectral) - mesh_spectral_getGrid, & - mesh_spectral_getSize -#elif defined(Marc4DAMASK) || defined(Abaqus) mesh_FEasCP -#endif private :: & mesh_get_damaskOptions, & mesh_build_cellconnectivity, & mesh_build_ipAreas, & - mesh_tell_statistics, & FE_mapElemtype, & - mesh_faceMatch, & mesh_build_FEdata, & -#if defined(Spectral) - mesh_spectral_getHomogenization, & - mesh_spectral_count, & - mesh_spectral_count_cpSizes, & - mesh_spectral_build_nodes, & - mesh_spectral_build_elements, & - mesh_spectral_build_ipNeighborhood -#elif defined(Marc4DAMASK) || defined(Abaqus) mesh_build_nodeTwins, & mesh_build_sharedElems, & mesh_build_ipNeighborhood, & -#endif -#if defined(Marc4DAMASK) - mesh_marc_get_fileFormat, & - mesh_marc_get_tableStyles, & - mesh_marc_get_matNumber, & - mesh_marc_count_nodesAndElements, & - mesh_marc_count_elementSets, & - mesh_marc_map_elementSets, & - mesh_marc_count_cpElements, & - mesh_marc_map_Elements, & - mesh_marc_map_nodes, & - mesh_marc_build_nodes, & - mesh_marc_count_cpSizes, & - mesh_marc_build_elements -#elif defined(Abaqus) mesh_abaqus_count_nodesAndElements, & mesh_abaqus_count_elementSets, & mesh_abaqus_count_materials, & @@ -443,36 +381,52 @@ integer(pInt), dimension(:,:), allocatable, private :: & mesh_abaqus_build_nodes, & mesh_abaqus_count_cpSizes, & mesh_abaqus_build_elements -#endif + + type, public, extends(tMesh) :: tMesh_abaqus + + integer(pInt):: & + mesh_Nelems, & !< total number of elements in mesh (including non-DAMASK elements) + mesh_maxNnodes, & !< max number of nodes in any CP element + mesh_NelemSets, & + mesh_maxNelemInSet, & + mesh_Nmaterials + character(len=64), dimension(:), allocatable :: & + mesh_nameElemSet, & !< names of elementSet + mesh_nameMaterial, & !< names of material in solid section + mesh_mapMaterial !< name of elementSet for material + integer(pInt), dimension(:,:), allocatable :: & + mesh_mapElemSet !< list of elements in elementSet + logical:: noPart !< for cases where the ABAQUS input file does not use part/assembly information + + contains + procedure, pass(self) :: tMesh_abaqus_init + generic, public :: init => tMesh_abaqus_init + end type tMesh_abaqus + + type(tMesh_abaqus), public, protected :: theMesh + contains +subroutine tMesh_abaqus_init(self,elemType,nodes) + + implicit none + class(tMesh_abaqus) :: self + real(pReal), dimension(:,:), intent(in) :: nodes + integer(pInt), intent(in) :: elemType + + call self%tMesh%init('mesh',elemType,nodes) + +end subroutine tMesh_abaqus_init !-------------------------------------------------------------------------------------------------- !> @brief initializes the mesh by calling all necessary private routines the mesh module !! Order and routines strongly depend on type of solver !-------------------------------------------------------------------------------------------------- subroutine mesh_init(ip,el) -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif -#ifdef Spectral -#include - use PETScsys -#endif use DAMASK_interface use IO, only: & -#ifdef Abaqus - IO_abaqus_hasNoPart, & -#endif -#ifdef Spectral - IO_open_file, & - IO_error, & -#else IO_open_InputFile, & -#endif IO_timeStamp, & IO_error, & IO_write_jobFile @@ -487,95 +441,25 @@ subroutine mesh_init(ip,el) numerics_unitlength, & worldrank use FEsolving, only: & -#ifndef Spectral modelName, & - calcMode, & -#endif - FEsolving_execElem, & + calcMode, & FEsolving_execElem, & FEsolving_execIP implicit none -#ifdef Spectral - include 'fftw3-mpi.f03' - integer(C_INTPTR_T) :: devNull, local_K, local_K_offset - integer :: ierr, worldsize -#endif integer(pInt), parameter :: FILEUNIT = 222_pInt integer(pInt), intent(in), optional :: el, ip integer(pInt) :: j logical :: myDebug write(6,'(/,a)') ' <<<+- mesh init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - call mesh_build_FEdata ! get properties of the different types of elements mesh_unitlength = numerics_unitlength ! set physical extent of a length unit in mesh myDebug = (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) -#ifdef Spectral - call fftw_mpi_init() - call IO_open_file(FILEUNIT,geometryFile) ! parse info from geometry file... - if (myDebug) write(6,'(a)') ' Opened geometry file'; flush(6) - grid = mesh_spectral_getGrid(fileUnit) - call MPI_comm_size(PETSC_COMM_WORLD, worldsize, ierr) - if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='MPI_comm_size') - if(worldsize>grid(3)) call IO_error(894_pInt, ext_msg='number of processes exceeds grid(3)') - - geomSize = mesh_spectral_getSize(fileUnit) - devNull = fftw_mpi_local_size_3d(int(grid(3),C_INTPTR_T), & - int(grid(2),C_INTPTR_T), & - int(grid(1),C_INTPTR_T)/2+1, & - PETSC_COMM_WORLD, & - local_K, & ! domain grid size along z - local_K_offset) ! domain grid offset along z - grid3 = int(local_K,pInt) - grid3Offset = int(local_K_offset,pInt) - size3 = geomSize(3)*real(grid3,pReal) /real(grid(3),pReal) - size3Offset = geomSize(3)*real(grid3Offset,pReal)/real(grid(3),pReal) - if (myDebug) write(6,'(a)') ' Grid partitioned'; flush(6) - call mesh_spectral_count() - if (myDebug) write(6,'(a)') ' Counted nodes/elements'; flush(6) - call mesh_spectral_count_cpSizes - if (myDebug) write(6,'(a)') ' Built CP statistics'; flush(6) - call mesh_spectral_build_nodes() - if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) - call mesh_spectral_build_elements(FILEUNIT) - if (myDebug) write(6,'(a)') ' Built elements'; flush(6) -#elif defined Marc4DAMASK call IO_open_inputFile(FILEUNIT,modelName) ! parse info from input file... if (myDebug) write(6,'(a)') ' Opened input file'; flush(6) - call mesh_marc_get_fileFormat(FILEUNIT) - if (myDebug) write(6,'(a)') ' Got input file format'; flush(6) - call mesh_marc_get_tableStyles(FILEUNIT) - if (myDebug) write(6,'(a)') ' Got table styles'; flush(6) - if (MarcVersion > 12) then - call mesh_marc_get_matNumber(FILEUNIT) - if (myDebug) write(6,'(a)') ' Got hypoleastic material number'; flush(6) - endif - call mesh_marc_count_nodesAndElements(FILEUNIT) - if (myDebug) write(6,'(a)') ' Counted nodes/elements'; flush(6) - call mesh_marc_count_elementSets(FILEUNIT) - if (myDebug) write(6,'(a)') ' Counted element sets'; flush(6) - call mesh_marc_map_elementSets(FILEUNIT) - if (myDebug) write(6,'(a)') ' Mapped element sets'; flush(6) - call mesh_marc_count_cpElements(FILEUNIT) - if (myDebug) write(6,'(a)') ' Counted CP elements'; flush(6) - call mesh_marc_map_elements(FILEUNIT) - if (myDebug) write(6,'(a)') ' Mapped elements'; flush(6) - call mesh_marc_map_nodes(FILEUNIT) - if (myDebug) write(6,'(a)') ' Mapped nodes'; flush(6) - call mesh_marc_build_nodes(FILEUNIT) - if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) - call mesh_marc_count_cpSizes(FILEUNIT) - if (myDebug) write(6,'(a)') ' Counted CP sizes'; flush(6) - call mesh_marc_build_elements(FILEUNIT) - if (myDebug) write(6,'(a)') ' Built elements'; flush(6) -#elif defined Abaqus - call IO_open_inputFile(FILEUNIT,modelName) ! parse info from input file... - if (myDebug) write(6,'(a)') ' Opened input file'; flush(6) - noPart = IO_abaqus_hasNoPart(FILEUNIT) + noPart = hasNoPart(FILEUNIT) call mesh_abaqus_count_nodesAndElements(FILEUNIT) if (myDebug) write(6,'(a)') ' Counted nodes/elements'; flush(6) call mesh_abaqus_count_elementSets(FILEUNIT) @@ -598,10 +482,14 @@ subroutine mesh_init(ip,el) if (myDebug) write(6,'(a)') ' Counted CP sizes'; flush(6) call mesh_abaqus_build_elements(FILEUNIT) if (myDebug) write(6,'(a)') ' Built elements'; flush(6) -#endif - - call mesh_get_damaskOptions(FILEUNIT) + call mesh_get_damaskOptions(mesh_periodicSurface,FILEUNIT) if (myDebug) write(6,'(a)') ' Got DAMASK options'; flush(6) + close (FILEUNIT) + + call theMesh%init(mesh_element(2,1),mesh_node0) + call theMesh%setNelems(mesh_NcpElems) + call mesh_build_FEdata ! get properties of the different types of elements + call mesh_build_cellconnectivity if (myDebug) write(6,'(a)') ' Built cell connectivity'; flush(6) mesh_cellnode = mesh_build_cellnodes(mesh_node,mesh_Ncellnodes) @@ -612,106 +500,807 @@ subroutine mesh_init(ip,el) if (myDebug) write(6,'(a)') ' Built IP volumes'; flush(6) call mesh_build_ipAreas if (myDebug) write(6,'(a)') ' Built IP areas'; flush(6) - close (FILEUNIT) - -#if defined(Marc4DAMASK) || defined(Abaqus) call mesh_build_nodeTwins if (myDebug) write(6,'(a)') ' Built node twins'; flush(6) call mesh_build_sharedElems if (myDebug) write(6,'(a)') ' Built shared elements'; flush(6) call mesh_build_ipNeighborhood -#else - call mesh_spectral_build_ipNeighborhood -#endif if (myDebug) write(6,'(a)') ' Built IP neighborhood'; flush(6) - if (worldrank == 0_pInt) then - call mesh_tell_statistics - endif - -#if defined(Marc4DAMASK) || defined(Abaqus) if (usePingPong .and. (mesh_Nelems /= mesh_NcpElems)) & call IO_error(600_pInt) ! ping-pong must be disabled when having non-DAMASK elements -#endif if (debug_e < 1 .or. debug_e > mesh_NcpElems) & call IO_error(602_pInt,ext_msg='element') ! selected element does not exist if (debug_i < 1 .or. debug_i > FE_Nips(FE_geomtype(mesh_element(2_pInt,debug_e)))) & call IO_error(602_pInt,ext_msg='IP') ! selected element does not have requested IP - FEsolving_execElem = [ 1_pInt,mesh_NcpElems ] ! parallel loop bounds set to comprise all DAMASK elements allocate(FEsolving_execIP(2_pInt,mesh_NcpElems), source=1_pInt) ! parallel loop bounds set to comprise from first IP... forall (j = 1_pInt:mesh_NcpElems) FEsolving_execIP(2,j) = FE_Nips(FE_geomtype(mesh_element(2,j))) ! ...up to own IP count for each element - -#if defined(Marc4DAMASK) || defined(Abaqus) allocate(calcMode(mesh_maxNips,mesh_NcpElems)) calcMode = .false. ! pretend to have collected what first call is asking (F = I) calcMode(ip,mesh_FEasCP('elem',el)) = .true. ! first ip,el needs to be already pingponged to "calc" -#endif -!!!! COMPATIBILITY HACK !!!! -! for a homogeneous mesh, all elements have the same number of IPs and and cell nodes. -! hence, xxPerElem instead of maxXX - mesh_NipsPerElem = mesh_maxNips - mesh_NcellnodesPerElem = mesh_maxNcellnodes + ! better name mesh_homogenizationAt = mesh_element(3,:) mesh_microstructureAt = mesh_element(4,:) - mesh_CPnodeID = mesh_element(5:4+mesh_NipsPerElem,:) -!!!!!!!!!!!!!!!!!!!!!!!! + + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief check if the input file for Abaqus contains part info +!-------------------------------------------------------------------------------------------------- +logical function hasNoPart(fileUnit) + use IO, only: & + IO_stringPos, & + IO_stringValue, & + IO_lc + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: line + + hasNoPart = .true. + + rewind(fileUnit) + do + read(fileUnit,'(a65536)',END=620) line + chunkPos = IO_stringPos(line) + if (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) then + hasNoPart = .false. + exit + endif + enddo + +620 end function hasNoPart end subroutine mesh_init -#if defined(Marc4DAMASK) || defined(Abaqus) + + + + + + !-------------------------------------------------------------------------------------------------- -!> @brief Gives the FE to CP ID mapping by binary search through lookup array -!! valid questions (what) are 'elem', 'node' +!> @brief Count overall number of nodes and elements in mesh and stores them in +!! 'mesh_Nelems' and 'mesh_Nnodes' !-------------------------------------------------------------------------------------------------- -integer(pInt) function mesh_FEasCP(what,myID) - use IO, only: & - IO_lc +subroutine mesh_abaqus_count_nodesAndElements(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countDataLines, & + IO_error implicit none - character(len=*), intent(in) :: what - integer(pInt), intent(in) :: myID + integer(pInt), intent(in) :: fileUnit - integer(pInt), dimension(:,:), pointer :: lookupMap - integer(pInt) :: lower,upper,center + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: inPart - mesh_FEasCP = 0_pInt - select case(IO_lc(what(1:4))) - case('elem') - lookupMap => mesh_mapFEtoCPelem - case('node') - lookupMap => mesh_mapFEtoCPnode - case default - return - endselect + mesh_Nnodes = 0_pInt + mesh_Nelems = 0_pInt + + inPart = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. - lower = 1_pInt - upper = int(size(lookupMap,2_pInt),pInt) - - if (lookupMap(1_pInt,lower) == myID) then ! check at bounds QUESTION is it valid to extend bounds by 1 and just do binary search w/o init check at bounds? - mesh_FEasCP = lookupMap(2_pInt,lower) - return - elseif (lookupMap(1_pInt,upper) == myID) then - mesh_FEasCP = lookupMap(2_pInt,upper) - return - endif - binarySearch: do while (upper-lower > 1_pInt) - center = (lower+upper)/2_pInt - if (lookupMap(1_pInt,center) < myID) then - lower = center - elseif (lookupMap(1_pInt,center) > myID) then - upper = center - else - mesh_FEasCP = lookupMap(2_pInt,center) - exit + if (inPart .or. noPart) then + select case ( IO_lc(IO_stringValue(line,chunkPos,1_pInt))) + case('*node') + if( & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'print' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'file' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' & + ) & + mesh_Nnodes = mesh_Nnodes + IO_countDataLines(fileUnit) + case('*element') + if( & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'matrix' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' & + ) then + mesh_Nelems = mesh_Nelems + IO_countDataLines(fileUnit) + endif + endselect endif - enddo binarySearch + enddo + + if (mesh_Nnodes < 2_pInt) call IO_error(error_ID=900_pInt) + if (mesh_Nelems == 0_pInt) call IO_error(error_ID=901_pInt) + +end subroutine mesh_abaqus_count_nodesAndElements + + +!-------------------------------------------------------------------------------------------------- +!> @brief count overall number of element sets in mesh and write 'mesh_NelemSets' and +!! 'mesh_maxNelemInSet' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_count_elementSets(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: inPart + + mesh_NelemSets = 0_pInt + mesh_maxNelemInSet = mesh_Nelems ! have to be conservative, since Abaqus allows for recursive definitons + + inPart = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*elset' ) & + mesh_NelemSets = mesh_NelemSets + 1_pInt + enddo + + if (mesh_NelemSets == 0) call IO_error(error_ID=902_pInt) + +end subroutine mesh_abaqus_count_elementSets + + +!-------------------------------------------------------------------------------------------------- +! count overall number of solid sections sets in mesh (Abaqus only) +! +! mesh_Nmaterials +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_count_materials(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: inPart + + mesh_Nmaterials = 0_pInt + + inPart = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if ( (inPart .or. noPart) .and. & + IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == '*solid' .and. & + IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'section' ) & + mesh_Nmaterials = mesh_Nmaterials + 1_pInt + enddo + + if (mesh_Nmaterials == 0_pInt) call IO_error(error_ID=903_pInt) + +end subroutine mesh_abaqus_count_materials + + +!-------------------------------------------------------------------------------------------------- +! Build element set mapping +! +! allocate globals: mesh_nameElemSet, mesh_mapElemSet +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_map_elementSets(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue, & + IO_continuousIntValues, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: inPart + integer(pInt) :: elemSet,i + + allocate (mesh_nameElemSet(mesh_NelemSets)); mesh_nameElemSet = '' + allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets),source=0_pInt) + + + elemSet = 0_pInt + inPart = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*elset' ) then + elemSet = elemSet + 1_pInt + mesh_nameElemSet(elemSet) = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'elset')) + mesh_mapElemSet(:,elemSet) = IO_continuousIntValues(fileUnit,mesh_Nelems,mesh_nameElemSet,& + mesh_mapElemSet,elemSet-1_pInt) + endif + enddo + + do i = 1_pInt,elemSet + if (mesh_mapElemSet(1,i) == 0_pInt) call IO_error(error_ID=904_pInt,ext_msg=mesh_nameElemSet(i)) + enddo + +end subroutine mesh_abaqus_map_elementSets + + +!-------------------------------------------------------------------------------------------------- +! map solid section (Abaqus only) +! +! allocate globals: mesh_nameMaterial, mesh_mapMaterial +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_map_materials(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: inPart + integer(pInt) :: i,c + character(len=64) :: elemSetName,materialName + + allocate (mesh_nameMaterial(mesh_Nmaterials)); mesh_nameMaterial = '' + allocate (mesh_mapMaterial(mesh_Nmaterials)); mesh_mapMaterial = '' + + c = 0_pInt + inPart = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if ( (inPart .or. noPart) .and. & + IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == '*solid' .and. & + IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'section' ) then + + elemSetName = '' + materialName = '' + + do i = 3_pInt,chunkPos(1_pInt) + if (IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'elset') /= '') & + elemSetName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'elset')) + if (IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'material') /= '') & + materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'material')) + enddo + + if (elemSetName /= '' .and. materialName /= '') then + c = c + 1_pInt + mesh_nameMaterial(c) = materialName ! name of material used for this section + mesh_mapMaterial(c) = elemSetName ! mapped to respective element set + endif + endif + enddo + + if (c==0_pInt) call IO_error(error_ID=905_pInt) + do i=1_pInt,c + if (mesh_nameMaterial(i)=='' .or. mesh_mapMaterial(i)=='') call IO_error(error_ID=905_pInt) + enddo + + end subroutine mesh_abaqus_map_materials + + +!-------------------------------------------------------------------------------------------------- +!> @brief Count overall number of CP elements in mesh and stores them in 'mesh_NcpElems' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_count_cpElements(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error, & + IO_extractValue + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: materialFound + integer(pInt) :: i,k + character(len=64) ::materialName,elemSetName + + mesh_NcpElems = 0_pInt + materialFound = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + select case ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ) + case('*material') + materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'name')) ! extract name=value + materialFound = materialName /= '' ! valid name? + case('*user') + if (IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'material' .and. materialFound) then + do i = 1_pInt,mesh_Nmaterials ! look thru material names + if (materialName == mesh_nameMaterial(i)) then ! found one + elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet + do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions + if (elemSetName == mesh_nameElemSet(k)) & ! matched? + mesh_NcpElems = mesh_NcpElems + mesh_mapElemSet(1,k) ! add those elem count + enddo + endif + enddo + materialFound = .false. + endif + endselect + enddo + + if (mesh_NcpElems == 0_pInt) call IO_error(error_ID=906_pInt) + +end subroutine mesh_abaqus_count_cpElements + + +!-------------------------------------------------------------------------------------------------- +!> @brief Maps elements from FE ID to internal (consecutive) representation. +!! Allocates global array 'mesh_mapFEtoCPelem' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_map_elements(fileUnit) + + use math, only: math_qsort + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: materialFound + integer(pInt) ::i,j,k,cpElem + character (len=64) materialName,elemSetName ! why limited to 64? ABAQUS? + + allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems), source = 0_pInt) + + cpElem = 0_pInt + materialFound = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + select case ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ) + case('*material') + materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'name')) ! extract name=value + materialFound = materialName /= '' ! valid name? + case('*user') + if (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'material' .and. materialFound) then + do i = 1_pInt,mesh_Nmaterials ! look thru material names + if (materialName == mesh_nameMaterial(i)) then ! found one + elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet + do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions + if (elemSetName == mesh_nameElemSet(k)) then ! matched? + do j = 1_pInt,mesh_mapElemSet(1,k) + cpElem = cpElem + 1_pInt + mesh_mapFEtoCPelem(1,cpElem) = mesh_mapElemSet(1_pInt+j,k) ! store FE id + mesh_mapFEtoCPelem(2,cpElem) = cpElem ! store our id + enddo + endif + enddo + endif + enddo + materialFound = .false. + endif + endselect + enddo + + call math_qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems + + if (int(size(mesh_mapFEtoCPelem),pInt) < 2_pInt) call IO_error(error_ID=907_pInt) + +end subroutine mesh_abaqus_map_elements + + +!-------------------------------------------------------------------------------------------------- +!> @brief Maps node from FE ID to internal (consecutive) representation. +!! Allocates global array 'mesh_mapFEtoCPnode' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_map_nodes(fileUnit) + + use math, only: math_qsort + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countDataLines, & + IO_intValue, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: inPart + integer(pInt) :: i,c,cpNode + + allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes), source=0_pInt) + + cpNode = 0_pInt + inPart = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if( (inPart .or. noPart) .and. & + IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*node' .and. & + ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'print' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'file' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & + ) then + c = IO_countDataLines(fileUnit) + do i = 1_pInt,c + backspace(fileUnit) + enddo + do i = 1_pInt,c + read (fileUnit,'(a300)') line + chunkPos = IO_stringPos(line) + cpNode = cpNode + 1_pInt + mesh_mapFEtoCPnode(1_pInt,cpNode) = IO_intValue(line,chunkPos,1_pInt) + mesh_mapFEtoCPnode(2_pInt,cpNode) = cpNode + enddo + endif + enddo + + call math_qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) + + if (int(size(mesh_mapFEtoCPnode),pInt) == 0_pInt) call IO_error(error_ID=908_pInt) + +end subroutine mesh_abaqus_map_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief store x,y,z coordinates of all nodes in mesh. +!! Allocates global arrays 'mesh_node0' and 'mesh_node' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_build_nodes(fileUnit) + use IO, only: & + IO_lc, & + IO_stringValue, & + IO_floatValue, & + IO_stringPos, & + IO_error, & + IO_countDataLines, & + IO_intValue + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: inPart + integer(pInt) :: i,j,m,c + + allocate ( mesh_node0 (3,mesh_Nnodes), source=0.0_pReal) + allocate ( mesh_node (3,mesh_Nnodes), source=0.0_pReal) + + inPart = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if( (inPart .or. noPart) .and. & + IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*node' .and. & + ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'print' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'file' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & + ) then + c = IO_countDataLines(fileUnit) ! how many nodes are defined here? + do i = 1_pInt,c + backspace(fileUnit) ! rewind to first entry + enddo + do i = 1_pInt,c + read (fileUnit,'(a300)') line + chunkPos = IO_stringPos(line) + m = mesh_FEasCP('node',IO_intValue(line,chunkPos,1_pInt)) + do j=1_pInt, 3_pInt + mesh_node0(j,m) = mesh_unitlength * IO_floatValue(line,chunkPos,j+1_pInt) + enddo + enddo + endif + enddo + + if (int(size(mesh_node0,2_pInt),pInt) /= mesh_Nnodes) call IO_error(error_ID=909_pInt) + mesh_node = mesh_node0 + +end subroutine mesh_abaqus_build_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Gets maximum count of nodes, IPs, IP neighbors, and subNodes among cpElements. +!! Sets global values 'mesh_maxNnodes', 'mesh_maxNips', 'mesh_maxNipNeighbors', +!! and 'mesh_maxNcellnodes' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_count_cpSizes(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue ,& + IO_error, & + IO_countDataLines, & + IO_intValue + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: inPart + integer(pInt) :: i,c,t,g + + mesh_maxNnodes = 0_pInt + mesh_maxNips = 0_pInt + mesh_maxNipNeighbors = 0_pInt + mesh_maxNcellnodes = 0_pInt + + + inPart = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if( (inPart .or. noPart) .and. & + IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*element' .and. & + ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'matrix' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & + ) then + t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'type')) ! remember elem type + g = FE_geomtype(t) + c = FE_celltype(g) + mesh_maxNnodes = max(mesh_maxNnodes,FE_Nnodes(t)) + mesh_maxNips = max(mesh_maxNips,FE_Nips(g)) + mesh_maxNipNeighbors = max(mesh_maxNipNeighbors,FE_NipNeighbors(c)) + mesh_maxNcellnodes = max(mesh_maxNcellnodes,FE_Ncellnodes(g)) + endif + enddo + +end subroutine mesh_abaqus_count_cpSizes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Store FEid, type, mat, tex, and node list per elemen. +!! Allocates global array 'mesh_element' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_build_elements(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_intValue, & + IO_extractValue, & + IO_floatValue, & + IO_countDataLines, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + logical :: inPart, materialFound + integer(pInt) :: i,j,k,c,e,t,homog,micro, nNodesAlreadyRead + character (len=64) :: materialName,elemSetName + + allocate(mesh_element (4_pInt+mesh_maxNnodes,mesh_NcpElems), source=0_pInt) + mesh_elemType = -1_pInt + + inPart = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if( (inPart .or. noPart) .and. & + IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*element' .and. & + ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'matrix' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & + ) then + t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'type')) ! remember elem type + c = IO_countDataLines(fileUnit) + do i = 1_pInt,c + backspace(fileUnit) + enddo + do i = 1_pInt,c + read (fileUnit,'(a300)') line + chunkPos = IO_stringPos(line) ! limit to 64 nodes max + e = mesh_FEasCP('elem',IO_intValue(line,chunkPos,1_pInt)) + if (e /= 0_pInt) then ! disregard non CP elems + mesh_element(1,e) = -1_pInt ! DEPRECATED + if (mesh_elemType /= t .and. mesh_elemType /= -1_pInt) & + call IO_error(191,el=t,ip=mesh_elemType) + mesh_elemType = t + mesh_element(2,e) = t ! elem type + nNodesAlreadyRead = 0_pInt + do j = 1_pInt,chunkPos(1)-1_pInt + mesh_element(4_pInt+j,e) = mesh_FEasCP('node',IO_intValue(line,chunkPos,1_pInt+j)) ! put CP ids of nodes to position 5: + enddo + nNodesAlreadyRead = chunkPos(1) - 1_pInt + do while(nNodesAlreadyRead < FE_Nnodes(t)) ! read on if not all nodes in one line + read (fileUnit,'(a300)') line + chunkPos = IO_stringPos(line) + do j = 1_pInt,chunkPos(1) + mesh_element(4_pInt+nNodesAlreadyRead+j,e) & + = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j)) ! CP ids of nodes + enddo + nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) + enddo + endif + enddo + endif + enddo + + + rewind(fileUnit) ! just in case "*material" definitions apear before "*element" + + materialFound = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + select case ( IO_lc(IO_StringValue(line,chunkPos,1_pInt))) + case('*material') + materialName = trim(IO_extractValue(IO_lc(IO_StringValue(line,chunkPos,2_pInt)),'name')) ! extract name=value + materialFound = materialName /= '' ! valid name? + case('*user') + if ( IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'material' .and. & + materialFound ) then + read (fileUnit,'(a300)') line ! read homogenization and microstructure + chunkPos = IO_stringPos(line) + homog = nint(IO_floatValue(line,chunkPos,1_pInt),pInt) + micro = nint(IO_floatValue(line,chunkPos,2_pInt),pInt) + do i = 1_pInt,mesh_Nmaterials ! look thru material names + if (materialName == mesh_nameMaterial(i)) then ! found one + elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet + do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions + if (elemSetName == mesh_nameElemSet(k)) then ! matched? + do j = 1_pInt,mesh_mapElemSet(1,k) + e = mesh_FEasCP('elem',mesh_mapElemSet(1+j,k)) + mesh_element(3,e) = homog ! store homogenization + mesh_element(4,e) = micro ! store microstructure + mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),homog) + mesh_maxValStateVar(2) = max(mesh_maxValStateVar(2),micro) + enddo + endif + enddo + endif + enddo + materialFound = .false. + endif + endselect + enddo + +end subroutine mesh_abaqus_build_elements + + +!-------------------------------------------------------------------------------------------------- +!> @brief get any additional damask options from input file, sets mesh_periodicSurface +!-------------------------------------------------------------------------------------------------- +subroutine mesh_get_damaskOptions(periodic_surface,fileUnit) + +use IO, only: & + IO_lc, & + IO_stringValue, & + IO_stringPos + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + integer(pInt) :: chunk, Nchunks + character(len=300) :: v + logical, dimension(3) :: periodic_surface + + + periodic_surface = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + Nchunks = chunkPos(1) + if (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '**damask' .and. Nchunks > 1_pInt) then ! found keyword for damask option and there is at least one more chunk to read + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case('periodic') ! damask Option that allows to specify periodic fluxes + do chunk = 3_pInt,Nchunks ! loop through chunks (skipping the keyword) + v = IO_lc(IO_stringValue(line,chunkPos,chunk)) ! chunk matches keyvalues x,y, or z? + mesh_periodicSurface(1) = mesh_periodicSurface(1) .or. v == 'x' + mesh_periodicSurface(2) = mesh_periodicSurface(2) .or. v == 'y' + mesh_periodicSurface(3) = mesh_periodicSurface(3) .or. v == 'z' + enddo + endselect + endif + enddo + +end subroutine mesh_get_damaskOptions -end function mesh_FEasCP -#endif !-------------------------------------------------------------------------------------------------- !> @brief Split CP elements into cells. @@ -837,10 +1426,7 @@ subroutine mesh_build_ipVolumes integer(pInt) :: e,t,g,c,i,m,f,n real(pReal), dimension(FE_maxNcellnodesPerCellface,FE_maxNcellfaces) :: subvolume - if (.not. allocated(mesh_ipVolume)) then - allocate(mesh_ipVolume(mesh_maxNips,mesh_NcpElems)) - mesh_ipVolume = 0.0_pReal - endif + allocate(mesh_ipVolume(mesh_maxNips,mesh_NcpElems),source=0.0_pReal) !$OMP PARALLEL DO PRIVATE(t,g,c,m,subvolume) do e = 1_pInt,mesh_NcpElems ! loop over cpElems @@ -953,1903 +1539,8 @@ pure function mesh_cellCenterCoordinates(ip,el) end function mesh_cellCenterCoordinates -#ifdef Spectral -!-------------------------------------------------------------------------------------------------- -!> @brief Reads grid information from geometry file. If fileUnit is given, -!! assumes an opened file, otherwise tries to open the one specified in geometryFile -!-------------------------------------------------------------------------------------------------- -function mesh_spectral_getGrid(fileUnit) - use IO, only: & - IO_checkAndRewind, & - IO_open_file, & - IO_stringPos, & - IO_lc, & - IO_stringValue, & - IO_intValue, & - IO_floatValue, & - IO_error - use DAMASK_interface, only: & - geometryFile - implicit none - integer(pInt), dimension(3) :: mesh_spectral_getGrid - integer(pInt), intent(in), optional :: fileUnit - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: headerLength = 0_pInt - character(len=1024) :: line, & - keyword - integer(pInt) :: i, j, myFileUnit - logical :: gotGrid = .false. - - mesh_spectral_getGrid = -1_pInt - if(.not. present(fileUnit)) then - myFileUnit = 289_pInt - call IO_open_file(myFileUnit,trim(geometryFile)) - else - myFileUnit = fileUnit - endif - - call IO_checkAndRewind(myFileUnit) - - read(myFileUnit,'(a1024)') line - chunkPos = IO_stringPos(line) - keyword = IO_lc(IO_StringValue(line,chunkPos,2_pInt,.true.)) - if (keyword(1:4) == 'head') then - headerLength = IO_intValue(line,chunkPos,1_pInt) + 1_pInt - else - call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_getGrid') - endif - rewind(myFileUnit) - do i = 1_pInt, headerLength - read(myFileUnit,'(a1024)') line - chunkPos = IO_stringPos(line) - select case ( IO_lc(IO_StringValue(line,chunkPos,1_pInt,.true.)) ) - case ('grid') - gotGrid = .true. - do j = 2_pInt,6_pInt,2_pInt - select case (IO_lc(IO_stringValue(line,chunkPos,j))) - case('a') - mesh_spectral_getGrid(1) = IO_intValue(line,chunkPos,j+1_pInt) - case('b') - mesh_spectral_getGrid(2) = IO_intValue(line,chunkPos,j+1_pInt) - case('c') - mesh_spectral_getGrid(3) = IO_intValue(line,chunkPos,j+1_pInt) - end select - enddo - end select - enddo - - if(.not. present(fileUnit)) close(myFileUnit) - - if (.not. gotGrid) & - call IO_error(error_ID = 845_pInt, ext_msg='grid') - if(any(mesh_spectral_getGrid < 1_pInt)) & - call IO_error(error_ID = 843_pInt, ext_msg='mesh_spectral_getGrid') - -end function mesh_spectral_getGrid - - -!-------------------------------------------------------------------------------------------------- -!> @brief Reads size information from geometry file. If fileUnit is given, -!! assumes an opened file, otherwise tries to open the one specified in geometryFile -!-------------------------------------------------------------------------------------------------- -function mesh_spectral_getSize(fileUnit) - use IO, only: & - IO_checkAndRewind, & - IO_open_file, & - IO_stringPos, & - IO_lc, & - IO_stringValue, & - IO_intValue, & - IO_floatValue, & - IO_error - use DAMASK_interface, only: & - geometryFile - - implicit none - real(pReal), dimension(3) :: mesh_spectral_getSize - integer(pInt), intent(in), optional :: fileUnit - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: headerLength = 0_pInt - character(len=1024) :: line, & - keyword - integer(pInt) :: i, j, myFileUnit - logical :: gotSize = .false. - - mesh_spectral_getSize = -1.0_pReal - if(.not. present(fileUnit)) then - myFileUnit = 289_pInt - call IO_open_file(myFileUnit,trim(geometryFile)) - else - myFileUnit = fileUnit - endif - - call IO_checkAndRewind(myFileUnit) - - read(myFileUnit,'(a1024)') line - chunkPos = IO_stringPos(line) - keyword = IO_lc(IO_StringValue(line,chunkPos,2_pInt,.true.)) - if (keyword(1:4) == 'head') then - headerLength = IO_intValue(line,chunkPos,1_pInt) + 1_pInt - else - call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_getSize') - endif - rewind(myFileUnit) - do i = 1_pInt, headerLength - read(myFileUnit,'(a1024)') line - chunkPos = IO_stringPos(line) - select case ( IO_lc(IO_StringValue(line,chunkPos,1,.true.)) ) - case ('size') - gotSize = .true. - do j = 2_pInt,6_pInt,2_pInt - select case (IO_lc(IO_stringValue(line,chunkPos,j))) - case('x') - mesh_spectral_getSize(1) = IO_floatValue(line,chunkPos,j+1_pInt) - case('y') - mesh_spectral_getSize(2) = IO_floatValue(line,chunkPos,j+1_pInt) - case('z') - mesh_spectral_getSize(3) = IO_floatValue(line,chunkPos,j+1_pInt) - end select - enddo - end select - enddo - - if(.not. present(fileUnit)) close(myFileUnit) - - if (.not. gotSize) & - call IO_error(error_ID = 845_pInt, ext_msg='size') - if (any(mesh_spectral_getSize<=0.0_pReal)) & - call IO_error(error_ID = 844_pInt, ext_msg='mesh_spectral_getSize') - -end function mesh_spectral_getSize - - -!-------------------------------------------------------------------------------------------------- -!> @brief Reads homogenization information from geometry file. If fileUnit is given, -!! assumes an opened file, otherwise tries to open the one specified in geometryFile -!-------------------------------------------------------------------------------------------------- -integer(pInt) function mesh_spectral_getHomogenization(fileUnit) - use IO, only: & - IO_checkAndRewind, & - IO_open_file, & - IO_stringPos, & - IO_lc, & - IO_stringValue, & - IO_intValue, & - IO_error - use DAMASK_interface, only: & - geometryFile - - implicit none - integer(pInt), intent(in), optional :: fileUnit - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: headerLength = 0_pInt - character(len=1024) :: line, & - keyword - integer(pInt) :: i, myFileUnit - logical :: gotHomogenization = .false. - - mesh_spectral_getHomogenization = -1_pInt - if(.not. present(fileUnit)) then - myFileUnit = 289_pInt - call IO_open_file(myFileUnit,trim(geometryFile)) - else - myFileUnit = fileUnit - endif - - call IO_checkAndRewind(myFileUnit) - - read(myFileUnit,'(a1024)') line - chunkPos = IO_stringPos(line) - keyword = IO_lc(IO_StringValue(line,chunkPos,2_pInt,.true.)) - if (keyword(1:4) == 'head') then - headerLength = IO_intValue(line,chunkPos,1_pInt) + 1_pInt - else - call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_getHomogenization') - endif - rewind(myFileUnit) - do i = 1_pInt, headerLength - read(myFileUnit,'(a1024)') line - chunkPos = IO_stringPos(line) - select case ( IO_lc(IO_StringValue(line,chunkPos,1,.true.)) ) - case ('homogenization') - gotHomogenization = .true. - mesh_spectral_getHomogenization = IO_intValue(line,chunkPos,2_pInt) - end select - enddo - - if(.not. present(fileUnit)) close(myFileUnit) - - if (.not. gotHomogenization ) & - call IO_error(error_ID = 845_pInt, ext_msg='homogenization') - if (mesh_spectral_getHomogenization<1_pInt) & - call IO_error(error_ID = 842_pInt, ext_msg='mesh_spectral_getHomogenization') - -end function mesh_spectral_getHomogenization - - -!-------------------------------------------------------------------------------------------------- -!> @brief Count overall number of nodes and elements in mesh and stores them in -!! 'mesh_Nelems', 'mesh_Nnodes' and 'mesh_NcpElems' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_spectral_count() - - implicit none - - mesh_NcpElems= product(grid(1:2))*grid3 - mesh_Nnodes = product(grid(1:2) + 1_pInt)*(grid3 + 1_pInt) - - mesh_NcpElemsGlobal = product(grid) - -end subroutine mesh_spectral_count - - -!-------------------------------------------------------------------------------------------------- -!> @brief Gets maximum count of nodes, IPs, IP neighbors, and subNodes among cpElements. -!! Sets global values 'mesh_maxNips', 'mesh_maxNipNeighbors', -!! and 'mesh_maxNcellnodes' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_spectral_count_cpSizes - - implicit none - integer(pInt) :: t,g,c - - t = FE_mapElemtype('C3D8R') ! fake 3D hexahedral 8 node 1 IP element - g = FE_geomtype(t) - c = FE_celltype(g) - - mesh_maxNips = FE_Nips(g) - mesh_maxNipNeighbors = FE_NipNeighbors(c) - mesh_maxNcellnodes = FE_Ncellnodes(g) - -end subroutine mesh_spectral_count_cpSizes - - -!-------------------------------------------------------------------------------------------------- -!> @brief Store x,y,z coordinates of all nodes in mesh. -!! Allocates global arrays 'mesh_node0' and 'mesh_node' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_spectral_build_nodes() - - implicit none - integer(pInt) :: n - - allocate (mesh_node0 (3,mesh_Nnodes), source = 0.0_pReal) - allocate (mesh_node (3,mesh_Nnodes), source = 0.0_pReal) - - forall (n = 0_pInt:mesh_Nnodes-1_pInt) - mesh_node0(1,n+1_pInt) = mesh_unitlength * & - geomSize(1)*real(mod(n,(grid(1)+1_pInt) ),pReal) & - / real(grid(1),pReal) - mesh_node0(2,n+1_pInt) = mesh_unitlength * & - geomSize(2)*real(mod(n/(grid(1)+1_pInt),(grid(2)+1_pInt)),pReal) & - / real(grid(2),pReal) - mesh_node0(3,n+1_pInt) = mesh_unitlength * & - size3*real(mod(n/(grid(1)+1_pInt)/(grid(2)+1_pInt),(grid3+1_pInt)),pReal) & - / real(grid3,pReal) + & - size3offset - end forall - - mesh_node = mesh_node0 - -end subroutine mesh_spectral_build_nodes - - -!-------------------------------------------------------------------------------------------------- -!> @brief Store FEid, type, material, texture, and node list per element. -!! Allocates global array 'mesh_element' -!> @todo does the IO_error makes sense? -!-------------------------------------------------------------------------------------------------- -subroutine mesh_spectral_build_elements(fileUnit) - use IO, only: & - IO_checkAndRewind, & - IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_error, & - IO_continuousIntValues, & - IO_intValue, & - IO_countContinuousIntValues - - implicit none - integer(pInt), intent(in) :: & - fileUnit - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: & - e, i, & - headerLength = 0_pInt, & - maxDataPerLine, & - homog, & - elemType, & - elemOffset - integer(pInt), dimension(:), allocatable :: & - microstructures, & - microGlobal - integer(pInt), dimension(1,1) :: & - dummySet = 0_pInt - character(len=65536) :: & - line, & - keyword - character(len=64), dimension(1) :: & - dummyName = '' - - homog = mesh_spectral_getHomogenization(fileUnit) - -!-------------------------------------------------------------------------------------------------- -! get header length - call IO_checkAndRewind(fileUnit) - read(fileUnit,'(a65536)') line - chunkPos = IO_stringPos(line) - keyword = IO_lc(IO_StringValue(line,chunkPos,2_pInt,.true.)) - if (keyword(1:4) == 'head') then - headerLength = IO_intValue(line,chunkPos,1_pInt) + 1_pInt - else - call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_build_elements') - endif - -!-------------------------------------------------------------------------------------------------- -! get maximum microstructure index - call IO_checkAndRewind(fileUnit) - do i = 1_pInt, headerLength - read(fileUnit,'(a65536)') line - enddo - - maxDataPerLine = 0_pInt - i = 1_pInt - - do while (i > 0_pInt) - i = IO_countContinuousIntValues(fileUnit) - maxDataPerLine = max(maxDataPerLine, i) ! found a longer line? - enddo - allocate(mesh_element (4_pInt+8_pInt,mesh_NcpElems), source = 0_pInt) - allocate(microstructures (1_pInt+maxDataPerLine), source = 1_pInt) ! prepare to receive counter and max data size - allocate(microGlobal (mesh_NcpElemsGlobal), source = 1_pInt) - -!-------------------------------------------------------------------------------------------------- -! read in microstructures - call IO_checkAndRewind(fileUnit) - do i=1_pInt,headerLength - read(fileUnit,'(a65536)') line - enddo - - e = 0_pInt - do while (e < mesh_NcpElemsGlobal .and. microstructures(1) > 0_pInt) ! fill expected number of elements, stop at end of data (or blank line!) - microstructures = IO_continuousIntValues(fileUnit,maxDataPerLine,dummyName,dummySet,0_pInt) ! get affected elements - do i = 1_pInt,microstructures(1_pInt) - e = e+1_pInt ! valid element entry - microGlobal(e) = microstructures(1_pInt+i) - enddo - enddo - - elemType = FE_mapElemtype('C3D8R') - elemOffset = product(grid(1:2))*grid3Offset - e = 0_pInt - do while (e < mesh_NcpElems) ! fill expected number of elements, stop at end of data (or blank line!) - e = e+1_pInt ! valid element entry - mesh_element( 1,e) = -1_pInt ! DEPRECATED - mesh_element( 2,e) = elemType ! elem type - mesh_element( 3,e) = homog ! homogenization - mesh_element( 4,e) = microGlobal(e+elemOffset) ! microstructure - mesh_element( 5,e) = e + (e-1_pInt)/grid(1) + & - ((e-1_pInt)/(grid(1)*grid(2)))*(grid(1)+1_pInt) ! base node - mesh_element( 6,e) = mesh_element(5,e) + 1_pInt - mesh_element( 7,e) = mesh_element(5,e) + grid(1) + 2_pInt - mesh_element( 8,e) = mesh_element(5,e) + grid(1) + 1_pInt - mesh_element( 9,e) = mesh_element(5,e) +(grid(1) + 1_pInt) * (grid(2) + 1_pInt) ! second floor base node - mesh_element(10,e) = mesh_element(9,e) + 1_pInt - mesh_element(11,e) = mesh_element(9,e) + grid(1) + 2_pInt - mesh_element(12,e) = mesh_element(9,e) + grid(1) + 1_pInt - mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),mesh_element(3,e)) ! needed for statistics - mesh_maxValStateVar(2) = max(mesh_maxValStateVar(2),mesh_element(4,e)) - enddo - - if (e /= mesh_NcpElems) call IO_error(880_pInt,e) - -end subroutine mesh_spectral_build_elements - - -!-------------------------------------------------------------------------------------------------- -!> @brief build neighborhood relations for spectral -!> @details assign globals: mesh_ipNeighborhood -!-------------------------------------------------------------------------------------------------- -subroutine mesh_spectral_build_ipNeighborhood - - implicit none - integer(pInt) :: & - x,y,z, & - e - allocate(mesh_ipNeighborhood(3,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems),source=0_pInt) - - e = 0_pInt - do z = 0_pInt,grid3-1_pInt - do y = 0_pInt,grid(2)-1_pInt - do x = 0_pInt,grid(1)-1_pInt - e = e + 1_pInt - mesh_ipNeighborhood(1,1,1,e) = z * grid(1) * grid(2) & - + y * grid(1) & - + modulo(x+1_pInt,grid(1)) & - + 1_pInt - mesh_ipNeighborhood(1,2,1,e) = z * grid(1) * grid(2) & - + y * grid(1) & - + modulo(x-1_pInt,grid(1)) & - + 1_pInt - mesh_ipNeighborhood(1,3,1,e) = z * grid(1) * grid(2) & - + modulo(y+1_pInt,grid(2)) * grid(1) & - + x & - + 1_pInt - mesh_ipNeighborhood(1,4,1,e) = z * grid(1) * grid(2) & - + modulo(y-1_pInt,grid(2)) * grid(1) & - + x & - + 1_pInt - mesh_ipNeighborhood(1,5,1,e) = modulo(z+1_pInt,grid3) * grid(1) * grid(2) & - + y * grid(1) & - + x & - + 1_pInt - mesh_ipNeighborhood(1,6,1,e) = modulo(z-1_pInt,grid3) * grid(1) * grid(2) & - + y * grid(1) & - + x & - + 1_pInt - mesh_ipNeighborhood(2,1:6,1,e) = 1_pInt - mesh_ipNeighborhood(3,1,1,e) = 2_pInt - mesh_ipNeighborhood(3,2,1,e) = 1_pInt - mesh_ipNeighborhood(3,3,1,e) = 4_pInt - mesh_ipNeighborhood(3,4,1,e) = 3_pInt - mesh_ipNeighborhood(3,5,1,e) = 6_pInt - mesh_ipNeighborhood(3,6,1,e) = 5_pInt - enddo - enddo - enddo - -end subroutine mesh_spectral_build_ipNeighborhood - - -!-------------------------------------------------------------------------------------------------- -!> @brief builds mesh of (distorted) cubes for given coordinates (= center of the cubes) -!-------------------------------------------------------------------------------------------------- -function mesh_nodesAroundCentres(gDim,Favg,centres) result(nodes) - use debug, only: & - debug_mesh, & - debug_level, & - debug_levelBasic - use math, only: & - math_mul33x3 - - implicit none - real(pReal), intent(in), dimension(:,:,:,:) :: & - centres - real(pReal), dimension(3,size(centres,2)+1,size(centres,3)+1,size(centres,4)+1) :: & - nodes - real(pReal), intent(in), dimension(3) :: & - gDim - real(pReal), intent(in), dimension(3,3) :: & - Favg - real(pReal), dimension(3,size(centres,2)+2,size(centres,3)+2,size(centres,4)+2) :: & - wrappedCentres - - integer(pInt) :: & - i,j,k,n - integer(pInt), dimension(3), parameter :: & - diag = 1_pInt - integer(pInt), dimension(3) :: & - shift = 0_pInt, & - lookup = 0_pInt, & - me = 0_pInt, & - iRes = 0_pInt - integer(pInt), dimension(3,8) :: & - neighbor = reshape([ & - 0_pInt, 0_pInt, 0_pInt, & - 1_pInt, 0_pInt, 0_pInt, & - 1_pInt, 1_pInt, 0_pInt, & - 0_pInt, 1_pInt, 0_pInt, & - 0_pInt, 0_pInt, 1_pInt, & - 1_pInt, 0_pInt, 1_pInt, & - 1_pInt, 1_pInt, 1_pInt, & - 0_pInt, 1_pInt, 1_pInt ], [3,8]) - -!-------------------------------------------------------------------------------------------------- -! initializing variables - iRes = [size(centres,2),size(centres,3),size(centres,4)] - nodes = 0.0_pReal - wrappedCentres = 0.0_pReal - -!-------------------------------------------------------------------------------------------------- -! report - if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then - write(6,'(a)') ' Meshing cubes around centroids' - write(6,'(a,3(e12.5))') ' Dimension: ', gDim - write(6,'(a,3(i5))') ' Resolution:', iRes - endif - -!-------------------------------------------------------------------------------------------------- -! building wrappedCentres = centroids + ghosts - wrappedCentres(1:3,2_pInt:iRes(1)+1_pInt,2_pInt:iRes(2)+1_pInt,2_pInt:iRes(3)+1_pInt) = centres - do k = 0_pInt,iRes(3)+1_pInt - do j = 0_pInt,iRes(2)+1_pInt - do i = 0_pInt,iRes(1)+1_pInt - if (k==0_pInt .or. k==iRes(3)+1_pInt .or. & ! z skin - j==0_pInt .or. j==iRes(2)+1_pInt .or. & ! y skin - i==0_pInt .or. i==iRes(1)+1_pInt ) then ! x skin - me = [i,j,k] ! me on skin - shift = sign(abs(iRes+diag-2_pInt*me)/(iRes+diag),iRes+diag-2_pInt*me) - lookup = me-diag+shift*iRes - wrappedCentres(1:3,i+1_pInt, j+1_pInt, k+1_pInt) = & - centres(1:3,lookup(1)+1_pInt,lookup(2)+1_pInt,lookup(3)+1_pInt) & - - math_mul33x3(Favg, real(shift,pReal)*gDim) - endif - enddo; enddo; enddo - -!-------------------------------------------------------------------------------------------------- -! averaging - do k = 0_pInt,iRes(3); do j = 0_pInt,iRes(2); do i = 0_pInt,iRes(1) - do n = 1_pInt,8_pInt - nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) = & - nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) + wrappedCentres(1:3,i+1_pInt+neighbor(1,n), & - j+1_pInt+neighbor(2,n), & - k+1_pInt+neighbor(3,n) ) - enddo - enddo; enddo; enddo - nodes = nodes/8.0_pReal - -end function mesh_nodesAroundCentres -#endif - -#ifdef Marc4DAMASK -!-------------------------------------------------------------------------------------------------- -!> @brief Figures out version of Marc input file format and stores ist as MarcVersion -!-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_get_fileFormat(fileUnit) - use IO, only: & - IO_lc, & - IO_intValue, & - IO_stringValue, & - IO_stringPos - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) line - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'version') then - MarcVersion = IO_intValue(line,chunkPos,2_pInt) - exit - endif - enddo - -620 end subroutine mesh_marc_get_fileFormat - - -!-------------------------------------------------------------------------------------------------- -!> @brief Figures out table styles (Marc only) and stores to 'initialcondTableStyle' and -!! 'hypoelasticTableStyle' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_get_tableStyles(fileUnit) - use IO, only: & - IO_lc, & - IO_intValue, & - IO_stringValue, & - IO_stringPos - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) line - - initialcondTableStyle = 0_pInt - hypoelasticTableStyle = 0_pInt - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'table' .and. chunkPos(1_pInt) > 5) then - initialcondTableStyle = IO_intValue(line,chunkPos,4_pInt) - hypoelasticTableStyle = IO_intValue(line,chunkPos,5_pInt) - exit - endif - enddo - -620 end subroutine mesh_marc_get_tableStyles - -!-------------------------------------------------------------------------------------------------- -!> @brief Figures out material number of hypoelastic material and stores it in Marc_matNumber array -!-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_get_matNumber(fileUnit) - use IO, only: & - IO_lc, & - IO_intValue, & - IO_stringValue, & - IO_stringPos - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: i, j, data_blocks - character(len=300) line - -610 FORMAT(A300) - - rewind(fileUnit) - - data_blocks = 1_pInt - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'hypoelastic') then - read (fileUnit,610,END=620) line - if (len(trim(line))/=0_pInt) then - chunkPos = IO_stringPos(line) - data_blocks = IO_intValue(line,chunkPos,1_pInt) - endif - allocate(Marc_matNumber(data_blocks)) - do i=1_pInt,data_blocks ! read all data blocks - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - Marc_matNumber(i) = IO_intValue(line,chunkPos,1_pInt) - do j=1_pint,2_pInt + hypoelasticTableStyle ! read 2 or 3 remaining lines of data block - read (fileUnit,610,END=620) line - enddo - enddo - exit - endif - enddo - -620 end subroutine mesh_marc_get_matNumber - - -!-------------------------------------------------------------------------------------------------- -!> @brief Count overall number of nodes and elements in mesh and stores the numbers in -!! 'mesh_Nelems' and 'mesh_Nnodes' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_count_nodesAndElements(fileUnit) - use IO, only: & - IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_IntValue - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) line - - mesh_Nnodes = 0_pInt - mesh_Nelems = 0_pInt - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - - if ( IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == 'sizing') & - mesh_Nelems = IO_IntValue (line,chunkPos,3_pInt) - if ( IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == 'coordinates') then - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - mesh_Nnodes = IO_IntValue (line,chunkPos,2_pInt) - exit ! assumes that "coordinates" comes later in file - endif - enddo - -620 end subroutine mesh_marc_count_nodesAndElements - - -!-------------------------------------------------------------------------------------------------- -!> @brief Count overall number of element sets in mesh. Stores to 'mesh_NelemSets', and -!! 'mesh_maxNelemInSet' -!-------------------------------------------------------------------------------------------------- - subroutine mesh_marc_count_elementSets(fileUnit) - use IO, only: & - IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_countContinuousIntValues - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) line - - mesh_NelemSets = 0_pInt - mesh_maxNelemInSet = 0_pInt - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - - if ( IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == 'define' .and. & - IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'element' ) then - mesh_NelemSets = mesh_NelemSets + 1_pInt - mesh_maxNelemInSet = max(mesh_maxNelemInSet, & - IO_countContinuousIntValues(fileUnit)) - endif - enddo - -620 end subroutine mesh_marc_count_elementSets - - -!******************************************************************** -! map element sets -! -! allocate globals: mesh_nameElemSet, mesh_mapElemSet -!******************************************************************** -subroutine mesh_marc_map_elementSets(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_continuousIntValues - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer(pInt) :: elemSet = 0_pInt - - allocate (mesh_nameElemSet(mesh_NelemSets)); mesh_nameElemSet = '' - allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets), source=0_pInt) - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=640) line - chunkPos = IO_stringPos(line) - if( (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'define' ) .and. & - (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'element' ) ) then - elemSet = elemSet+1_pInt - mesh_nameElemSet(elemSet) = trim(IO_stringValue(line,chunkPos,4_pInt)) - mesh_mapElemSet(:,elemSet) = & - IO_continuousIntValues(fileUnit,mesh_maxNelemInSet,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) - endif - enddo - -640 end subroutine mesh_marc_map_elementSets - - -!-------------------------------------------------------------------------------------------------- -!> @brief Count overall number of CP elements in mesh and stores them in 'mesh_NcpElems' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_count_cpElements(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_countContinuousIntValues, & - IO_error, & - IO_intValue, & - IO_countNumericalDataLines - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: i - character(len=300):: line - - mesh_NcpElems = 0_pInt - -610 FORMAT(A300) - - rewind(fileUnit) - if (MarcVersion < 13) then ! Marc 2016 or earlier - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'hypoelastic') then - do i=1_pInt,3_pInt+hypoelasticTableStyle ! Skip 3 or 4 lines - read (fileUnit,610,END=620) line - enddo - mesh_NcpElems = mesh_NcpElems + IO_countContinuousIntValues(fileUnit) ! why not simply mesh_NcpElems = IO_countContinuousIntValues(fileUnit)? not fully correct as hypoelastic can have multiple data fields, needs update - exit - endif - enddo - else ! Marc2017 and later - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'connectivity') then - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if (any(Marc_matNumber==IO_intValue(line,chunkPos,6_pInt))) then - mesh_NcpElems = mesh_NcpElems + IO_countNumericalDataLines(fileUnit) - endif - endif - enddo - end if - -620 end subroutine mesh_marc_count_cpElements - - -!-------------------------------------------------------------------------------------------------- -!> @brief Maps elements from FE ID to internal (consecutive) representation. -!! Allocates global array 'mesh_mapFEtoCPelem' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_map_elements(fileUnit) - - use math, only: math_qsort - use IO, only: IO_lc, & - IO_intValue, & - IO_stringValue, & - IO_stringPos, & - IO_continuousIntValues - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line, & - tmp - - integer(pInt), dimension (1_pInt+mesh_NcpElems) :: contInts - integer(pInt) :: i,cpElem = 0_pInt - - allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems), source = 0_pInt) - -610 FORMAT(A300) - - contInts = 0_pInt - rewind(fileUnit) - do - read (fileUnit,610,END=660) line - chunkPos = IO_stringPos(line) - if (MarcVersion < 13) then ! Marc 2016 or earlier - if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'hypoelastic' ) then - do i=1_pInt,3_pInt+hypoelasticTableStyle ! skip three (or four if new table style!) lines - read (fileUnit,610,END=660) line - enddo - contInts = IO_continuousIntValues(fileUnit,mesh_NcpElems,mesh_nameElemSet,& - mesh_mapElemSet,mesh_NelemSets) - exit - endif - else ! Marc2017 and later - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'connectivity') then - read (fileUnit,610,END=660) line - chunkPos = IO_stringPos(line) - if(any(Marc_matNumber==IO_intValue(line,chunkPos,6_pInt))) then - do - read (fileUnit,610,END=660) line - chunkPos = IO_stringPos(line) - tmp = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) - if (verify(trim(tmp),"0123456789")/=0) then ! found keyword - exit - else - contInts(1) = contInts(1) + 1_pInt - read (tmp,*) contInts(contInts(1)+1) - endif - enddo - endif - endif - endif - enddo -660 do i = 1_pInt,contInts(1) - cpElem = cpElem+1_pInt - mesh_mapFEtoCPelem(1,cpElem) = contInts(1_pInt+i) - mesh_mapFEtoCPelem(2,cpElem) = cpElem - enddo - -call math_qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems - -end subroutine mesh_marc_map_elements - - -!-------------------------------------------------------------------------------------------------- -!> @brief Maps node from FE ID to internal (consecutive) representation. -!! Allocates global array 'mesh_mapFEtoCPnode' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_map_nodes(fileUnit) - - use math, only: math_qsort - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_fixedIntValue - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) line - - integer(pInt), dimension (mesh_Nnodes) :: node_count - integer(pInt) :: i - - allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes),source=0_pInt) - -610 FORMAT(A300) - - node_count = 0_pInt - - rewind(fileUnit) - do - read (fileUnit,610,END=650) line - chunkPos = IO_stringPos(line) - if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'coordinates' ) then - read (fileUnit,610,END=650) line ! skip crap line - do i = 1_pInt,mesh_Nnodes - read (fileUnit,610,END=650) line - mesh_mapFEtoCPnode(1_pInt,i) = IO_fixedIntValue (line,[ 0_pInt,10_pInt],1_pInt) - mesh_mapFEtoCPnode(2_pInt,i) = i - enddo - exit - endif - enddo - -650 call math_qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) - -end subroutine mesh_marc_map_nodes - - -!-------------------------------------------------------------------------------------------------- -!> @brief store x,y,z coordinates of all nodes in mesh. -!! Allocates global arrays 'mesh_node0' and 'mesh_node' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_build_nodes(fileUnit) - - use IO, only: & - IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_fixedIntValue, & - IO_fixedNoEFloatValue - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), dimension(5), parameter :: node_ends = int([0,10,30,50,70],pInt) - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer(pInt) :: i,j,m - - allocate ( mesh_node0 (3,mesh_Nnodes), source=0.0_pReal) - allocate ( mesh_node (3,mesh_Nnodes), source=0.0_pReal) - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=670) line - chunkPos = IO_stringPos(line) - if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'coordinates' ) then - read (fileUnit,610,END=670) line ! skip crap line - do i=1_pInt,mesh_Nnodes - read (fileUnit,610,END=670) line - m = mesh_FEasCP('node',IO_fixedIntValue(line,node_ends,1_pInt)) - do j = 1_pInt,3_pInt - mesh_node0(j,m) = mesh_unitlength * IO_fixedNoEFloatValue(line,node_ends,j+1_pInt) - enddo - enddo - exit - endif - enddo - -670 mesh_node = mesh_node0 - -end subroutine mesh_marc_build_nodes - - -!-------------------------------------------------------------------------------------------------- -!> @brief Gets maximum count of nodes, IPs, IP neighbors, and cellnodes among cpElements. -!! Sets global values 'mesh_maxNnodes', 'mesh_maxNips', 'mesh_maxNipNeighbors', -!! and 'mesh_maxNcellnodes' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_count_cpSizes(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_intValue, & - IO_skipChunks - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer(pInt) :: i,t,g,e,c - - mesh_maxNnodes = 0_pInt - mesh_maxNips = 0_pInt - mesh_maxNipNeighbors = 0_pInt - mesh_maxNcellnodes = 0_pInt - -610 FORMAT(A300) - rewind(fileUnit) - do - read (fileUnit,610,END=630) line - chunkPos = IO_stringPos(line) - if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'connectivity' ) then - read (fileUnit,610,END=630) line ! Garbage line - do i=1_pInt,mesh_Nelems ! read all elements - read (fileUnit,610,END=630) line - chunkPos = IO_stringPos(line) ! limit to id and type - e = mesh_FEasCP('elem',IO_intValue(line,chunkPos,1_pInt)) - if (e /= 0_pInt) then - t = FE_mapElemtype(IO_stringValue(line,chunkPos,2_pInt)) - g = FE_geomtype(t) - c = FE_celltype(g) - mesh_maxNnodes = max(mesh_maxNnodes,FE_Nnodes(t)) - mesh_maxNips = max(mesh_maxNips,FE_Nips(g)) - mesh_maxNipNeighbors = max(mesh_maxNipNeighbors,FE_NipNeighbors(c)) - mesh_maxNcellnodes = max(mesh_maxNcellnodes,FE_Ncellnodes(g)) - call IO_skipChunks(fileUnit,FE_Nnodes(t)-(chunkPos(1_pInt)-2_pInt)) ! read on if FE_Nnodes exceeds node count present on current line - endif - enddo - exit - endif - enddo - -630 end subroutine mesh_marc_count_cpSizes - - -!-------------------------------------------------------------------------------------------------- -!> @brief Store FEid, type, mat, tex, and node list per element. -!! Allocates global array 'mesh_element' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_build_elements(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_fixedNoEFloatValue, & - IO_skipChunks, & - IO_stringPos, & - IO_intValue, & - IO_continuousIntValues, & - IO_error - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) line - - integer(pInt), dimension(1_pInt+mesh_NcpElems) :: contInts - integer(pInt) :: i,j,t,sv,myVal,e,nNodesAlreadyRead - - allocate(mesh_element(4_pInt+mesh_maxNnodes,mesh_NcpElems), source=0_pInt) - mesh_elemType = -1_pInt - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'connectivity' ) then - read (fileUnit,610,END=620) line ! garbage line - do i = 1_pInt,mesh_Nelems - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - e = mesh_FEasCP('elem',IO_intValue(line,chunkPos,1_pInt)) - if (e /= 0_pInt) then ! disregard non CP elems - mesh_element(1,e) = -1_pInt ! DEPRECATED - t = FE_mapElemtype(IO_StringValue(line,chunkPos,2_pInt)) ! elem type - if (mesh_elemType /= t .and. mesh_elemType /= -1_pInt) & - call IO_error(191,el=t,ip=mesh_elemType) - mesh_elemType = t - mesh_element(2,e) = t - nNodesAlreadyRead = 0_pInt - do j = 1_pInt,chunkPos(1)-2_pInt - mesh_element(4_pInt+j,e) = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j+2_pInt)) ! CP ids of nodes - enddo - nNodesAlreadyRead = chunkPos(1) - 2_pInt - do while(nNodesAlreadyRead < FE_Nnodes(t)) ! read on if not all nodes in one line - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - do j = 1_pInt,chunkPos(1) - mesh_element(4_pInt+nNodesAlreadyRead+j,e) & - = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j)) ! CP ids of nodes - enddo - nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) - enddo - endif - enddo - exit - endif - enddo - -620 rewind(fileUnit) ! just in case "initial state" appears before "connectivity" - read (fileUnit,610,END=620) line - do - chunkPos = IO_stringPos(line) - if( (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'initial') .and. & - (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'state') ) then - if (initialcondTableStyle == 2_pInt) read (fileUnit,610,END=620) line ! read extra line for new style - read (fileUnit,610,END=630) line ! read line with index of state var - chunkPos = IO_stringPos(line) - sv = IO_IntValue(line,chunkPos,1_pInt) ! figure state variable index - if( (sv == 2_pInt).or.(sv == 3_pInt) ) then ! only state vars 2 and 3 of interest - read (fileUnit,610,END=620) line ! read line with value of state var - chunkPos = IO_stringPos(line) - do while (scan(IO_stringValue(line,chunkPos,1_pInt),'+-',back=.true.)>1) ! is noEfloat value? - myVal = nint(IO_fixedNoEFloatValue(line,[0_pInt,20_pInt],1_pInt),pInt) ! state var's value - mesh_maxValStateVar(sv-1_pInt) = max(myVal,mesh_maxValStateVar(sv-1_pInt)) ! remember max val of homogenization and microstructure index - if (initialcondTableStyle == 2_pInt) then - read (fileUnit,610,END=630) line ! read extra line - read (fileUnit,610,END=630) line ! read extra line - endif - contInts = IO_continuousIntValues& ! get affected elements - (fileUnit,mesh_NcpElems,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) - do i = 1_pInt,contInts(1) - e = mesh_FEasCP('elem',contInts(1_pInt+i)) - mesh_element(1_pInt+sv,e) = myVal - enddo - if (initialcondTableStyle == 0_pInt) read (fileUnit,610,END=620) line ! ignore IP range for old table style - read (fileUnit,610,END=630) line - chunkPos = IO_stringPos(line) - enddo - endif - else - read (fileUnit,610,END=630) line - endif - enddo - -630 end subroutine mesh_marc_build_elements -#endif - -#ifdef Abaqus -!-------------------------------------------------------------------------------------------------- -!> @brief Count overall number of nodes and elements in mesh and stores them in -!! 'mesh_Nelems' and 'mesh_Nnodes' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_count_nodesAndElements(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_countDataLines, & - IO_error - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line - logical :: inPart - - mesh_Nnodes = 0_pInt - mesh_Nelems = 0_pInt - -610 FORMAT(A300) - - inPart = .false. - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. - - if (inPart .or. noPart) then - select case ( IO_lc(IO_stringValue(line,chunkPos,1_pInt))) - case('*node') - if( & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'print' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'file' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' & - ) & - mesh_Nnodes = mesh_Nnodes + IO_countDataLines(fileUnit) - case('*element') - if( & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'matrix' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' & - ) then - mesh_Nelems = mesh_Nelems + IO_countDataLines(fileUnit) - endif - endselect - endif - enddo - -620 if (mesh_Nnodes < 2_pInt) call IO_error(error_ID=900_pInt) - if (mesh_Nelems == 0_pInt) call IO_error(error_ID=901_pInt) - -end subroutine mesh_abaqus_count_nodesAndElements - - -!-------------------------------------------------------------------------------------------------- -!> @brief count overall number of element sets in mesh and write 'mesh_NelemSets' and -!! 'mesh_maxNelemInSet' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_count_elementSets(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_error - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line - logical :: inPart - - mesh_NelemSets = 0_pInt - mesh_maxNelemInSet = mesh_Nelems ! have to be conservative, since Abaqus allows for recursive definitons - -610 FORMAT(A300) - - inPart = .false. - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. - - if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*elset' ) & - mesh_NelemSets = mesh_NelemSets + 1_pInt - enddo - -620 continue - if (mesh_NelemSets == 0) call IO_error(error_ID=902_pInt) - -end subroutine mesh_abaqus_count_elementSets - - -!-------------------------------------------------------------------------------------------------- -! count overall number of solid sections sets in mesh (Abaqus only) -! -! mesh_Nmaterials -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_count_materials(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_error - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line - logical inPart - - mesh_Nmaterials = 0_pInt - -610 FORMAT(A300) - - inPart = .false. - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. - - if ( (inPart .or. noPart) .and. & - IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == '*solid' .and. & - IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'section' ) & - mesh_Nmaterials = mesh_Nmaterials + 1_pInt - enddo - -620 if (mesh_Nmaterials == 0_pInt) call IO_error(error_ID=903_pInt) - -end subroutine mesh_abaqus_count_materials - - -!-------------------------------------------------------------------------------------------------- -! Build element set mapping -! -! allocate globals: mesh_nameElemSet, mesh_mapElemSet -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_map_elementSets(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_extractValue, & - IO_continuousIntValues, & - IO_error - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer(pInt) :: elemSet = 0_pInt,i - logical :: inPart = .false. - - allocate (mesh_nameElemSet(mesh_NelemSets)); mesh_nameElemSet = '' - allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets),source=0_pInt) - -610 FORMAT(A300) - - - rewind(fileUnit) - do - read (fileUnit,610,END=640) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. - - if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*elset' ) then - elemSet = elemSet + 1_pInt - mesh_nameElemSet(elemSet) = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'elset')) - mesh_mapElemSet(:,elemSet) = IO_continuousIntValues(fileUnit,mesh_Nelems,mesh_nameElemSet,& - mesh_mapElemSet,elemSet-1_pInt) - endif - enddo - -640 do i = 1_pInt,elemSet - if (mesh_mapElemSet(1,i) == 0_pInt) call IO_error(error_ID=904_pInt,ext_msg=mesh_nameElemSet(i)) - enddo - -end subroutine mesh_abaqus_map_elementSets - - -!-------------------------------------------------------------------------------------------------- -! map solid section (Abaqus only) -! -! allocate globals: mesh_nameMaterial, mesh_mapMaterial -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_map_materials(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_extractValue, & - IO_error - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) line - - integer(pInt) :: i,c = 0_pInt - logical :: inPart = .false. - character(len=64) :: elemSetName,materialName - - allocate (mesh_nameMaterial(mesh_Nmaterials)); mesh_nameMaterial = '' - allocate (mesh_mapMaterial(mesh_Nmaterials)); mesh_mapMaterial = '' - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. - - if ( (inPart .or. noPart) .and. & - IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == '*solid' .and. & - IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'section' ) then - - elemSetName = '' - materialName = '' - - do i = 3_pInt,chunkPos(1_pInt) - if (IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'elset') /= '') & - elemSetName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'elset')) - if (IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'material') /= '') & - materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'material')) - enddo - - if (elemSetName /= '' .and. materialName /= '') then - c = c + 1_pInt - mesh_nameMaterial(c) = materialName ! name of material used for this section - mesh_mapMaterial(c) = elemSetName ! mapped to respective element set - endif - endif - enddo - -620 if (c==0_pInt) call IO_error(error_ID=905_pInt) - do i=1_pInt,c - if (mesh_nameMaterial(i)=='' .or. mesh_mapMaterial(i)=='') call IO_error(error_ID=905_pInt) - enddo - - end subroutine mesh_abaqus_map_materials - - -!-------------------------------------------------------------------------------------------------- -!> @brief Count overall number of CP elements in mesh and stores them in 'mesh_NcpElems' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_count_cpElements(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_error, & - IO_extractValue - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) line - integer(pInt) :: i,k - logical :: materialFound = .false. - character(len=64) ::materialName,elemSetName - - mesh_NcpElems = 0_pInt - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - select case ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ) - case('*material') - materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'name')) ! extract name=value - materialFound = materialName /= '' ! valid name? - case('*user') - if (IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'material' .and. materialFound) then - do i = 1_pInt,mesh_Nmaterials ! look thru material names - if (materialName == mesh_nameMaterial(i)) then ! found one - elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet - do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions - if (elemSetName == mesh_nameElemSet(k)) & ! matched? - mesh_NcpElems = mesh_NcpElems + mesh_mapElemSet(1,k) ! add those elem count - enddo - endif - enddo - materialFound = .false. - endif - endselect - enddo - -620 if (mesh_NcpElems == 0_pInt) call IO_error(error_ID=906_pInt) - -end subroutine mesh_abaqus_count_cpElements - - -!-------------------------------------------------------------------------------------------------- -!> @brief Maps elements from FE ID to internal (consecutive) representation. -!! Allocates global array 'mesh_mapFEtoCPelem' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_map_elements(fileUnit) - - use math, only: math_qsort - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_extractValue, & - IO_error - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer(pInt) ::i,j,k,cpElem = 0_pInt - logical :: materialFound = .false. - character (len=64) materialName,elemSetName ! why limited to 64? ABAQUS? - - allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems), source = 0_pInt) - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=660) line - chunkPos = IO_stringPos(line) - select case ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ) - case('*material') - materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'name')) ! extract name=value - materialFound = materialName /= '' ! valid name? - case('*user') - if (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'material' .and. materialFound) then - do i = 1_pInt,mesh_Nmaterials ! look thru material names - if (materialName == mesh_nameMaterial(i)) then ! found one - elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet - do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions - if (elemSetName == mesh_nameElemSet(k)) then ! matched? - do j = 1_pInt,mesh_mapElemSet(1,k) - cpElem = cpElem + 1_pInt - mesh_mapFEtoCPelem(1,cpElem) = mesh_mapElemSet(1_pInt+j,k) ! store FE id - mesh_mapFEtoCPelem(2,cpElem) = cpElem ! store our id - enddo - endif - enddo - endif - enddo - materialFound = .false. - endif - endselect - enddo - -660 call math_qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems - - if (int(size(mesh_mapFEtoCPelem),pInt) < 2_pInt) call IO_error(error_ID=907_pInt) - -end subroutine mesh_abaqus_map_elements - - -!-------------------------------------------------------------------------------------------------- -!> @brief Maps node from FE ID to internal (consecutive) representation. -!! Allocates global array 'mesh_mapFEtoCPnode' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_map_nodes(fileUnit) - - use math, only: math_qsort - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_countDataLines, & - IO_intValue, & - IO_error - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) line - - integer(pInt) :: i,c,cpNode = 0_pInt - logical :: inPart = .false. - - allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes), source=0_pInt) - -610 FORMAT(A300) - - rewind(fileUnit) - do - read (fileUnit,610,END=650) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. - - if( (inPart .or. noPart) .and. & - IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*node' .and. & - ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'print' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'file' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & - ) then - c = IO_countDataLines(fileUnit) - do i = 1_pInt,c - backspace(fileUnit) - enddo - do i = 1_pInt,c - read (fileUnit,610,END=650) line - chunkPos = IO_stringPos(line) - cpNode = cpNode + 1_pInt - mesh_mapFEtoCPnode(1_pInt,cpNode) = IO_intValue(line,chunkPos,1_pInt) - mesh_mapFEtoCPnode(2_pInt,cpNode) = cpNode - enddo - endif - enddo - -650 call math_qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) - - if (int(size(mesh_mapFEtoCPnode),pInt) == 0_pInt) call IO_error(error_ID=908_pInt) - -end subroutine mesh_abaqus_map_nodes - - -!-------------------------------------------------------------------------------------------------- -!> @brief store x,y,z coordinates of all nodes in mesh. -!! Allocates global arrays 'mesh_node0' and 'mesh_node' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_build_nodes(fileUnit) - use IO, only: & - IO_lc, & - IO_stringValue, & - IO_floatValue, & - IO_stringPos, & - IO_error, & - IO_countDataLines, & - IO_intValue - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer(pInt) :: i,j,m,c - logical :: inPart - - allocate ( mesh_node0 (3,mesh_Nnodes), source=0.0_pReal) - allocate ( mesh_node (3,mesh_Nnodes), source=0.0_pReal) - -610 FORMAT(A300) - - inPart = .false. - rewind(fileUnit) - do - read (fileUnit,610,END=670) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. - - if( (inPart .or. noPart) .and. & - IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*node' .and. & - ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'print' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'file' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & - ) then - c = IO_countDataLines(fileUnit) ! how many nodes are defined here? - do i = 1_pInt,c - backspace(fileUnit) ! rewind to first entry - enddo - do i = 1_pInt,c - read (fileUnit,610,END=670) line - chunkPos = IO_stringPos(line) - m = mesh_FEasCP('node',IO_intValue(line,chunkPos,1_pInt)) - do j=1_pInt, 3_pInt - mesh_node0(j,m) = mesh_unitlength * IO_floatValue(line,chunkPos,j+1_pInt) - enddo - enddo - endif - enddo - -670 if (int(size(mesh_node0,2_pInt),pInt) /= mesh_Nnodes) call IO_error(error_ID=909_pInt) - mesh_node = mesh_node0 - -end subroutine mesh_abaqus_build_nodes - - -!-------------------------------------------------------------------------------------------------- -!> @brief Gets maximum count of nodes, IPs, IP neighbors, and subNodes among cpElements. -!! Sets global values 'mesh_maxNnodes', 'mesh_maxNips', 'mesh_maxNipNeighbors', -!! and 'mesh_maxNcellnodes' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_count_cpSizes(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_extractValue ,& - IO_error, & - IO_countDataLines, & - IO_intValue - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer(pInt) :: i,c,t,g - logical :: inPart - - mesh_maxNnodes = 0_pInt - mesh_maxNips = 0_pInt - mesh_maxNipNeighbors = 0_pInt - mesh_maxNcellnodes = 0_pInt - -610 FORMAT(A300) - - inPart = .false. - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. - - if( (inPart .or. noPart) .and. & - IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*element' .and. & - ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'matrix' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & - ) then - t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'type')) ! remember elem type - g = FE_geomtype(t) - c = FE_celltype(g) - mesh_maxNnodes = max(mesh_maxNnodes,FE_Nnodes(t)) - mesh_maxNips = max(mesh_maxNips,FE_Nips(g)) - mesh_maxNipNeighbors = max(mesh_maxNipNeighbors,FE_NipNeighbors(c)) - mesh_maxNcellnodes = max(mesh_maxNcellnodes,FE_Ncellnodes(g)) - endif - enddo - -620 end subroutine mesh_abaqus_count_cpSizes - - -!-------------------------------------------------------------------------------------------------- -!> @brief Store FEid, type, mat, tex, and node list per elemen. -!! Allocates global array 'mesh_element' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_abaqus_build_elements(fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_skipChunks, & - IO_stringPos, & - IO_intValue, & - IO_extractValue, & - IO_floatValue, & - IO_countDataLines, & - IO_error - - implicit none - integer(pInt), intent(in) :: fileUnit - - integer(pInt), allocatable, dimension(:) :: chunkPos - - integer(pInt) :: i,j,k,c,e,t,homog,micro, nNodesAlreadyRead - logical inPart,materialFound - character (len=64) :: materialName,elemSetName - character(len=300) :: line - - allocate(mesh_element (4_pInt+mesh_maxNnodes,mesh_NcpElems), source=0_pInt) - mesh_elemType = -1_pInt - -610 FORMAT(A300) - - inPart = .false. - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. - if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. - - if( (inPart .or. noPart) .and. & - IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*element' .and. & - ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'matrix' .and. & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & - ) then - t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'type')) ! remember elem type - c = IO_countDataLines(fileUnit) - do i = 1_pInt,c - backspace(fileUnit) - enddo - do i = 1_pInt,c - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) ! limit to 64 nodes max - e = mesh_FEasCP('elem',IO_intValue(line,chunkPos,1_pInt)) - if (e /= 0_pInt) then ! disregard non CP elems - mesh_element(1,e) = -1_pInt ! DEPRECATED - if (mesh_elemType /= t .and. mesh_elemType /= -1_pInt) & - call IO_error(191,el=t,ip=mesh_elemType) - mesh_elemType = t - mesh_element(2,e) = t ! elem type - nNodesAlreadyRead = 0_pInt - do j = 1_pInt,chunkPos(1)-1_pInt - mesh_element(4_pInt+j,e) = mesh_FEasCP('node',IO_intValue(line,chunkPos,1_pInt+j)) ! put CP ids of nodes to position 5: - enddo - nNodesAlreadyRead = chunkPos(1) - 1_pInt - do while(nNodesAlreadyRead < FE_Nnodes(t)) ! read on if not all nodes in one line - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - do j = 1_pInt,chunkPos(1) - mesh_element(4_pInt+nNodesAlreadyRead+j,e) & - = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j)) ! CP ids of nodes - enddo - nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) - enddo - endif - enddo - endif - enddo - - -620 rewind(fileUnit) ! just in case "*material" definitions apear before "*element" - - materialFound = .false. - do - read (fileUnit,610,END=630) line - chunkPos = IO_stringPos(line) - select case ( IO_lc(IO_StringValue(line,chunkPos,1_pInt))) - case('*material') - materialName = trim(IO_extractValue(IO_lc(IO_StringValue(line,chunkPos,2_pInt)),'name')) ! extract name=value - materialFound = materialName /= '' ! valid name? - case('*user') - if ( IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'material' .and. & - materialFound ) then - read (fileUnit,610,END=630) line ! read homogenization and microstructure - chunkPos = IO_stringPos(line) - homog = nint(IO_floatValue(line,chunkPos,1_pInt),pInt) - micro = nint(IO_floatValue(line,chunkPos,2_pInt),pInt) - do i = 1_pInt,mesh_Nmaterials ! look thru material names - if (materialName == mesh_nameMaterial(i)) then ! found one - elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet - do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions - if (elemSetName == mesh_nameElemSet(k)) then ! matched? - do j = 1_pInt,mesh_mapElemSet(1,k) - e = mesh_FEasCP('elem',mesh_mapElemSet(1+j,k)) - mesh_element(3,e) = homog ! store homogenization - mesh_element(4,e) = micro ! store microstructure - mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),homog) - mesh_maxValStateVar(2) = max(mesh_maxValStateVar(2),micro) - enddo - endif - enddo - endif - enddo - materialFound = .false. - endif - endselect - enddo - -630 end subroutine mesh_abaqus_build_elements -#endif - - -!-------------------------------------------------------------------------------------------------- -!> @brief get any additional damask options from input file, sets mesh_periodicSurface -!-------------------------------------------------------------------------------------------------- -subroutine mesh_get_damaskOptions(fileUnit) - -use IO, only: & - IO_lc, & - IO_stringValue, & - IO_stringPos - - implicit none - integer(pInt), intent(in) :: fileUnit - -#ifdef Spectral - mesh_periodicSurface = .true. - - end subroutine mesh_get_damaskOptions - -#else - - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) chunk, Nchunks - character(len=300) :: line, damaskOption, v - character(len=300) :: keyword - - mesh_periodicSurface = .false. -#ifdef Marc4DAMASK - keyword = '$damask' -#endif -#ifdef Abaqus - keyword = '**damask' -#endif - - rewind(fileUnit) - do - read (fileUnit,610,END=620) line - chunkPos = IO_stringPos(line) - Nchunks = chunkPos(1) - if (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == keyword .and. Nchunks > 1_pInt) then ! found keyword for damask option and there is at least one more chunk to read - damaskOption = IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - select case(damaskOption) - case('periodic') ! damask Option that allows to specify periodic fluxes - do chunk = 3_pInt,Nchunks ! loop through chunks (skipping the keyword) - v = IO_lc(IO_stringValue(line,chunkPos,chunk)) ! chunk matches keyvalues x,y, or z? - mesh_periodicSurface(1) = mesh_periodicSurface(1) .or. v == 'x' - mesh_periodicSurface(2) = mesh_periodicSurface(2) .or. v == 'y' - mesh_periodicSurface(3) = mesh_periodicSurface(3) .or. v == 'z' - enddo - endselect - endif - enddo - -610 FORMAT(A300) - -620 end subroutine mesh_get_damaskOptions -#endif !-------------------------------------------------------------------------------------------------- @@ -2925,7 +1616,7 @@ subroutine mesh_build_ipAreas end subroutine mesh_build_ipAreas -#ifndef Spectral + !-------------------------------------------------------------------------------------------------- !> @brief assignment of twin nodes for each cp node, allocate globals '_nodeTwins' !-------------------------------------------------------------------------------------------------- @@ -3225,208 +1916,9 @@ subroutine mesh_build_ipNeighborhood enddo enddo enddo - -end subroutine mesh_build_ipNeighborhood -#endif - - -!-------------------------------------------------------------------------------------------------- -!> @brief write statistics regarding input file parsing to the output file -!-------------------------------------------------------------------------------------------------- -subroutine mesh_tell_statistics - use math, only: & - math_range - use IO, only: & - IO_error - use debug, only: & - debug_level, & - debug_MESH, & - debug_LEVELBASIC, & - debug_LEVELEXTENSIVE, & - debug_LEVELSELECTIVE, & - debug_e, & - debug_i - - implicit none - integer(pInt), dimension (:,:), allocatable :: mesh_HomogMicro - character(len=64) :: myFmt - integer(pInt) :: i,e,n,f,t,g,c, myDebug - - myDebug = debug_level(debug_mesh) - - if (mesh_maxValStateVar(1) < 1_pInt) call IO_error(error_ID=170_pInt) ! no homogenization specified - if (mesh_maxValStateVar(2) < 1_pInt) call IO_error(error_ID=180_pInt) ! no microstructure specified - - allocate (mesh_HomogMicro(mesh_maxValStateVar(1),mesh_maxValStateVar(2)),source = 0_pInt) - do e = 1_pInt,mesh_NcpElems - if (mesh_element(3,e) < 1_pInt) call IO_error(error_ID=170_pInt,el=e) ! no homogenization specified - if (mesh_element(4,e) < 1_pInt) call IO_error(error_ID=180_pInt,el=e) ! no microstructure specified - mesh_HomogMicro(mesh_element(3,e),mesh_element(4,e)) = & - mesh_HomogMicro(mesh_element(3,e),mesh_element(4,e)) + 1_pInt ! count combinations of homogenization and microstructure - enddo -!$OMP CRITICAL (write2out) - if (iand(myDebug,debug_levelBasic) /= 0_pInt) then - write(6,'(/,a,/)') ' Input Parser: STATISTICS' - write(6,*) mesh_NcpElems, ' : total number of CP elements in mesh' - write(6,*) mesh_Nnodes, ' : total number of nodes in mesh' - write(6,'(/,a,/)') ' Input Parser: HOMOGENIZATION/MICROSTRUCTURE' - write(6,*) mesh_maxValStateVar(1), ' : maximum homogenization index' - write(6,*) mesh_maxValStateVar(2), ' : maximum microstructure index' - write(6,*) - write (myFmt,'(a,i32.32,a)') '(9x,a2,1x,',mesh_maxValStateVar(2),'(i8))' - write(6,myFmt) '+-',math_range(mesh_maxValStateVar(2)) - write (myFmt,'(a,i32.32,a)') '(i8,1x,a2,1x,',mesh_maxValStateVar(2),'(i8))' - do i=1_pInt,mesh_maxValStateVar(1) ! loop over all (possibly assigned) homogenizations - write(6,myFmt) i,'| ',mesh_HomogMicro(i,:) ! loop over all (possibly assigned) microstructures - enddo - write(6,'(/,a,/)') ' Input Parser: ADDITIONAL MPIE OPTIONS' - write(6,*) 'periodic surface : ', mesh_periodicSurface - write(6,*) - flush(6) - endif - - if (iand(myDebug,debug_levelExtensive) /= 0_pInt) then - write(6,'(/,a,/)') 'Input Parser: ELEMENT TYPE' - write(6,'(a8,3(1x,a8))') 'elem','elemtype','geomtype','celltype' - do e = 1_pInt,mesh_NcpElems - if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle - t = mesh_element(2,e) ! get elemType - g = FE_geomtype(t) ! get elemGeomType - c = FE_celltype(g) ! get cellType - write(6,'(i8,3(1x,i8))') e,t,g,c - enddo - write(6,'(/,a)') 'Input Parser: ELEMENT VOLUME' - write(6,'(/,a13,1x,e15.8)') 'total volume', sum(mesh_ipVolume) - write(6,'(/,a8,1x,a5,1x,a15,1x,a5,1x,a15,1x,a16)') 'elem','IP','volume','face','area','-- normal --' - do e = 1_pInt,mesh_NcpElems - if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle - t = mesh_element(2,e) ! get element type - g = FE_geomtype(t) ! get geometry type - c = FE_celltype(g) ! get cell type - do i = 1_pInt,FE_Nips(g) - if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle - write(6,'(i8,1x,i5,1x,e15.8)') e,i,mesh_IPvolume(i,e) - do f = 1_pInt,FE_NipNeighbors(c) - write(6,'(i33,1x,e15.8,1x,3(f6.3,1x))') f,mesh_ipArea(f,i,e),mesh_ipAreaNormal(:,f,i,e) - enddo - enddo - enddo - write(6,'(/,a,/)') 'Input Parser: CELLNODE COORDINATES' - write(6,'(a8,1x,a2,1x,a8,3(1x,a12))') 'elem','IP','cellnode','x','y','z' - do e = 1_pInt,mesh_NcpElems ! loop over cpElems - if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle - t = mesh_element(2,e) ! get element type - g = FE_geomtype(t) ! get geometry type - c = FE_celltype(g) ! get cell type - do i = 1_pInt,FE_Nips(g) ! loop over IPs of elem - if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle - write(6,'(i8,1x,i2)') e,i - do n = 1_pInt,FE_NcellnodesPerCell(c) ! loop over cell nodes in the cell - write(6,'(12x,i8,3(1x,f12.8))') mesh_cell(n,i,e), & - mesh_cellnode(1:3,mesh_cell(n,i,e)) - enddo - enddo - enddo - write(6,'(/,a)') 'Input Parser: IP COORDINATES' - write(6,'(a8,1x,a5,3(1x,a12))') 'elem','IP','x','y','z' - do e = 1_pInt,mesh_NcpElems - if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle - do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) - if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle - write(6,'(i8,1x,i5,3(1x,f12.8))') e, i, mesh_ipCoordinates(:,i,e) - enddo - enddo -#ifndef Spectral - write(6,'(/,a,/)') 'Input Parser: NODE TWINS' - write(6,'(a6,3(3x,a6))') ' node','twin_x','twin_y','twin_z' - do n = 1_pInt,mesh_Nnodes ! loop over cpNodes - if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. .not. any(mesh_element(5:,debug_e) == n)) cycle - write(6,'(i6,3(3x,i6))') n, mesh_nodeTwins(1:3,n) - enddo -#endif - write(6,'(/,a,/)') 'Input Parser: IP NEIGHBORHOOD' - write(6,'(a8,1x,a10,1x,a10,1x,a3,1x,a13,1x,a13)') 'elem','IP','neighbor','','elemNeighbor','ipNeighbor' - do e = 1_pInt,mesh_NcpElems ! loop over cpElems - if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle - t = mesh_element(2,e) ! get element type - g = FE_geomtype(t) ! get geometry type - c = FE_celltype(g) ! get cell type - do i = 1_pInt,FE_Nips(g) ! loop over IPs of elem - if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle - do n = 1_pInt,FE_NipNeighbors(c) ! loop over neighbors of IP - write(6,'(i8,1x,i10,1x,i10,1x,a3,1x,i13,1x,i13)') e,i,n,'-->',mesh_ipNeighborhood(1,n,i,e),mesh_ipNeighborhood(2,n,i,e) - enddo - enddo - enddo - endif -!$OMP END CRITICAL (write2out) - -end subroutine mesh_tell_statistics - - -!-------------------------------------------------------------------------------------------------- -!> @brief mapping of FE element types to internal representation -!-------------------------------------------------------------------------------------------------- -integer(pInt) function FE_mapElemtype(what) - use IO, only: IO_lc, IO_error - - implicit none - character(len=*), intent(in) :: what - - select case (IO_lc(what)) - case ( '6') - FE_mapElemtype = 1_pInt ! Two-dimensional Plane Strain Triangle - case ( '155', & - '125', & - '128') - FE_mapElemtype = 2_pInt ! Two-dimensional Plane Strain triangle (155: cubic shape function, 125/128: second order isoparametric) - case ( '11', & - 'cpe4', & - 'cpe4t') - FE_mapElemtype = 3_pInt ! Arbitrary Quadrilateral Plane-strain - case ( '27', & - 'cpe8', & - 'cpe8t') - FE_mapElemtype = 4_pInt ! Plane Strain, Eight-node Distorted Quadrilateral - case ( '54') - FE_mapElemtype = 5_pInt ! Plane Strain, Eight-node Distorted Quadrilateral with reduced integration - case ( '134', & - 'c3d4', & - 'c3d4t') - FE_mapElemtype = 6_pInt ! Three-dimensional Four-node Tetrahedron - case ( '157') - FE_mapElemtype = 7_pInt ! Three-dimensional, Low-order, Tetrahedron, Herrmann Formulations - case ( '127') - FE_mapElemtype = 8_pInt ! Three-dimensional Ten-node Tetrahedron - case ( '136', & - 'c3d6', & - 'c3d6t') - FE_mapElemtype = 9_pInt ! Three-dimensional Arbitrarily Distorted Pentahedral - case ( '117', & - '123', & - 'c3d8r', & - 'c3d8rt') - FE_mapElemtype = 10_pInt ! Three-dimensional Arbitrarily Distorted linear hexahedral with reduced integration - case ( '7', & - 'c3d8', & - 'c3d8t') - FE_mapElemtype = 11_pInt ! Three-dimensional Arbitrarily Distorted Brick - case ( '57', & - 'c3d20r', & - 'c3d20rt') - FE_mapElemtype = 12_pInt ! Three-dimensional Arbitrarily Distorted quad hexahedral with reduced integration - case ( '21', & - 'c3d20', & - 'c3d20t') - FE_mapElemtype = 13_pInt ! Three-dimensional Arbitrarily Distorted quadratic hexahedral - case default - call IO_error(error_ID=190_pInt,ext_msg=IO_lc(what)) - end select - -end function FE_mapElemtype - - -!-------------------------------------------------------------------------------------------------- + + contains + !-------------------------------------------------------------------------------------------------- !> @brief find face-matching element of same type !-------------------------------------------------------------------------------------------------- subroutine mesh_faceMatch(elem, face ,matchingElem, matchingFace) @@ -3512,6 +2004,52 @@ enddo checkCandidate end subroutine mesh_faceMatch +end subroutine mesh_build_ipNeighborhood + + +!-------------------------------------------------------------------------------------------------- +!> @brief mapping of FE element types to internal representation +!-------------------------------------------------------------------------------------------------- +integer(pInt) function FE_mapElemtype(what) + use IO, only: IO_lc, IO_error + + implicit none + character(len=*), intent(in) :: what + + select case (IO_lc(what)) + case ( 'cpe4', & + 'cpe4t') + FE_mapElemtype = 3_pInt ! Arbitrary Quadrilateral Plane-strain + case ( 'cpe8', & + 'cpe8t') + FE_mapElemtype = 4_pInt ! Plane Strain, Eight-node Distorted Quadrilateral + case ( 'c3d4', & + 'c3d4t') + FE_mapElemtype = 6_pInt ! Three-dimensional Four-node Tetrahedron + case ( 'c3d6', & + 'c3d6t') + FE_mapElemtype = 9_pInt ! Three-dimensional Arbitrarily Distorted Pentahedral + case ( 'c3d8r', & + 'c3d8rt') + FE_mapElemtype = 10_pInt ! Three-dimensional Arbitrarily Distorted linear hexahedral with reduced integration + case ( 'c3d8', & + 'c3d8t') + FE_mapElemtype = 11_pInt ! Three-dimensional Arbitrarily Distorted Brick + case ( 'c3d20r', & + 'c3d20rt') + FE_mapElemtype = 12_pInt ! Three-dimensional Arbitrarily Distorted quad hexahedral with reduced integration + case ( 'c3d20', & + 'c3d20t') + FE_mapElemtype = 13_pInt ! Three-dimensional Arbitrarily Distorted quadratic hexahedral + case default + call IO_error(error_ID=190_pInt,ext_msg=IO_lc(what)) + end select + +end function FE_mapElemtype + + + + !-------------------------------------------------------------------------------------------------- !> @brief get properties of different types of finite elements @@ -4232,49 +2770,52 @@ end subroutine mesh_build_FEdata !-------------------------------------------------------------------------------------------------- -!> @brief returns global variable mesh_Ncellnodes +!> @brief Gives the FE to CP ID mapping by binary search through lookup array +!! valid questions (what) are 'elem', 'node' !-------------------------------------------------------------------------------------------------- -integer(pInt) function mesh_get_Ncellnodes() +integer(pInt) function mesh_FEasCP(what,myID) + use IO, only: & + IO_lc implicit none + character(len=*), intent(in) :: what + integer(pInt), intent(in) :: myID - mesh_get_Ncellnodes = mesh_Ncellnodes + integer(pInt), dimension(:,:), pointer :: lookupMap + integer(pInt) :: lower,upper,center -end function mesh_get_Ncellnodes + mesh_FEasCP = 0_pInt + select case(IO_lc(what(1:4))) + case('elem') + lookupMap => mesh_mapFEtoCPelem + case('node') + lookupMap => mesh_mapFEtoCPnode + case default + return + endselect + lower = 1_pInt + upper = int(size(lookupMap,2_pInt),pInt) -!-------------------------------------------------------------------------------------------------- -!> @brief returns global variable mesh_unitlength -!-------------------------------------------------------------------------------------------------- -real(pReal) function mesh_get_unitlength() - - implicit none - - mesh_get_unitlength = mesh_unitlength - -end function mesh_get_unitlength - - -!-------------------------------------------------------------------------------------------------- -!> @brief returns node that is located at an ip -!> @details return zero if requested ip does not exist or not available (more ips than nodes) -!-------------------------------------------------------------------------------------------------- -integer(pInt) function mesh_get_nodeAtIP(elemtypeFE,ip) - - implicit none - character(len=*), intent(in) :: elemtypeFE - integer(pInt), intent(in) :: ip - integer(pInt) :: elemtype - integer(pInt) :: geomtype - - mesh_get_nodeAtIP = 0_pInt - - elemtype = FE_mapElemtype(elemtypeFE) - geomtype = FE_geomtype(elemtype) - if (FE_Nips(geomtype) >= ip .and. FE_Nips(geomtype) <= FE_Nnodes(elemtype)) & - mesh_get_nodeAtIP = FE_nodesAtIP(1,ip,geomtype) - -end function mesh_get_nodeAtIP + if (lookupMap(1_pInt,lower) == myID) then ! check at bounds QUESTION is it valid to extend bounds by 1 and just do binary search w/o init check at bounds? + mesh_FEasCP = lookupMap(2_pInt,lower) + return + elseif (lookupMap(1_pInt,upper) == myID) then + mesh_FEasCP = lookupMap(2_pInt,upper) + return + endif + binarySearch: do while (upper-lower > 1_pInt) + center = (lower+upper)/2_pInt + if (lookupMap(1_pInt,center) < myID) then + lower = center + elseif (lookupMap(1_pInt,center) > myID) then + upper = center + else + mesh_FEasCP = lookupMap(2_pInt,center) + exit + endif + enddo binarySearch +end function mesh_FEasCP end module mesh diff --git a/src/mesh_base.f90 b/src/mesh_base.f90 new file mode 100644 index 000000000..5afdbc3ad --- /dev/null +++ b/src/mesh_base.f90 @@ -0,0 +1,85 @@ + +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Koords, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Sets up the mesh for the solvers MSC.Marc,FEM, Abaqus and the spectral solver +!-------------------------------------------------------------------------------------------------- +module mesh_base + + use, intrinsic :: iso_c_binding + use prec, only: & + pStringLen, & + pReal, & + pInt + use element, only: & + tElement + + implicit none + +!--------------------------------------------------------------------------------------------------- +!> Properties of a the whole mesh (consisting of one type of elements) +!--------------------------------------------------------------------------------------------------- + type, public :: tMesh + type(tElement) :: & + elem + real(pReal), dimension(:,:), allocatable, public :: & + ipVolume, & !< volume associated with each IP (initially!) + node0, & !< node x,y,z coordinates (initially) + node !< node x,y,z coordinates (deformed) + integer(pInt), dimension(:,:), allocatable, public :: & + cellnodeParent !< cellnode's parent element ID, cellnode's intra-element ID + character(pStringLen) :: type = "n/a" + integer(pInt) :: & + Nnodes, & !< total number of nodes in mesh + Nelems = -1_pInt, & + elemType, & + Ncells, & + nIPneighbors, & + NcellNodes, & + maxElemsPerNode + integer(pInt), dimension(:), allocatable, public :: & + homogenizationAt, & + microstructureAt + integer(pInt), dimension(:,:), allocatable, public :: & + connectivity + contains + procedure, pass(self) :: tMesh_base_init + procedure :: setNelems => tMesh_base_setNelems ! not needed once we compute the cells from the connectivity + generic, public :: init => tMesh_base_init + end type tMesh + +contains +subroutine tMesh_base_init(self,meshType,elemType,nodes) + + implicit none + class(tMesh) :: self + character(len=*), intent(in) :: meshType + integer(pInt), intent(in) :: elemType + real(pReal), dimension(:,:), intent(in) :: nodes + + write(6,'(/,a)') ' <<<+- mesh_base_init -+>>>' + + write(6,*)' mesh type ',meshType + write(6,*)' # node ',size(nodes,2) + + self%type = meshType + call self%elem%init(elemType) + self%node0 = nodes + self%nNodes = size(nodes,2) + +end subroutine tMesh_base_init + + +subroutine tMesh_base_setNelems(self,Nelems) + + implicit none + class(tMesh) :: self + integer(pInt), intent(in) :: Nelems + + self%Nelems = Nelems + +end subroutine tMesh_base_setNelems + +end module mesh_base diff --git a/src/mesh_grid.f90 b/src/mesh_grid.f90 new file mode 100644 index 000000000..424456e3a --- /dev/null +++ b/src/mesh_grid.f90 @@ -0,0 +1,1031 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Koords, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Sets up the mesh for the solvers MSC.Marc, Abaqus and the spectral solver +!-------------------------------------------------------------------------------------------------- +module mesh + use, intrinsic :: iso_c_binding + use prec, only: pReal, pInt + use mesh_base + + implicit none + private + integer(pInt), public, protected :: & + mesh_Nnodes, & !< total number of nodes in mesh + mesh_Ncellnodes, & !< total number of cell nodes in mesh (including duplicates) + mesh_Ncells, & !< total number of cells in mesh + mesh_maxNipNeighbors, & !< max number of IP neighbors in any CP element + mesh_maxNsharedElems !< max number of CP elements sharing a node + + + integer(pInt), dimension(:), allocatable, private :: & + microGlobal + integer(pInt), dimension(:), allocatable, public, protected :: & + mesh_homogenizationAt, & !< homogenization ID of each element + mesh_microstructureAt !< microstructure ID of each element + + integer(pInt), dimension(:,:), allocatable, public, protected :: & + mesh_element !< entryCount and list of elements containing node + + integer(pInt), dimension(:,:,:,:), allocatable, public, protected :: & + mesh_ipNeighborhood !< 6 or less neighboring IPs as [element_num, IP_index, neighbor_index that points to me] + + real(pReal), public, protected :: & + mesh_unitlength !< physical length of one unit in mesh + + real(pReal), dimension(:,:), allocatable, public :: & + mesh_node, & !< node x,y,z coordinates (after deformation! ONLY FOR MARC!!!) + mesh_cellnode !< cell node x,y,z coordinates (after deformation! ONLY FOR MARC!!!) + + real(pReal), dimension(:,:), allocatable, public, protected :: & + mesh_ipVolume, & !< volume associated with IP (initially!) + mesh_node0 !< node x,y,z coordinates (initially!) + + real(pReal), dimension(:,:,:), allocatable, public, protected :: & + mesh_ipArea !< area of interface to neighboring IP (initially!) + + real(pReal), dimension(:,:,:), allocatable, public :: & + mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!) + + real(pReal),dimension(:,:,:,:), allocatable, public, protected :: & + mesh_ipAreaNormal !< area normal of interface to neighboring IP (initially!) + + logical, dimension(3), public, parameter :: mesh_periodicSurface = .true. !< flag indicating periodic outer surfaces (used for fluxes) + +integer(pInt), dimension(:,:), allocatable, private :: & + mesh_cellnodeParent !< cellnode's parent element ID, cellnode's intra-element ID + + integer(pInt),dimension(:,:,:), allocatable, private :: & + mesh_cell !< cell connectivity for each element,ip/cell + + integer(pInt), dimension(:,:,:), allocatable, private :: & + FE_cellface !< list of intra-cell cell node IDs that constitute the cell faces of a specific type of cell + + +! These definitions should actually reside in the FE-solver specific part (different for MARC/ABAQUS) +! Hence, I suggest to prefix with "FE_" + + integer(pInt), parameter, private :: & + FE_Ngeomtypes = 10_pInt, & + FE_Ncelltypes = 4_pInt, & + FE_maxNmatchingNodesPerFace = 4_pInt, & + FE_maxNfaces = 6_pInt, & + FE_maxNcellnodesPerCell = 8_pInt, & + FE_maxNcellfaces = 6_pInt, & + FE_maxNcellnodesPerCellface = 4_pInt + + + + integer(pInt), dimension(FE_Ncelltypes), parameter, private :: FE_NcellnodesPerCell = & !< number of cell nodes in a specific cell type + int([ & + 3, & ! (2D 3node) + 4, & ! (2D 4node) + 4, & ! (3D 4node) + 8 & ! (3D 8node) + ],pInt) + + integer(pInt), dimension(FE_Ncelltypes), parameter, private :: FE_NcellnodesPerCellface = & !< number of cell nodes per cell face in a specific cell type + int([& + 2, & ! (2D 3node) + 2, & ! (2D 4node) + 3, & ! (3D 4node) + 4 & ! (3D 8node) + ],pInt) + + + integer(pInt), dimension(FE_Ncelltypes), parameter, private :: FE_NipNeighbors = & !< number of ip neighbors / cell faces in a specific cell type + int([& + 3, & ! (2D 3node) + 4, & ! (2D 4node) + 4, & ! (3D 4node) + 6 & ! (3D 8node) + ],pInt) + + + integer(pInt), dimension(3), public, protected :: & + grid !< (global) grid + integer(pInt), public, protected :: & + mesh_NcpElemsGlobal, & !< total number of CP elements in global mesh + grid3, & !< (local) grid in 3rd direction + grid3Offset !< (local) grid offset in 3rd direction + real(pReal), dimension(3), public, protected :: & + geomSize + real(pReal), public, protected :: & + size3, & !< (local) size in 3rd direction + size3offset !< (local) size offset in 3rd direction + + public :: & + mesh_init, & + mesh_cellCenterCoordinates + + private :: & + mesh_build_cellconnectivity, & + mesh_build_ipAreas, & + mesh_build_FEdata, & + mesh_spectral_build_nodes, & + mesh_spectral_build_elements, & + mesh_spectral_build_ipNeighborhood, & + mesh_build_cellnodes, & + mesh_build_ipVolumes, & + mesh_build_ipCoordinates + + type, public, extends(tMesh) :: tMesh_grid + + integer(pInt), dimension(3), public :: & + grid !< (global) grid + integer(pInt), public :: & + mesh_NcpElemsGlobal, & !< total number of CP elements in global mesh + grid3, & !< (local) grid in 3rd direction + grid3Offset !< (local) grid offset in 3rd direction + real(pReal), dimension(3), public :: & + geomSize + real(pReal), public :: & + size3, & !< (local) size in 3rd direction + size3offset + + contains + procedure, pass(self) :: tMesh_grid_init + generic, public :: init => tMesh_grid_init + end type tMesh_grid + + type(tMesh_grid), public, protected :: theMesh + +contains + +subroutine tMesh_grid_init(self,nodes) + + implicit none + class(tMesh_grid) :: self + real(pReal), dimension(:,:), intent(in) :: nodes + + call self%tMesh%init('grid',10_pInt,nodes) + +end subroutine tMesh_grid_init + +!-------------------------------------------------------------------------------------------------- +!> @brief initializes the mesh by calling all necessary private routines the mesh module +!! Order and routines strongly depend on type of solver +!-------------------------------------------------------------------------------------------------- +subroutine mesh_init(ip,el) + +#include + use PETScsys + + use DAMASK_interface + use IO, only: & + IO_open_file, & + IO_error, & + IO_timeStamp, & + IO_error, & + IO_write_jobFile + use debug, only: & + debug_e, & + debug_i, & + debug_level, & + debug_mesh, & + debug_levelBasic + use numerics, only: & + numerics_unitlength + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + + implicit none + include 'fftw3-mpi.f03' + integer(C_INTPTR_T) :: devNull, local_K, local_K_offset + integer :: ierr, worldsize + integer(pInt), intent(in), optional :: el, ip + integer(pInt) :: j + logical :: myDebug + + write(6,'(/,a)') ' <<<+- mesh init -+>>>' + + mesh_unitlength = numerics_unitlength ! set physical extent of a length unit in mesh + + myDebug = (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) + + call fftw_mpi_init() + call mesh_spectral_read_grid() + + + call MPI_comm_size(PETSC_COMM_WORLD, worldsize, ierr) + if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='MPI_comm_size') + if(worldsize>grid(3)) call IO_error(894_pInt, ext_msg='number of processes exceeds grid(3)') + + + devNull = fftw_mpi_local_size_3d(int(grid(3),C_INTPTR_T), & + int(grid(2),C_INTPTR_T), & + int(grid(1),C_INTPTR_T)/2+1, & + PETSC_COMM_WORLD, & + local_K, & ! domain grid size along z + local_K_offset) ! domain grid offset along z + grid3 = int(local_K,pInt) + grid3Offset = int(local_K_offset,pInt) + size3 = geomSize(3)*real(grid3,pReal) /real(grid(3),pReal) + size3Offset = geomSize(3)*real(grid3Offset,pReal)/real(grid(3),pReal) + + mesh_NcpElemsGlobal = product(grid) + + mesh_Nnodes = product(grid(1:2) + 1_pInt)*(grid3 + 1_pInt) + + call mesh_spectral_build_nodes() + if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) + + call theMesh%init(mesh_node) + call theMesh%setNelems(product(grid(1:2))*grid3) + mesh_homogenizationAt = mesh_homogenizationAt(product(grid(1:2))*grid3) ! reallocate/shrink in case of MPI + mesh_maxNipNeighbors = theMesh%elem%nIPneighbors + + call mesh_spectral_build_elements() + if (myDebug) write(6,'(a)') ' Built elements'; flush(6) + + + call mesh_build_FEdata ! get properties of the different types of elements + call mesh_build_cellconnectivity + if (myDebug) write(6,'(a)') ' Built cell connectivity'; flush(6) + mesh_cellnode = mesh_build_cellnodes(mesh_node,mesh_Ncellnodes) + if (myDebug) write(6,'(a)') ' Built cell nodes'; flush(6) + call mesh_build_ipCoordinates + if (myDebug) write(6,'(a)') ' Built IP coordinates'; flush(6) + call mesh_build_ipVolumes + if (myDebug) write(6,'(a)') ' Built IP volumes'; flush(6) + call mesh_build_ipAreas + if (myDebug) write(6,'(a)') ' Built IP areas'; flush(6) + + call mesh_spectral_build_ipNeighborhood + + if (myDebug) write(6,'(a)') ' Built IP neighborhood'; flush(6) + + if (debug_e < 1 .or. debug_e > theMesh%nElems) & + call IO_error(602_pInt,ext_msg='element') ! selected element does not exist + if (debug_i < 1 .or. debug_i > theMesh%elem%nIPs) & + call IO_error(602_pInt,ext_msg='IP') ! selected element does not have requested IP + + FEsolving_execElem = [ 1_pInt,theMesh%nElems ] ! parallel loop bounds set to comprise all DAMASK elements + allocate(FEsolving_execIP(2_pInt,theMesh%nElems), source=1_pInt) ! parallel loop bounds set to comprise from first IP... + forall (j = 1_pInt:theMesh%nElems) FEsolving_execIP(2,j) = theMesh%elem%nIPs ! ...up to own IP count for each element + + +!!!! COMPATIBILITY HACK !!!! +! for a homogeneous mesh, all elements have the same number of IPs and and cell nodes. +! hence, xxPerElem instead of maxXX +! better name + mesh_microstructureAt = mesh_element(4,:) +!!!!!!!!!!!!!!!!!!!!!!!! + deallocate(mesh_cell) +end subroutine mesh_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief Parses geometry file +!> @details important variables have an implicit "save" attribute. Therefore, this function is +! supposed to be called only once! +!-------------------------------------------------------------------------------------------------- +subroutine mesh_spectral_read_grid() + use IO, only: & + IO_stringPos, & + IO_lc, & + IO_stringValue, & + IO_intValue, & + IO_floatValue, & + IO_error + use DAMASK_interface, only: & + geometryFile + + implicit none + character(len=:), allocatable :: rawData + character(len=65536) :: line + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: h =- 1_pInt + integer(pInt) :: & + headerLength = -1_pInt, & !< length of header (in lines) + fileLength, & !< length of the geom file (in characters) + fileUnit, & + startPos, endPos, & + myStat, & + l, & !< line counter + c, & !< counter for # microstructures in line + o, & !< order of "to" packing + e, & !< "element", i.e. spectral collocation point + i, j + + grid = -1_pInt + geomSize = -1.0_pReal + +!-------------------------------------------------------------------------------------------------- +! read data as stream + inquire(file = trim(geometryFile), size=fileLength) + open(newunit=fileUnit, file=trim(geometryFile), access='stream',& + status='old', position='rewind', action='read',iostat=myStat) + if(myStat /= 0_pInt) call IO_error(100_pInt,ext_msg=trim(geometryFile)) + allocate(character(len=fileLength)::rawData) + read(fileUnit) rawData + close(fileUnit) + +!-------------------------------------------------------------------------------------------------- +! get header length + endPos = index(rawData,new_line('')) + if(endPos <= index(rawData,'head')) then + startPos = len(rawData) + call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_read_grid') + else + chunkPos = IO_stringPos(rawData(1:endPos)) + if (chunkPos(1) < 2_pInt) call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_read_grid') + headerLength = IO_intValue(rawData(1:endPos),chunkPos,1_pInt) + startPos = endPos + 1_pInt + endif + +!-------------------------------------------------------------------------------------------------- +! read and interprete header + l = 0 + do while (l < headerLength .and. startPos < len(rawData)) + endPos = startPos + index(rawData(startPos:),new_line('')) - 1_pInt + if (endPos < startPos) endPos = len(rawData) ! end of file without new line + line = rawData(startPos:endPos) + startPos = endPos + 1_pInt + l = l + 1_pInt + + chunkPos = IO_stringPos(trim(line)) + if (chunkPos(1) < 2) cycle ! need at least one keyword value pair + + select case ( IO_lc(IO_StringValue(trim(line),chunkPos,1_pInt,.true.)) ) + case ('grid') + if (chunkPos(1) > 6) then + do j = 2_pInt,6_pInt,2_pInt + select case (IO_lc(IO_stringValue(line,chunkPos,j))) + case('a') + grid(1) = IO_intValue(line,chunkPos,j+1_pInt) + case('b') + grid(2) = IO_intValue(line,chunkPos,j+1_pInt) + case('c') + grid(3) = IO_intValue(line,chunkPos,j+1_pInt) + end select + enddo + endif + + case ('size') + if (chunkPos(1) > 6) then + do j = 2_pInt,6_pInt,2_pInt + select case (IO_lc(IO_stringValue(line,chunkPos,j))) + case('x') + geomSize(1) = IO_floatValue(line,chunkPos,j+1_pInt) + case('y') + geomSize(2) = IO_floatValue(line,chunkPos,j+1_pInt) + case('z') + geomSize(3) = IO_floatValue(line,chunkPos,j+1_pInt) + end select + enddo + endif + + case ('homogenization') + if (chunkPos(1) > 1) h = IO_intValue(line,chunkPos,2_pInt) + end select + + enddo + +!-------------------------------------------------------------------------------------------------- +! sanity checks + if(h < 1_pInt) & + call IO_error(error_ID = 842_pInt, ext_msg='homogenization (mesh_spectral_read_grid)') + if(any(grid < 1_pInt)) & + call IO_error(error_ID = 842_pInt, ext_msg='grid (mesh_spectral_read_grid)') + if(any(geomSize < 0.0_pReal)) & + call IO_error(error_ID = 842_pInt, ext_msg='size (mesh_spectral_read_grid)') + + allocate(microGlobal(product(grid)), source = -1_pInt) + allocate(mesh_homogenizationAt(product(grid)), source = h) ! too large in case of MPI (shrink later, not very elegant) + +!-------------------------------------------------------------------------------------------------- +! read and interprete content + e = 1_pInt + do while (startPos < len(rawData)) + endPos = startPos + index(rawData(startPos:),new_line('')) - 1_pInt + if (endPos < startPos) endPos = len(rawData) ! end of file without new line + line = rawData(startPos:endPos) + startPos = endPos + 1_pInt + l = l + 1_pInt + chunkPos = IO_stringPos(trim(line)) + + noCompression: if (chunkPos(1) /= 3) then + c = chunkPos(1) + microGlobal(e:e+c-1_pInt) = [(IO_intValue(line,chunkPos,i+1_pInt), i=0_pInt, c-1_pInt)] + else noCompression + compression: if (IO_lc(IO_stringValue(line,chunkPos,2)) == 'of') then + c = IO_intValue(line,chunkPos,1) + microGlobal(e:e+c-1_pInt) = [(IO_intValue(line,chunkPos,3),i = 1_pInt,IO_intValue(line,chunkPos,1))] + else if (IO_lc(IO_stringValue(line,chunkPos,2)) == 'to') then compression + c = abs(IO_intValue(line,chunkPos,3) - IO_intValue(line,chunkPos,1)) + 1_pInt + o = merge(+1_pInt, -1_pInt, IO_intValue(line,chunkPos,3) > IO_intValue(line,chunkPos,1)) + microGlobal(e:e+c-1_pInt) = [(i, i = IO_intValue(line,chunkPos,1),IO_intValue(line,chunkPos,3),o)] + else compression + c = chunkPos(1) + microGlobal(e:e+c-1_pInt) = [(IO_intValue(line,chunkPos,i+1_pInt), i=0_pInt, c-1_pInt)] + endif compression + endif noCompression + + e = e+c + end do + + if (e-1 /= product(grid)) call IO_error(error_ID = 843_pInt, el=e) + +end subroutine mesh_spectral_read_grid + + +!-------------------------------------------------------------------------------------------------- +!> @brief Store x,y,z coordinates of all nodes in mesh. +!! Allocates global arrays 'mesh_node0' and 'mesh_node' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_spectral_build_nodes() + + implicit none + integer(pInt) :: n + + allocate (mesh_node0 (3,mesh_Nnodes), source = 0.0_pReal) + + forall (n = 0_pInt:mesh_Nnodes-1_pInt) + mesh_node0(1,n+1_pInt) = mesh_unitlength * & + geomSize(1)*real(mod(n,(grid(1)+1_pInt) ),pReal) & + / real(grid(1),pReal) + mesh_node0(2,n+1_pInt) = mesh_unitlength * & + geomSize(2)*real(mod(n/(grid(1)+1_pInt),(grid(2)+1_pInt)),pReal) & + / real(grid(2),pReal) + mesh_node0(3,n+1_pInt) = mesh_unitlength * & + size3*real(mod(n/(grid(1)+1_pInt)/(grid(2)+1_pInt),(grid3+1_pInt)),pReal) & + / real(grid3,pReal) + & + size3offset + end forall + + mesh_node = mesh_node0 + +end subroutine mesh_spectral_build_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Store FEid, type, material, texture, and node list per element. +!! Allocates global array 'mesh_element' +!> @todo does the IO_error makes sense? +!-------------------------------------------------------------------------------------------------- +subroutine mesh_spectral_build_elements() + use IO, only: & + IO_error + implicit none + integer(pInt) :: & + e, & + elemOffset + + + allocate(mesh_element (4_pInt+8_pInt,theMesh%nElems), source = 0_pInt) + + elemOffset = product(grid(1:2))*grid3Offset + e = 0_pInt + do while (e < theMesh%nElems) ! fill expected number of elements, stop at end of data + e = e+1_pInt ! valid element entry + mesh_element( 1,e) = -1_pInt ! DEPRECATED + mesh_element( 2,e) = 10_pInt + mesh_element( 3,e) = mesh_homogenizationAt(e) + mesh_element( 4,e) = microGlobal(e+elemOffset) ! microstructure + mesh_element( 5,e) = e + (e-1_pInt)/grid(1) + & + ((e-1_pInt)/(grid(1)*grid(2)))*(grid(1)+1_pInt) ! base node + mesh_element( 6,e) = mesh_element(5,e) + 1_pInt + mesh_element( 7,e) = mesh_element(5,e) + grid(1) + 2_pInt + mesh_element( 8,e) = mesh_element(5,e) + grid(1) + 1_pInt + mesh_element( 9,e) = mesh_element(5,e) +(grid(1) + 1_pInt) * (grid(2) + 1_pInt) ! second floor base node + mesh_element(10,e) = mesh_element(9,e) + 1_pInt + mesh_element(11,e) = mesh_element(9,e) + grid(1) + 2_pInt + mesh_element(12,e) = mesh_element(9,e) + grid(1) + 1_pInt + enddo + + if (e /= theMesh%nElems) call IO_error(880_pInt,e) + +end subroutine mesh_spectral_build_elements + + +!-------------------------------------------------------------------------------------------------- +!> @brief build neighborhood relations for spectral +!> @details assign globals: mesh_ipNeighborhood +!-------------------------------------------------------------------------------------------------- +subroutine mesh_spectral_build_ipNeighborhood + + implicit none + integer(pInt) :: & + x,y,z, & + e + allocate(mesh_ipNeighborhood(3,theMesh%elem%nIPneighbors,theMesh%elem%nIPs,theMesh%nElems),source=0_pInt) + + e = 0_pInt + do z = 0_pInt,grid3-1_pInt + do y = 0_pInt,grid(2)-1_pInt + do x = 0_pInt,grid(1)-1_pInt + e = e + 1_pInt + mesh_ipNeighborhood(1,1,1,e) = z * grid(1) * grid(2) & + + y * grid(1) & + + modulo(x+1_pInt,grid(1)) & + + 1_pInt + mesh_ipNeighborhood(1,2,1,e) = z * grid(1) * grid(2) & + + y * grid(1) & + + modulo(x-1_pInt,grid(1)) & + + 1_pInt + mesh_ipNeighborhood(1,3,1,e) = z * grid(1) * grid(2) & + + modulo(y+1_pInt,grid(2)) * grid(1) & + + x & + + 1_pInt + mesh_ipNeighborhood(1,4,1,e) = z * grid(1) * grid(2) & + + modulo(y-1_pInt,grid(2)) * grid(1) & + + x & + + 1_pInt + mesh_ipNeighborhood(1,5,1,e) = modulo(z+1_pInt,grid3) * grid(1) * grid(2) & + + y * grid(1) & + + x & + + 1_pInt + mesh_ipNeighborhood(1,6,1,e) = modulo(z-1_pInt,grid3) * grid(1) * grid(2) & + + y * grid(1) & + + x & + + 1_pInt + mesh_ipNeighborhood(2,1:6,1,e) = 1_pInt + mesh_ipNeighborhood(3,1,1,e) = 2_pInt + mesh_ipNeighborhood(3,2,1,e) = 1_pInt + mesh_ipNeighborhood(3,3,1,e) = 4_pInt + mesh_ipNeighborhood(3,4,1,e) = 3_pInt + mesh_ipNeighborhood(3,5,1,e) = 6_pInt + mesh_ipNeighborhood(3,6,1,e) = 5_pInt + enddo + enddo + enddo + +end subroutine mesh_spectral_build_ipNeighborhood + + +!-------------------------------------------------------------------------------------------------- +!> @brief builds mesh of (distorted) cubes for given coordinates (= center of the cubes) +!-------------------------------------------------------------------------------------------------- +function mesh_nodesAroundCentres(gDim,Favg,centres) result(nodes) + use debug, only: & + debug_mesh, & + debug_level, & + debug_levelBasic + use math, only: & + math_mul33x3 + + implicit none + real(pReal), intent(in), dimension(:,:,:,:) :: & + centres + real(pReal), dimension(3,size(centres,2)+1,size(centres,3)+1,size(centres,4)+1) :: & + nodes + real(pReal), intent(in), dimension(3) :: & + gDim + real(pReal), intent(in), dimension(3,3) :: & + Favg + real(pReal), dimension(3,size(centres,2)+2,size(centres,3)+2,size(centres,4)+2) :: & + wrappedCentres + + integer(pInt) :: & + i,j,k,n + integer(pInt), dimension(3), parameter :: & + diag = 1_pInt + integer(pInt), dimension(3) :: & + shift = 0_pInt, & + lookup = 0_pInt, & + me = 0_pInt, & + iRes = 0_pInt + integer(pInt), dimension(3,8) :: & + neighbor = reshape([ & + 0_pInt, 0_pInt, 0_pInt, & + 1_pInt, 0_pInt, 0_pInt, & + 1_pInt, 1_pInt, 0_pInt, & + 0_pInt, 1_pInt, 0_pInt, & + 0_pInt, 0_pInt, 1_pInt, & + 1_pInt, 0_pInt, 1_pInt, & + 1_pInt, 1_pInt, 1_pInt, & + 0_pInt, 1_pInt, 1_pInt ], [3,8]) + +!-------------------------------------------------------------------------------------------------- +! initializing variables + iRes = [size(centres,2),size(centres,3),size(centres,4)] + nodes = 0.0_pReal + wrappedCentres = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! report + if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then + write(6,'(a)') ' Meshing cubes around centroids' + write(6,'(a,3(e12.5))') ' Dimension: ', gDim + write(6,'(a,3(i5))') ' Resolution:', iRes + endif + +!-------------------------------------------------------------------------------------------------- +! building wrappedCentres = centroids + ghosts + wrappedCentres(1:3,2_pInt:iRes(1)+1_pInt,2_pInt:iRes(2)+1_pInt,2_pInt:iRes(3)+1_pInt) = centres + do k = 0_pInt,iRes(3)+1_pInt + do j = 0_pInt,iRes(2)+1_pInt + do i = 0_pInt,iRes(1)+1_pInt + if (k==0_pInt .or. k==iRes(3)+1_pInt .or. & ! z skin + j==0_pInt .or. j==iRes(2)+1_pInt .or. & ! y skin + i==0_pInt .or. i==iRes(1)+1_pInt ) then ! x skin + me = [i,j,k] ! me on skin + shift = sign(abs(iRes+diag-2_pInt*me)/(iRes+diag),iRes+diag-2_pInt*me) + lookup = me-diag+shift*iRes + wrappedCentres(1:3,i+1_pInt, j+1_pInt, k+1_pInt) = & + centres(1:3,lookup(1)+1_pInt,lookup(2)+1_pInt,lookup(3)+1_pInt) & + - math_mul33x3(Favg, real(shift,pReal)*gDim) + endif + enddo; enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! averaging + do k = 0_pInt,iRes(3); do j = 0_pInt,iRes(2); do i = 0_pInt,iRes(1) + do n = 1_pInt,8_pInt + nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) = & + nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) + wrappedCentres(1:3,i+1_pInt+neighbor(1,n), & + j+1_pInt+neighbor(2,n), & + k+1_pInt+neighbor(3,n) ) + enddo + enddo; enddo; enddo + nodes = nodes/8.0_pReal + +end function mesh_nodesAroundCentres + + +!################################################################################################################# +!################################################################################################################# +!################################################################################################################# +! The following routines are not solver specific and should be included in mesh_base (most likely in modified form) +!################################################################################################################# +!################################################################################################################# +!################################################################################################################# + + + +!-------------------------------------------------------------------------------------------------- +!> @brief Split CP elements into cells. +!> @details Build a mapping between cells and the corresponding cell nodes ('mesh_cell'). +!> Cell nodes that are also matching nodes are unique in the list of cell nodes, +!> all others (currently) might be stored more than once. +!> Also allocates the 'mesh_node' array. +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_cellconnectivity + + implicit none + integer(pInt), dimension(:), allocatable :: & + matchingNode2cellnode + integer(pInt), dimension(:,:), allocatable :: & + cellnodeParent + integer(pInt), dimension(theMesh%elem%Ncellnodes) :: & + localCellnode2globalCellnode + integer(pInt) :: & + e,n,i, & + matchingNodeID, & + localCellnodeID + + integer(pInt), dimension(FE_Ngeomtypes), parameter :: FE_NmatchingNodes = & !< number of nodes that are needed for face matching in a specific type of element geometry + int([ & + 3, & ! element 6 (2D 3node 1ip) + 3, & ! element 125 (2D 6node 3ip) + 4, & ! element 11 (2D 4node 4ip) + 4, & ! element 27 (2D 8node 9ip) + 4, & ! element 134 (3D 4node 1ip) + 4, & ! element 127 (3D 10node 4ip) + 6, & ! element 136 (3D 6node 6ip) + 8, & ! element 117 (3D 8node 1ip) + 8, & ! element 7 (3D 8node 8ip) + 8 & ! element 21 (3D 20node 27ip) + ],pInt) + + allocate(mesh_cell(FE_maxNcellnodesPerCell,theMesh%elem%nIPs,theMesh%nElems), source=0_pInt) + allocate(matchingNode2cellnode(theMesh%nNodes), source=0_pInt) + allocate(cellnodeParent(2_pInt,theMesh%elem%Ncellnodes*theMesh%nElems), source=0_pInt) + + mesh_Ncells = theMesh%nElems*theMesh%elem%nIPs +!-------------------------------------------------------------------------------------------------- +! Count cell nodes (including duplicates) and generate cell connectivity list + mesh_Ncellnodes = 0_pInt + + do e = 1_pInt,theMesh%nElems + localCellnode2globalCellnode = 0_pInt + do i = 1_pInt,theMesh%elem%nIPs + do n = 1_pInt,theMesh%elem%NcellnodesPerCell + localCellnodeID = theMesh%elem%cell(n,i) + if (localCellnodeID <= FE_NmatchingNodes(theMesh%elem%geomType)) then ! this cell node is a matching node + matchingNodeID = mesh_element(4_pInt+localCellnodeID,e) + if (matchingNode2cellnode(matchingNodeID) == 0_pInt) then ! if this matching node does not yet exist in the glbal cell node list ... + mesh_Ncellnodes = mesh_Ncellnodes + 1_pInt ! ... count it as cell node ... + matchingNode2cellnode(matchingNodeID) = mesh_Ncellnodes ! ... and remember its global ID + cellnodeParent(1_pInt,mesh_Ncellnodes) = e ! ... and where it belongs to + cellnodeParent(2_pInt,mesh_Ncellnodes) = localCellnodeID + endif + mesh_cell(n,i,e) = matchingNode2cellnode(matchingNodeID) + else ! this cell node is no matching node + if (localCellnode2globalCellnode(localCellnodeID) == 0_pInt) then ! if this local cell node does not yet exist in the global cell node list ... + mesh_Ncellnodes = mesh_Ncellnodes + 1_pInt ! ... count it as cell node ... + localCellnode2globalCellnode(localCellnodeID) = mesh_Ncellnodes ! ... and remember its global ID ... + cellnodeParent(1_pInt,mesh_Ncellnodes) = e ! ... and it belongs to + cellnodeParent(2_pInt,mesh_Ncellnodes) = localCellnodeID + endif + mesh_cell(n,i,e) = localCellnode2globalCellnode(localCellnodeID) + endif + enddo + enddo + enddo + + allocate(mesh_cellnodeParent(2_pInt,mesh_Ncellnodes)) + allocate(mesh_cellnode(3_pInt,mesh_Ncellnodes)) + + forall(n = 1_pInt:mesh_Ncellnodes) + mesh_cellnodeParent(1,n) = cellnodeParent(1,n) + mesh_cellnodeParent(2,n) = cellnodeParent(2,n) + endforall + +end subroutine mesh_build_cellconnectivity + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculate position of cellnodes from the given position of nodes +!> Build list of cellnodes' coordinates. +!> Cellnode coordinates are calculated from a weighted sum of node coordinates. +!-------------------------------------------------------------------------------------------------- +function mesh_build_cellnodes(nodes,Ncellnodes) + + implicit none + integer(pInt), intent(in) :: Ncellnodes !< requested number of cellnodes + real(pReal), dimension(3,mesh_Nnodes), intent(in) :: nodes + real(pReal), dimension(3,Ncellnodes) :: mesh_build_cellnodes + + integer(pInt) :: & + e,n,m, & + localCellnodeID + real(pReal), dimension(3) :: & + myCoords + + mesh_build_cellnodes = 0.0_pReal +!$OMP PARALLEL DO PRIVATE(e,localCellnodeID,myCoords) + do n = 1_pInt,Ncellnodes ! loop over cell nodes + e = mesh_cellnodeParent(1,n) + localCellnodeID = mesh_cellnodeParent(2,n) + myCoords = 0.0_pReal + do m = 1_pInt,theMesh%elem%nNodes + myCoords = myCoords + nodes(1:3,mesh_element(4_pInt+m,e)) & + * theMesh%elem%cellNodeParentNodeWeights(m,localCellnodeID) + enddo + mesh_build_cellnodes(1:3,n) = myCoords / sum(theMesh%elem%cellNodeParentNodeWeights(:,localCellnodeID)) + enddo +!$OMP END PARALLEL DO + +end function mesh_build_cellnodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates IP volume. Allocates global array 'mesh_ipVolume' +!> @details The IP volume is calculated differently depending on the cell type. +!> 2D cells assume an element depth of one in order to calculate the volume. +!> For the hexahedral cell we subdivide the cell into subvolumes of pyramidal +!> shape with a cell face as basis and the central ip at the tip. This subvolume is +!> calculated as an average of four tetrahedals with three corners on the cell face +!> and one corner at the central ip. +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipVolumes + use math, only: & + math_volTetrahedron, & + math_areaTriangle + + implicit none + integer(pInt) :: e,t,g,c,i,m,f,n + real(pReal), dimension(FE_maxNcellnodesPerCellface,FE_maxNcellfaces) :: subvolume + + + allocate(mesh_ipVolume(theMesh%elem%nIPs,theMesh%nElems),source=0.0_pReal) + + + !$OMP PARALLEL DO PRIVATE(t,g,c,m,subvolume) + do e = 1_pInt,theMesh%nElems ! loop over cpElems + select case (theMesh%elem%cellType) + + case (1_pInt) ! 2D 3node + forall (i = 1_pInt:theMesh%elem%nIPs) & ! loop over ips=cells in this element + mesh_ipVolume(i,e) = math_areaTriangle(mesh_cellnode(1:3,mesh_cell(1,i,e)), & + mesh_cellnode(1:3,mesh_cell(2,i,e)), & + mesh_cellnode(1:3,mesh_cell(3,i,e))) + + case (2_pInt) ! 2D 4node + forall (i = 1_pInt:theMesh%elem%nIPs) & ! loop over ips=cells in this element + mesh_ipVolume(i,e) = math_areaTriangle(mesh_cellnode(1:3,mesh_cell(1,i,e)), & ! here we assume a planar shape, so division in two triangles suffices + mesh_cellnode(1:3,mesh_cell(2,i,e)), & + mesh_cellnode(1:3,mesh_cell(3,i,e))) & + + math_areaTriangle(mesh_cellnode(1:3,mesh_cell(3,i,e)), & + mesh_cellnode(1:3,mesh_cell(4,i,e)), & + mesh_cellnode(1:3,mesh_cell(1,i,e))) + + case (3_pInt) ! 3D 4node + forall (i = 1_pInt:theMesh%elem%nIPs) & ! loop over ips=cells in this element + mesh_ipVolume(i,e) = math_volTetrahedron(mesh_cellnode(1:3,mesh_cell(1,i,e)), & + mesh_cellnode(1:3,mesh_cell(2,i,e)), & + mesh_cellnode(1:3,mesh_cell(3,i,e)), & + mesh_cellnode(1:3,mesh_cell(4,i,e))) + + case (4_pInt) + c = theMesh%elem%cellType ! 3D 8node + m = FE_NcellnodesPerCellface(c) + do i = 1_pInt,theMesh%elem%nIPs ! loop over ips=cells in this element + subvolume = 0.0_pReal + forall(f = 1_pInt:FE_NipNeighbors(c), n = 1_pInt:FE_NcellnodesPerCellface(c)) & + subvolume(n,f) = math_volTetrahedron(& + mesh_cellnode(1:3,mesh_cell(FE_cellface( n ,f,c),i,e)), & + mesh_cellnode(1:3,mesh_cell(FE_cellface(1+mod(n ,m),f,c),i,e)), & + mesh_cellnode(1:3,mesh_cell(FE_cellface(1+mod(n+1,m),f,c),i,e)), & + mesh_ipCoordinates(1:3,i,e)) + mesh_ipVolume(i,e) = 0.5_pReal * sum(subvolume) ! each subvolume is based on four tetrahedrons, altough the face consists of only two triangles -> averaging factor two + enddo + + end select + enddo + !$OMP END PARALLEL DO + +end subroutine mesh_build_ipVolumes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates IP Coordinates. Allocates global array 'mesh_ipCoordinates' +! Called by all solvers in mesh_init in order to initialize the ip coordinates. +! Later on the current ip coordinates are directly prvided by the spectral solver and by Abaqus, +! so no need to use this subroutine anymore; Marc however only provides nodal displacements, +! so in this case the ip coordinates are always calculated on the basis of this subroutine. +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FOR THE MOMENT THIS SUBROUTINE ACTUALLY CALCULATES THE CELL CENTER AND NOT THE IP COORDINATES, +! AS THE IP IS NOT (ALWAYS) LOCATED IN THE CENTER OF THE IP VOLUME. +! HAS TO BE CHANGED IN A LATER VERSION. +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipCoordinates + + implicit none + integer(pInt) :: e,c,i,n + real(pReal), dimension(3) :: myCoords + + if (.not. allocated(mesh_ipCoordinates)) & + allocate(mesh_ipCoordinates(3,theMesh%elem%nIPs,theMesh%nElems),source=0.0_pReal) + + !$OMP PARALLEL DO PRIVATE(c,myCoords) + do e = 1_pInt,theMesh%nElems ! loop over cpElems + c = theMesh%elem%cellType + do i = 1_pInt,theMesh%elem%nIPs ! loop over ips=cells in this element + myCoords = 0.0_pReal + do n = 1_pInt,FE_NcellnodesPerCell(c) ! loop over cell nodes in this cell + myCoords = myCoords + mesh_cellnode(1:3,mesh_cell(n,i,e)) + enddo + mesh_ipCoordinates(1:3,i,e) = myCoords / real(FE_NcellnodesPerCell(c),pReal) + enddo + enddo + !$OMP END PARALLEL DO + +end subroutine mesh_build_ipCoordinates + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates cell center coordinates. +!-------------------------------------------------------------------------------------------------- +pure function mesh_cellCenterCoordinates(ip,el) + + implicit none + integer(pInt), intent(in) :: el, & !< element number + ip !< integration point number + real(pReal), dimension(3) :: mesh_cellCenterCoordinates !< x,y,z coordinates of the cell center of the requested IP cell + integer(pInt) :: c,n + + c = theMesh%elem%cellType + mesh_cellCenterCoordinates = 0.0_pReal + do n = 1_pInt,FE_NcellnodesPerCell(c) ! loop over cell nodes in this cell + mesh_cellCenterCoordinates = mesh_cellCenterCoordinates + mesh_cellnode(1:3,mesh_cell(n,ip,el)) + enddo + mesh_cellCenterCoordinates = mesh_cellCenterCoordinates / real(FE_NcellnodesPerCell(c),pReal) + +end function mesh_cellCenterCoordinates + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculation of IP interface areas, allocate globals '_ipArea', and '_ipAreaNormal' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipAreas + use math, only: & + math_crossproduct + + implicit none + integer(pInt) :: e,t,g,c,i,f,n,m + real(pReal), dimension (3,FE_maxNcellnodesPerCellface) :: nodePos, normals + real(pReal), dimension(3) :: normal + + allocate(mesh_ipArea(theMesh%elem%nIPneighbors,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + allocate(mesh_ipAreaNormal(3_pInt,theMesh%elem%nIPneighbors,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + + !$OMP PARALLEL DO PRIVATE(t,g,c,nodePos,normal,normals) + do e = 1_pInt,theMesh%nElems ! loop over cpElems + c = theMesh%elem%cellType + select case (c) + + case (1_pInt,2_pInt) ! 2D 3 or 4 node + do i = 1_pInt,theMesh%elem%nIPs ! loop over ips=cells in this element + do f = 1_pInt,FE_NipNeighbors(c) ! loop over cell faces + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + normal(1) = nodePos(2,2) - nodePos(2,1) ! x_normal = y_connectingVector + normal(2) = -(nodePos(1,2) - nodePos(1,1)) ! y_normal = -x_connectingVector + normal(3) = 0.0_pReal + mesh_ipArea(f,i,e) = norm2(normal) + mesh_ipAreaNormal(1:3,f,i,e) = normal / norm2(normal) ! ensure unit length of area normal + enddo + enddo + + case (3_pInt) ! 3D 4node + do i = 1_pInt,theMesh%elem%nIPs ! loop over ips=cells in this element + do f = 1_pInt,FE_NipNeighbors(c) ! loop over cell faces + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + normal = math_crossproduct(nodePos(1:3,2) - nodePos(1:3,1), & + nodePos(1:3,3) - nodePos(1:3,1)) + mesh_ipArea(f,i,e) = norm2(normal) + mesh_ipAreaNormal(1:3,f,i,e) = normal / norm2(normal) ! ensure unit length of area normal + enddo + enddo + + case (4_pInt) ! 3D 8node + ! for this cell type we get the normal of the quadrilateral face as an average of + ! four normals of triangular subfaces; since the face consists only of two triangles, + ! the sum has to be divided by two; this whole prcedure tries to compensate for + ! probable non-planar cell surfaces + m = FE_NcellnodesPerCellface(c) + do i = 1_pInt,theMesh%elem%nIPs ! loop over ips=cells in this element + do f = 1_pInt,FE_NipNeighbors(c) ! loop over cell faces + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + normals(1:3,n) = 0.5_pReal & + * math_crossproduct(nodePos(1:3,1+mod(n ,m)) - nodePos(1:3,n), & + nodePos(1:3,1+mod(n+1,m)) - nodePos(1:3,n)) + normal = 0.5_pReal * sum(normals,2) + mesh_ipArea(f,i,e) = norm2(normal) + mesh_ipAreaNormal(1:3,f,i,e) = normal / norm2(normal) + enddo + enddo + + end select + enddo + !$OMP END PARALLEL DO + +end subroutine mesh_build_ipAreas + + +!-------------------------------------------------------------------------------------------------- +!> @brief get properties of different types of finite elements +!> @details assign globals: FE_nodesAtIP, FE_ipNeighbor, FE_subNodeOnIPFace +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_FEdata + + implicit none + integer(pInt) :: me + allocate(FE_cellface(FE_maxNcellnodesPerCellface,FE_maxNcellfaces,FE_Ncelltypes), source=0_pInt) + + + ! *** FE_cellface *** + me = 0_pInt + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 2D 3node, VTK_TRIANGLE (5) + reshape(int([& + 2,3, & + 3,1, & + 1,2 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 2D 4node, VTK_QUAD (9) + reshape(int([& + 2,3, & + 4,1, & + 3,4, & + 1,2 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 3D 4node, VTK_TETRA (10) + reshape(int([& + 1,3,2, & + 1,2,4, & + 2,3,4, & + 1,4,3 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 3D 8node, VTK_HEXAHEDRON (12) + reshape(int([& + 2,3,7,6, & + 4,1,5,8, & + 3,4,8,7, & + 1,2,6,5, & + 5,6,7,8, & + 1,4,3,2 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + +end subroutine mesh_build_FEdata + + +end module mesh diff --git a/src/mesh_marc.f90 b/src/mesh_marc.f90 new file mode 100644 index 000000000..0c7d332c9 --- /dev/null +++ b/src/mesh_marc.f90 @@ -0,0 +1,1851 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Koords, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Sets up the mesh for the solver MSC.Marc +!-------------------------------------------------------------------------------------------------- +module mesh + use prec, only: pReal, pInt + use mesh_base + + implicit none + private + integer(pInt), public, protected :: & + mesh_elemType, & !< Element type of the mesh (only support homogeneous meshes) + mesh_Nnodes, & !< total number of nodes in mesh + mesh_Ncellnodes, & !< total number of cell nodes in mesh (including duplicates) + mesh_Ncells, & !< total number of cells in mesh + mesh_maxNsharedElems !< max number of CP elements sharing a node + + integer(pInt), dimension(:), allocatable, public, protected :: & + mesh_homogenizationAt, & !< homogenization ID of each element + mesh_microstructureAt !< microstructure ID of each element + + integer(pInt), dimension(:,:), allocatable, public, protected :: & + mesh_element, & !DEPRECATED + mesh_sharedElem, & !< entryCount and list of elements containing node + mesh_nodeTwins !< node twins are surface nodes that lie exactly on opposite sides of the mesh (surfaces nodes with equal coordinate values in two dimensions) + + integer(pInt), dimension(:,:,:,:), allocatable, public, protected :: & + mesh_ipNeighborhood !< 6 or less neighboring IPs as [element_num, IP_index, neighbor_index that points to me] + + real(pReal), public, protected :: & + mesh_unitlength !< physical length of one unit in mesh + + real(pReal), dimension(:,:), allocatable, public :: & + mesh_node, & !< node x,y,z coordinates (after deformation! ONLY FOR MARC!!!) + mesh_cellnode !< cell node x,y,z coordinates (after deformation! ONLY FOR MARC!!!) + + real(pReal), dimension(:,:), allocatable, public, protected :: & + mesh_ipVolume, & !< volume associated with IP (initially!) + mesh_node0 !< node x,y,z coordinates (initially!) + + real(pReal), dimension(:,:,:), allocatable, public, protected :: & + mesh_ipArea !< area of interface to neighboring IP (initially!) + + real(pReal), dimension(:,:,:), allocatable, public :: & + mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!) + + real(pReal),dimension(:,:,:,:), allocatable, public, protected :: & + mesh_ipAreaNormal !< area normal of interface to neighboring IP (initially!) + + logical, dimension(3), public, protected :: mesh_periodicSurface !< flag indicating periodic outer surfaces (used for fluxes) + + +integer(pInt), dimension(:,:), allocatable, private :: & + mesh_cellnodeParent !< cellnode's parent element ID, cellnode's intra-element ID + + integer(pInt),dimension(:,:,:), allocatable, private :: & + mesh_cell !< cell connectivity for each element,ip/cell + + integer(pInt), dimension(:,:,:), allocatable, private :: & + FE_cellface !< list of intra-cell cell node IDs that constitute the cell faces of a specific type of cell + + +! These definitions should actually reside in the FE-solver specific part (different for MARC/ABAQUS) +! Hence, I suggest to prefix with "FE_" + + integer(pInt), parameter, public :: & + FE_Nelemtypes = 13_pInt, & + FE_Ngeomtypes = 10_pInt, & + FE_Ncelltypes = 4_pInt, & + FE_maxNipNeighbors = 6_pInt, & + FE_maxmaxNnodesAtIP = 8_pInt, & !< max number of (equivalent) nodes attached to an IP + FE_maxNmatchingNodesPerFace = 4_pInt, & + FE_maxNfaces = 6_pInt, & + FE_maxNcellnodes = 64_pInt, & + FE_maxNcellnodesPerCell = 8_pInt, & + FE_maxNcellfaces = 6_pInt, & + FE_maxNcellnodesPerCellface = 4_pInt + + + integer(pInt), dimension(FE_Ngeomtypes), parameter, private :: FE_Nfaces = & !< number of faces of a specific type of element geometry + int([ & + 3, & ! element 6 (2D 3node 1ip) + 3, & ! element 125 (2D 6node 3ip) + 4, & ! element 11 (2D 4node 4ip) + 4, & ! element 27 (2D 8node 9ip) + 4, & ! element 134 (3D 4node 1ip) + 4, & ! element 127 (3D 10node 4ip) + 5, & ! element 136 (3D 6node 6ip) + 6, & ! element 117 (3D 8node 1ip) + 6, & ! element 7 (3D 8node 8ip) + 6 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_Ngeomtypes), parameter, private :: FE_NmatchingNodes = & !< number of nodes that are needed for face matching in a specific type of element geometry + int([ & + 3, & ! element 6 (2D 3node 1ip) + 3, & ! element 125 (2D 6node 3ip) + 4, & ! element 11 (2D 4node 4ip) + 4, & ! element 27 (2D 8node 9ip) + 4, & ! element 134 (3D 4node 1ip) + 4, & ! element 127 (3D 10node 4ip) + 6, & ! element 136 (3D 6node 6ip) + 8, & ! element 117 (3D 8node 1ip) + 8, & ! element 7 (3D 8node 8ip) + 8 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_maxNfaces,FE_Ngeomtypes), parameter, private :: & + FE_NmatchingNodesPerFace = & !< number of matching nodes per face in a specific type of element geometry + reshape(int([ & + 2,2,2,0,0,0, & ! element 6 (2D 3node 1ip) + 2,2,2,0,0,0, & ! element 125 (2D 6node 3ip) + 2,2,2,2,0,0, & ! element 11 (2D 4node 4ip) + 2,2,2,2,0,0, & ! element 27 (2D 8node 9ip) + 3,3,3,3,0,0, & ! element 134 (3D 4node 1ip) + 3,3,3,3,0,0, & ! element 127 (3D 10node 4ip) + 3,4,4,4,3,0, & ! element 136 (3D 6node 6ip) + 4,4,4,4,4,4, & ! element 117 (3D 8node 1ip) + 4,4,4,4,4,4, & ! element 7 (3D 8node 8ip) + 4,4,4,4,4,4 & ! element 21 (3D 20node 27ip) + ],pInt),[FE_maxNipNeighbors,FE_Ngeomtypes]) + + integer(pInt), dimension(FE_maxNmatchingNodesPerFace,FE_maxNfaces,FE_Ngeomtypes), & + parameter, private :: FE_face = & !< List of node indices on each face of a specific type of element geometry + reshape(int([& + 1,2,0,0 , & ! element 6 (2D 3node 1ip) + 2,3,0,0 , & + 3,1,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,0,0 , & ! element 125 (2D 6node 3ip) + 2,3,0,0 , & + 3,1,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,0,0 , & ! element 11 (2D 4node 4ip) + 2,3,0,0 , & + 3,4,0,0 , & + 4,1,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,0,0 , & ! element 27 (2D 8node 9ip) + 2,3,0,0 , & + 3,4,0,0 , & + 4,1,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,3,0 , & ! element 134 (3D 4node 1ip) + 1,4,2,0 , & + 2,3,4,0 , & + 1,3,4,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,3,0 , & ! element 127 (3D 10node 4ip) + 1,4,2,0 , & + 2,4,3,0 , & + 1,3,4,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,3,0 , & ! element 136 (3D 6node 6ip) + 1,4,5,2 , & + 2,5,6,3 , & + 1,3,6,4 , & + 4,6,5,0 , & + 0,0,0,0 , & + 1,2,3,4 , & ! element 117 (3D 8node 1ip) + 2,1,5,6 , & + 3,2,6,7 , & + 4,3,7,8 , & + 4,1,5,8 , & + 8,7,6,5 , & + 1,2,3,4 , & ! element 7 (3D 8node 8ip) + 2,1,5,6 , & + 3,2,6,7 , & + 4,3,7,8 , & + 4,1,5,8 , & + 8,7,6,5 , & + 1,2,3,4 , & ! element 21 (3D 20node 27ip) + 2,1,5,6 , & + 3,2,6,7 , & + 4,3,7,8 , & + 4,1,5,8 , & + 8,7,6,5 & + ],pInt),[FE_maxNmatchingNodesPerFace,FE_maxNfaces,FE_Ngeomtypes]) + + + integer(pInt), dimension(FE_Ncelltypes), parameter, private :: FE_NcellnodesPerCellface = & !< number of cell nodes per cell face in a specific cell type + int([& + 2, & ! (2D 3node) + 2, & ! (2D 4node) + 3, & ! (3D 4node) + 4 & ! (3D 8node) + ],pInt) + + integer(pInt), dimension(FE_Ncelltypes), parameter, private :: FE_NipNeighbors = & !< number of ip neighbors / cell faces in a specific cell type + int([& + 3, & ! (2D 3node) + 4, & ! (2D 4node) + 4, & ! (3D 4node) + 6 & ! (3D 8node) + ],pInt) + + + integer(pInt), private :: & + mesh_Nelems, & !< total number of elements in mesh (including non-DAMASK elements) + mesh_NelemSets + character(len=64), dimension(:), allocatable, private :: & + mesh_nameElemSet + + integer(pInt), dimension(:,:), allocatable, private :: & + mesh_mapElemSet !< list of elements in elementSet + integer(pInt), dimension(:,:), allocatable, target, private :: & + mesh_mapFEtoCPelem, & !< [sorted FEid, corresponding CPid] + mesh_mapFEtoCPnode !< [sorted FEid, corresponding CPid] + + + integer(pInt), private :: & + MarcVersion, & !< Version of input file format (Marc only) + hypoelasticTableStyle, & !< Table style (Marc only) + initialcondTableStyle !< Table style (Marc only) + integer(pInt), dimension(:), allocatable, private :: & + Marc_matNumber !< array of material numbers for hypoelastic material (Marc only) + + public :: & + mesh_init, & + mesh_build_cellnodes, & + mesh_build_ipVolumes, & + mesh_build_ipCoordinates, & + mesh_cellCenterCoordinates, & + mesh_FEasCP + + + private :: & + mesh_get_damaskOptions, & + mesh_build_cellconnectivity, & + mesh_build_ipAreas, & + FE_mapElemtype, & + mesh_build_FEdata, & + mesh_build_nodeTwins, & + mesh_build_sharedElems, & + mesh_build_ipNeighborhood, & + mesh_marc_get_fileFormat, & + mesh_marc_get_tableStyles, & + mesh_marc_get_matNumber, & + mesh_marc_count_nodesAndElements, & + mesh_marc_count_elementSets, & + mesh_marc_map_elementSets, & + mesh_marc_map_Elements, & + mesh_marc_map_nodes, & + mesh_marc_build_nodes, & + mesh_marc_build_elements + +type, public, extends(tMesh) :: tMesh_marc + + contains + procedure, pass(self) :: tMesh_marc_init + generic, public :: init => tMesh_marc_init +end type tMesh_marc + + type(tMesh_marc), public, protected :: theMesh + + +contains + +subroutine tMesh_marc_init(self,elemType,nodes) + + implicit none + class(tMesh_marc) :: self + real(pReal), dimension(:,:), intent(in) :: nodes + integer(pInt), intent(in) :: elemType + + call self%tMesh%init('mesh',elemType,nodes) + +end subroutine tMesh_marc_init + +!-------------------------------------------------------------------------------------------------- +!> @brief initializes the mesh by calling all necessary private routines the mesh module +!! Order and routines strongly depend on type of solver +!-------------------------------------------------------------------------------------------------- +subroutine mesh_init(ip,el) + use DAMASK_interface + use IO, only: & + IO_open_InputFile, & + IO_timeStamp, & + IO_error, & + IO_write_jobFile + use debug, only: & + debug_e, & + debug_i, & + debug_level, & + debug_mesh, & + debug_levelBasic + use numerics, only: & + usePingPong, & + numerics_unitlength, & + worldrank + use FEsolving, only: & + modelName, & + calcMode, & + FEsolving_execElem, & + FEsolving_execIP + + implicit none + integer(pInt), intent(in) :: el, ip + + integer(pInt), parameter :: FILEUNIT = 222_pInt + integer(pInt) :: j, fileFormatVersion, elemType + integer(pInt) :: & + mesh_maxNelemInSet, & + mesh_NcpElems + logical :: myDebug + + write(6,'(/,a)') ' <<<+- mesh init -+>>>' + + mesh_unitlength = numerics_unitlength ! set physical extent of a length unit in mesh + + myDebug = (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) + + call IO_open_inputFile(FILEUNIT,modelName) ! parse info from input file... + if (myDebug) write(6,'(a)') ' Opened input file'; flush(6) + + MarcVersion = mesh_marc_get_fileFormat(FILEUNIT) + fileFormatVersion = MarcVersion + if (myDebug) write(6,'(a)') ' Got input file format'; flush(6) + + call mesh_marc_get_tableStyles(initialcondTableStyle,hypoelasticTableStyle,FILEUNIT) + if (myDebug) write(6,'(a)') ' Got table styles'; flush(6) + + if (fileFormatVersion > 12) then + Marc_matNumber = mesh_marc_get_matNumber(FILEUNIT,hypoelasticTableStyle) + if (myDebug) write(6,'(a)') ' Got hypoleastic material number'; flush(6) + endif + + call mesh_marc_count_nodesAndElements(mesh_nNodes, mesh_nElems, FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted nodes/elements'; flush(6) + + call mesh_marc_count_elementSets(mesh_NelemSets,mesh_maxNelemInSet,FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted element sets'; flush(6) + + allocate(mesh_nameElemSet(mesh_NelemSets)); mesh_nameElemSet = 'n/a' + allocate(mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets),source=0_pInt) + call mesh_marc_map_elementSets(mesh_nameElemSet,mesh_mapElemSet,FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped element sets'; flush(6) + + mesh_NcpElems = mesh_nElems + if (myDebug) write(6,'(a)') ' Counted CP elements'; flush(6) + + allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems), source = 0_pInt) + call mesh_marc_map_elements(hypoelasticTableStyle,mesh_nameElemSet,mesh_mapElemSet,mesh_NcpElems,FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped elements'; flush(6) + + allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes),source=0_pInt) + call mesh_marc_map_nodes(mesh_Nnodes,FILEUNIT) !ToDo: don't work on global variables + if (myDebug) write(6,'(a)') ' Mapped nodes'; flush(6) + + call mesh_marc_build_nodes(FILEUNIT) !ToDo: don't work on global variables + mesh_node = mesh_node0 + if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) + + elemType = mesh_marc_count_cpSizes(FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted CP sizes'; flush(6) + + call theMesh%init(elemType,mesh_node0) + call theMesh%setNelems(mesh_NcpElems) + + call mesh_marc_build_elements(FILEUNIT) + if (myDebug) write(6,'(a)') ' Built elements'; flush(6) + call mesh_get_damaskOptions(mesh_periodicSurface,FILEUNIT) + if (myDebug) write(6,'(a)') ' Got DAMASK options'; flush(6) + close (FILEUNIT) + + + call mesh_build_FEdata ! get properties of the different types of elements + call mesh_build_cellconnectivity + if (myDebug) write(6,'(a)') ' Built cell connectivity'; flush(6) + mesh_cellnode = mesh_build_cellnodes(mesh_node,mesh_Ncellnodes) + if (myDebug) write(6,'(a)') ' Built cell nodes'; flush(6) + call mesh_build_ipCoordinates + if (myDebug) write(6,'(a)') ' Built IP coordinates'; flush(6) + call mesh_build_ipVolumes + if (myDebug) write(6,'(a)') ' Built IP volumes'; flush(6) + call mesh_build_ipAreas + if (myDebug) write(6,'(a)') ' Built IP areas'; flush(6) + + + call mesh_build_nodeTwins + if (myDebug) write(6,'(a)') ' Built node twins'; flush(6) + call mesh_build_sharedElems + if (myDebug) write(6,'(a)') ' Built shared elements'; flush(6) + call mesh_build_ipNeighborhood + if (myDebug) write(6,'(a)') ' Built IP neighborhood'; flush(6) + + if (usePingPong .and. (mesh_Nelems /= theMesh%nElems)) & + call IO_error(600_pInt) ! ping-pong must be disabled when having non-DAMASK elements + if (debug_e < 1 .or. debug_e > theMesh%nElems) & + call IO_error(602_pInt,ext_msg='element') ! selected element does not exist + if (debug_i < 1 .or. debug_i > theMesh%elem%nIPs) & + call IO_error(602_pInt,ext_msg='IP') ! selected element does not have requested IP + + FEsolving_execElem = [ 1_pInt,theMesh%nElems ] ! parallel loop bounds set to comprise all DAMASK elements + allocate(FEsolving_execIP(2_pInt,theMesh%nElems), source=1_pInt) ! parallel loop bounds set to comprise from first IP... + FEsolving_execIP(2,:) = theMesh%elem%nIPs + + allocate(calcMode(theMesh%elem%nIPs,theMesh%nElems)) + calcMode = .false. ! pretend to have collected what first call is asking (F = I) + calcMode(ip,mesh_FEasCP('elem',el)) = .true. ! first ip,el needs to be already pingponged to "calc" + +!!!! COMPATIBILITY HACK !!!! +! better name + mesh_homogenizationAt = mesh_element(3,:) + mesh_microstructureAt = mesh_element(4,:) +!!!!!!!!!!!!!!!!!!!!!!!! + +end subroutine mesh_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief Figures out version of Marc input file format +!-------------------------------------------------------------------------------------------------- +integer(pInt) function mesh_marc_get_fileFormat(fileUnit) + use IO, only: & + IO_lc, & + IO_intValue, & + IO_stringValue, & + IO_stringPos + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'version') then + mesh_marc_get_fileFormat = IO_intValue(line,chunkPos,2_pInt) + exit + endif + enddo + +620 end function mesh_marc_get_fileFormat + + +!-------------------------------------------------------------------------------------------------- +!> @brief Figures out table styles for initial cond and hypoelastic +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_get_tableStyles(initialcond, hypoelastic,fileUnit) + use IO, only: & + IO_lc, & + IO_intValue, & + IO_stringValue, & + IO_stringPos + + implicit none + integer(pInt), intent(out) :: initialcond, hypoelastic + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + initialcond = 0_pInt + hypoelastic = 0_pInt + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'table' .and. chunkPos(1_pInt) > 5) then + initialcond = IO_intValue(line,chunkPos,4_pInt) + hypoelastic = IO_intValue(line,chunkPos,5_pInt) + exit + endif + enddo + +620 end subroutine mesh_marc_get_tableStyles + + +!-------------------------------------------------------------------------------------------------- +!> @brief Figures out material number of hypoelastic material +!-------------------------------------------------------------------------------------------------- +function mesh_marc_get_matNumber(fileUnit,tableStyle) + use IO, only: & + IO_lc, & + IO_intValue, & + IO_stringValue, & + IO_stringPos + + implicit none + integer(pInt), intent(in) :: fileUnit, tableStyle + integer(pInt), dimension(:), allocatable :: mesh_marc_get_matNumber + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: i, j, data_blocks + character(len=300) line + + + rewind(fileUnit) + + data_blocks = 1_pInt + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'hypoelastic') then + read (fileUnit,'(A300)',END=620) line + if (len(trim(line))/=0_pInt) then + chunkPos = IO_stringPos(line) + data_blocks = IO_intValue(line,chunkPos,1_pInt) + endif + allocate(mesh_marc_get_matNumber(data_blocks), source = 0_pInt) + do i=1_pInt,data_blocks ! read all data blocks + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + mesh_marc_get_matNumber(i) = IO_intValue(line,chunkPos,1_pInt) + do j=1_pint,2_pInt + tableStyle ! read 2 or 3 remaining lines of data block + read (fileUnit,'(A300)') line + enddo + enddo + exit + endif + enddo + +620 end function mesh_marc_get_matNumber + + +!-------------------------------------------------------------------------------------------------- +!> @brief Count overall number of nodes and elements +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_count_nodesAndElements(nNodes, nElems, fileUnit) + use IO, only: & + IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_IntValue + + implicit none + integer(pInt), intent(in) :: fileUnit + integer(pInt), intent(out) :: nNodes, nElems + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + nNodes = 0_pInt + nElems = 0_pInt + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == 'sizing') & + nElems = IO_IntValue (line,chunkPos,3_pInt) + if ( IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == 'coordinates') then + read (fileUnit,'(A300)') line + chunkPos = IO_stringPos(line) + nNodes = IO_IntValue (line,chunkPos,2_pInt) + exit ! assumes that "coordinates" comes later in file + endif + enddo + +620 end subroutine mesh_marc_count_nodesAndElements + + +!-------------------------------------------------------------------------------------------------- +!> @brief Count overall number of element sets in mesh. +!-------------------------------------------------------------------------------------------------- + subroutine mesh_marc_count_elementSets(nElemSets,maxNelemInSet,fileUnit) + use IO, only: & + IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countContinuousIntValues + + implicit none + integer(pInt), intent(in) :: fileUnit + integer(pInt), intent(out) :: nElemSets, maxNelemInSet + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + + nElemSets = 0_pInt + maxNelemInSet = 0_pInt + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == 'define' .and. & + IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'element' ) then + nElemSets = nElemSets + 1_pInt + maxNelemInSet = max(maxNelemInSet, IO_countContinuousIntValues(fileUnit)) + endif + enddo + +620 end subroutine mesh_marc_count_elementSets + + +!-------------------------------------------------------------------------------------------------- +!> @brief map element sets +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_map_elementSets(nameElemSet,mapElemSet,fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_continuousIntValues + + implicit none + integer(pInt), intent(in) :: fileUnit + character(len=64), dimension(:), intent(out) :: & + nameElemSet + integer(pInt), dimension(:,:), intent(out) :: & + mapElemSet + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer(pInt) :: elemSet + + elemSet = 0_pInt + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=640) line + chunkPos = IO_stringPos(line) + if( (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'define' ) .and. & + (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'element' ) ) then + elemSet = elemSet+1_pInt + nameElemSet(elemSet) = trim(IO_stringValue(line,chunkPos,4_pInt)) + mapElemSet(:,elemSet) = IO_continuousIntValues(fileUnit,size(mapElemSet,1)-1,nameElemSet,mapElemSet,size(nameElemSet)) + endif + enddo + +640 end subroutine mesh_marc_map_elementSets + + +!-------------------------------------------------------------------------------------------------- +!> @brief Maps elements from FE ID to internal (consecutive) representation. +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_map_elements(tableStyle,nameElemSet,mapElemSet,nElems,fileUnit) + + use math, only: math_qsort + use IO, only: IO_lc, & + IO_intValue, & + IO_stringValue, & + IO_stringPos, & + IO_continuousIntValues + + implicit none + integer(pInt), intent(in) :: fileUnit,tableStyle,nElems + character(len=64), intent(in), dimension(:) :: nameElemSet + integer(pInt), dimension(:,:), intent(in) :: & + mapElemSet + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line, & + tmp + + integer(pInt), dimension (1_pInt+nElems) :: contInts + integer(pInt) :: i,cpElem + + cpElem = 0_pInt + contInts = 0_pInt + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=660) line + chunkPos = IO_stringPos(line) + if (MarcVersion < 13) then ! Marc 2016 or earlier + if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'hypoelastic' ) then + do i=1_pInt,3_pInt+TableStyle ! skip three (or four if new table style!) lines + read (fileUnit,'(A300)') line + enddo + contInts = IO_continuousIntValues(fileUnit,nElems,nameElemSet,& + mapElemSet,size(nameElemSet)) + exit + endif + else ! Marc2017 and later + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'connectivity') then + read (fileUnit,'(A300)',END=660) line + chunkPos = IO_stringPos(line) + if(any(Marc_matNumber==IO_intValue(line,chunkPos,6_pInt))) then + do + read (fileUnit,'(A300)',END=660) line + chunkPos = IO_stringPos(line) + tmp = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) + if (verify(trim(tmp),"0123456789")/=0) then ! found keyword + exit + else + contInts(1) = contInts(1) + 1_pInt + read (tmp,*) contInts(contInts(1)+1) + endif + enddo + endif + endif + endif + enddo +660 do i = 1_pInt,contInts(1) + cpElem = cpElem+1_pInt + mesh_mapFEtoCPelem(1,cpElem) = contInts(1_pInt+i) + mesh_mapFEtoCPelem(2,cpElem) = cpElem + enddo + +call math_qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems + +end subroutine mesh_marc_map_elements + + +!-------------------------------------------------------------------------------------------------- +!> @brief Maps node from FE ID to internal (consecutive) representation. +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_map_nodes(nNodes,fileUnit) + + use math, only: math_qsort + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_fixedIntValue + + implicit none + integer(pInt), intent(in) :: fileUnit, nNodes + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + integer(pInt), dimension (nNodes) :: node_count + integer(pInt) :: i + + node_count = 0_pInt + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=650) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'coordinates' ) then + read (fileUnit,'(A300)') line ! skip crap line + do i = 1_pInt,nNodes + read (fileUnit,'(A300)') line + mesh_mapFEtoCPnode(1_pInt,i) = IO_fixedIntValue (line,[0_pInt,10_pInt],1_pInt) + mesh_mapFEtoCPnode(2_pInt,i) = i + enddo + exit + endif + enddo + +650 call math_qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) + +end subroutine mesh_marc_map_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief store x,y,z coordinates of all nodes in mesh. +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_build_nodes(fileUnit) + + use IO, only: & + IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_fixedIntValue, & + IO_fixedNoEFloatValue + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), dimension(5), parameter :: node_ends = int([0,10,30,50,70],pInt) + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer(pInt) :: i,j,m + + allocate ( mesh_node0 (3,mesh_Nnodes), source=0.0_pReal) + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=670) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'coordinates' ) then + read (fileUnit,'(A300)') line ! skip crap line + do i=1_pInt,mesh_Nnodes + read (fileUnit,'(A300)') line + m = mesh_FEasCP('node',IO_fixedIntValue(line,node_ends,1_pInt)) + do j = 1_pInt,3_pInt + mesh_node0(j,m) = mesh_unitlength * IO_fixedNoEFloatValue(line,node_ends,j+1_pInt) + enddo + enddo + exit + endif + enddo + +670 mesh_node = mesh_node0 + +end subroutine mesh_marc_build_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Gets maximum count of nodes, IPs, IP neighbors, and cellnodes among cpElements. +!! Sets global values 'mesh_maxNnodes', 'mesh_maxNips', 'mesh_maxNipNeighbors', +!! and 'mesh_maxNcellnodes' +!-------------------------------------------------------------------------------------------------- +integer(pInt) function mesh_marc_count_cpSizes(fileUnit) + + use IO, only: IO_lc, & + IO_error, & + IO_stringValue, & + IO_stringPos, & + IO_intValue, & + IO_skipChunks + use element + + implicit none + integer(pInt), intent(in) :: fileUnit + + type(tElement) :: tempEl + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer(pInt) :: i,t,g,e,c + + t = -1_pInt + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=630) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'connectivity' ) then + read (fileUnit,'(A300)') line ! Garbage line + do i=1_pInt,mesh_Nelems ! read all elements + read (fileUnit,'(A300)') line + chunkPos = IO_stringPos(line) ! limit to id and type + if (t == -1_pInt) then + t = FE_mapElemtype(IO_stringValue(line,chunkPos,2_pInt)) + call tempEl%init(t) + mesh_marc_count_cpSizes = t + else + if (t /= FE_mapElemtype(IO_stringValue(line,chunkPos,2_pInt))) call IO_error(0_pInt) !ToDo: error message + endif + call IO_skipChunks(fileUnit,tempEl%nNodes-(chunkPos(1_pInt)-2_pInt)) + enddo + exit + endif + enddo + +630 end function mesh_marc_count_cpSizes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Store FEid, type, mat, tex, and node list per element. +!! Allocates global array 'mesh_element' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_build_elements(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_fixedNoEFloatValue, & + IO_skipChunks, & + IO_stringPos, & + IO_intValue, & + IO_continuousIntValues, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + integer(pInt), dimension(1_pInt+theMesh%nElems) :: contInts + integer(pInt) :: i,j,t,sv,myVal,e,nNodesAlreadyRead + + allocate(mesh_element(4_pInt+theMesh%elem%nNodes,theMesh%nElems), source=0_pInt) + mesh_elemType = -1_pInt + + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'connectivity' ) then + read (fileUnit,'(A300)',END=620) line ! garbage line + do i = 1_pInt,mesh_Nelems + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + e = mesh_FEasCP('elem',IO_intValue(line,chunkPos,1_pInt)) + if (e /= 0_pInt) then ! disregard non CP elems + mesh_element(1,e) = -1_pInt ! DEPRECATED + t = FE_mapElemtype(IO_StringValue(line,chunkPos,2_pInt)) ! elem type + if (mesh_elemType /= t .and. mesh_elemType /= -1_pInt) & + call IO_error(191,el=t,ip=mesh_elemType) + mesh_elemType = t + mesh_element(2,e) = t + nNodesAlreadyRead = 0_pInt + do j = 1_pInt,chunkPos(1)-2_pInt + mesh_element(4_pInt+j,e) = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j+2_pInt)) ! CP ids of nodes + enddo + nNodesAlreadyRead = chunkPos(1) - 2_pInt + do while(nNodesAlreadyRead < theMesh%elem%nNodes) ! read on if not all nodes in one line + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + do j = 1_pInt,chunkPos(1) + mesh_element(4_pInt+nNodesAlreadyRead+j,e) & + = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j)) ! CP ids of nodes + enddo + nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) + enddo + endif + enddo + exit + endif + enddo + +620 rewind(fileUnit) ! just in case "initial state" appears before "connectivity" + read (fileUnit,'(A300)',END=630) line + do + chunkPos = IO_stringPos(line) + if( (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'initial') .and. & + (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'state') ) then + if (initialcondTableStyle == 2_pInt) read (fileUnit,'(A300)',END=630) line ! read extra line for new style + read (fileUnit,'(A300)',END=630) line ! read line with index of state var + chunkPos = IO_stringPos(line) + sv = IO_IntValue(line,chunkPos,1_pInt) ! figure state variable index + if( (sv == 2_pInt).or.(sv == 3_pInt) ) then ! only state vars 2 and 3 of interest + read (fileUnit,'(A300)',END=630) line ! read line with value of state var + chunkPos = IO_stringPos(line) + do while (scan(IO_stringValue(line,chunkPos,1_pInt),'+-',back=.true.)>1) ! is noEfloat value? + myVal = nint(IO_fixedNoEFloatValue(line,[0_pInt,20_pInt],1_pInt),pInt) ! state var's value + if (initialcondTableStyle == 2_pInt) then + read (fileUnit,'(A300)',END=630) line ! read extra line + read (fileUnit,'(A300)',END=630) line ! read extra line + endif + contInts = IO_continuousIntValues& ! get affected elements + (fileUnit,theMesh%nElems,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) + do i = 1_pInt,contInts(1) + e = mesh_FEasCP('elem',contInts(1_pInt+i)) + mesh_element(1_pInt+sv,e) = myVal + enddo + if (initialcondTableStyle == 0_pInt) read (fileUnit,'(A300)',END=630) line ! ignore IP range for old table style + read (fileUnit,'(A300)',END=630) line + chunkPos = IO_stringPos(line) + enddo + endif + else + read (fileUnit,'(A300)',END=630) line + endif + enddo + +630 end subroutine mesh_marc_build_elements + + +!-------------------------------------------------------------------------------------------------- +!> @brief get any additional damask options from input file, sets mesh_periodicSurface +!-------------------------------------------------------------------------------------------------- +subroutine mesh_get_damaskOptions(periodic_surface,fileUnit) + +use IO, only: & + IO_lc, & + IO_stringValue, & + IO_stringPos + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: myStat + integer(pInt) :: chunk, Nchunks + character(len=300) :: v + logical, dimension(3) :: periodic_surface + + + periodic_surface = .false. + myStat = 0 + rewind(fileUnit) + do while(myStat == 0) + read (fileUnit,'(a300)',iostat=myStat) line + chunkPos = IO_stringPos(line) + Nchunks = chunkPos(1) + if (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '$damask' .and. Nchunks > 1_pInt) then ! found keyword for damask option and there is at least one more chunk to read + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case('periodic') ! damask Option that allows to specify periodic fluxes + do chunk = 3_pInt,Nchunks ! loop through chunks (skipping the keyword) + v = IO_lc(IO_stringValue(line,chunkPos,chunk)) ! chunk matches keyvalues x,y, or z? + mesh_periodicSurface(1) = mesh_periodicSurface(1) .or. v == 'x' + mesh_periodicSurface(2) = mesh_periodicSurface(2) .or. v == 'y' + mesh_periodicSurface(3) = mesh_periodicSurface(3) .or. v == 'z' + enddo + endselect + endif + enddo + +end subroutine mesh_get_damaskOptions + +!-------------------------------------------------------------------------------------------------- +!> @brief Split CP elements into cells. +!> @details Build a mapping between cells and the corresponding cell nodes ('mesh_cell'). +!> Cell nodes that are also matching nodes are unique in the list of cell nodes, +!> all others (currently) might be stored more than once. +!> Also allocates the 'mesh_node' array. +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_cellconnectivity + + implicit none + integer(pInt), dimension(:), allocatable :: & + matchingNode2cellnode + integer(pInt), dimension(:,:), allocatable :: & + cellnodeParent + integer(pInt), dimension(theMesh%elem%Ncellnodes) :: & + localCellnode2globalCellnode + integer(pInt) :: & + e,n,i, & + matchingNodeID, & + localCellnodeID + + allocate(mesh_cell(FE_maxNcellnodesPerCell,theMesh%elem%nIPs,theMesh%nElems), source=0_pInt) + allocate(matchingNode2cellnode(theMesh%nNodes), source=0_pInt) + allocate(cellnodeParent(2_pInt,theMesh%elem%Ncellnodes*theMesh%nElems), source=0_pInt) + + mesh_Ncells = theMesh%nElems*theMesh%elem%nIPs +!-------------------------------------------------------------------------------------------------- +! Count cell nodes (including duplicates) and generate cell connectivity list + mesh_Ncellnodes = 0_pInt + + do e = 1_pInt,theMesh%nElems + localCellnode2globalCellnode = 0_pInt + do i = 1_pInt,theMesh%elem%nIPs + do n = 1_pInt,theMesh%elem%NcellnodesPerCell + localCellnodeID = theMesh%elem%cell(n,i) + if (localCellnodeID <= FE_NmatchingNodes(theMesh%elem%geomType)) then ! this cell node is a matching node + matchingNodeID = mesh_element(4_pInt+localCellnodeID,e) + if (matchingNode2cellnode(matchingNodeID) == 0_pInt) then ! if this matching node does not yet exist in the glbal cell node list ... + mesh_Ncellnodes = mesh_Ncellnodes + 1_pInt ! ... count it as cell node ... + matchingNode2cellnode(matchingNodeID) = mesh_Ncellnodes ! ... and remember its global ID + cellnodeParent(1_pInt,mesh_Ncellnodes) = e ! ... and where it belongs to + cellnodeParent(2_pInt,mesh_Ncellnodes) = localCellnodeID + endif + mesh_cell(n,i,e) = matchingNode2cellnode(matchingNodeID) + else ! this cell node is no matching node + if (localCellnode2globalCellnode(localCellnodeID) == 0_pInt) then ! if this local cell node does not yet exist in the global cell node list ... + mesh_Ncellnodes = mesh_Ncellnodes + 1_pInt ! ... count it as cell node ... + localCellnode2globalCellnode(localCellnodeID) = mesh_Ncellnodes ! ... and remember its global ID ... + cellnodeParent(1_pInt,mesh_Ncellnodes) = e ! ... and it belongs to + cellnodeParent(2_pInt,mesh_Ncellnodes) = localCellnodeID + endif + mesh_cell(n,i,e) = localCellnode2globalCellnode(localCellnodeID) + endif + enddo + enddo + enddo + + allocate(mesh_cellnodeParent(2_pInt,mesh_Ncellnodes)) + allocate(mesh_cellnode(3_pInt,mesh_Ncellnodes)) + + forall(n = 1_pInt:mesh_Ncellnodes) + mesh_cellnodeParent(1,n) = cellnodeParent(1,n) + mesh_cellnodeParent(2,n) = cellnodeParent(2,n) + endforall + +end subroutine mesh_build_cellconnectivity + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculate position of cellnodes from the given position of nodes +!> Build list of cellnodes' coordinates. +!> Cellnode coordinates are calculated from a weighted sum of node coordinates. +!-------------------------------------------------------------------------------------------------- +function mesh_build_cellnodes(nodes,Ncellnodes) + + implicit none + integer(pInt), intent(in) :: Ncellnodes !< requested number of cellnodes + real(pReal), dimension(3,mesh_Nnodes), intent(in) :: nodes + real(pReal), dimension(3,Ncellnodes) :: mesh_build_cellnodes + + integer(pInt) :: & + e,n,m, & + localCellnodeID + real(pReal), dimension(3) :: & + myCoords + + mesh_build_cellnodes = 0.0_pReal +!$OMP PARALLEL DO PRIVATE(e,localCellnodeID,myCoords) + do n = 1_pInt,Ncellnodes ! loop over cell nodes + e = mesh_cellnodeParent(1,n) + localCellnodeID = mesh_cellnodeParent(2,n) + myCoords = 0.0_pReal + do m = 1_pInt,theMesh%elem%nNodes + myCoords = myCoords + nodes(1:3,mesh_element(4_pInt+m,e)) & + * theMesh%elem%cellNodeParentNodeWeights(m,localCellnodeID) + enddo + mesh_build_cellnodes(1:3,n) = myCoords / sum(theMesh%elem%cellNodeParentNodeWeights(:,localCellnodeID)) + enddo +!$OMP END PARALLEL DO + +end function mesh_build_cellnodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates IP volume. Allocates global array 'mesh_ipVolume' +!> @details The IP volume is calculated differently depending on the cell type. +!> 2D cells assume an element depth of one in order to calculate the volume. +!> For the hexahedral cell we subdivide the cell into subvolumes of pyramidal +!> shape with a cell face as basis and the central ip at the tip. This subvolume is +!> calculated as an average of four tetrahedals with three corners on the cell face +!> and one corner at the central ip. +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipVolumes + use math, only: & + math_volTetrahedron, & + math_areaTriangle + + implicit none + integer(pInt) :: e,t,g,c,i,m,f,n + real(pReal), dimension(FE_maxNcellnodesPerCellface,FE_maxNcellfaces) :: subvolume + + allocate(mesh_ipVolume(theMesh%elem%nIPs,theMesh%nElems),source=0.0_pReal) + + !$OMP PARALLEL DO PRIVATE(t,g,c,m,subvolume) + do e = 1_pInt,theMesh%nElems ! loop over cpElems + t = mesh_element(2_pInt,e) ! get element type + g = theMesh%elem%geomType + c = theMesh%elem%cellType + select case (c) + + case (1_pInt) ! 2D 3node + forall (i = 1_pInt:theMesh%elem%nIPs) & ! loop over ips=cells in this element + mesh_ipVolume(i,e) = math_areaTriangle(mesh_cellnode(1:3,mesh_cell(1,i,e)), & + mesh_cellnode(1:3,mesh_cell(2,i,e)), & + mesh_cellnode(1:3,mesh_cell(3,i,e))) + + case (2_pInt) ! 2D 4node + forall (i = 1_pInt:theMesh%elem%nIPs) & ! loop over ips=cells in this element + mesh_ipVolume(i,e) = math_areaTriangle(mesh_cellnode(1:3,mesh_cell(1,i,e)), & ! here we assume a planar shape, so division in two triangles suffices + mesh_cellnode(1:3,mesh_cell(2,i,e)), & + mesh_cellnode(1:3,mesh_cell(3,i,e))) & + + math_areaTriangle(mesh_cellnode(1:3,mesh_cell(3,i,e)), & + mesh_cellnode(1:3,mesh_cell(4,i,e)), & + mesh_cellnode(1:3,mesh_cell(1,i,e))) + + case (3_pInt) ! 3D 4node + forall (i = 1_pInt:theMesh%elem%nIPs) & ! loop over ips=cells in this element + mesh_ipVolume(i,e) = math_volTetrahedron(mesh_cellnode(1:3,mesh_cell(1,i,e)), & + mesh_cellnode(1:3,mesh_cell(2,i,e)), & + mesh_cellnode(1:3,mesh_cell(3,i,e)), & + mesh_cellnode(1:3,mesh_cell(4,i,e))) + + case (4_pInt) ! 3D 8node + m = FE_NcellnodesPerCellface(c) + do i = 1_pInt,theMesh%elem%nIPs ! loop over ips=cells in this element + subvolume = 0.0_pReal + forall(f = 1_pInt:FE_NipNeighbors(c), n = 1_pInt:FE_NcellnodesPerCellface(c)) & + subvolume(n,f) = math_volTetrahedron(& + mesh_cellnode(1:3,mesh_cell(FE_cellface( n ,f,c),i,e)), & + mesh_cellnode(1:3,mesh_cell(FE_cellface(1+mod(n ,m),f,c),i,e)), & + mesh_cellnode(1:3,mesh_cell(FE_cellface(1+mod(n+1,m),f,c),i,e)), & + mesh_ipCoordinates(1:3,i,e)) + mesh_ipVolume(i,e) = 0.5_pReal * sum(subvolume) ! each subvolume is based on four tetrahedrons, altough the face consists of only two triangles -> averaging factor two + enddo + + end select + enddo + !$OMP END PARALLEL DO + +end subroutine mesh_build_ipVolumes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates IP Coordinates. Allocates global array 'mesh_ipCoordinates' +! Called by all solvers in mesh_init in order to initialize the ip coordinates. +! Later on the current ip coordinates are directly prvided by the spectral solver and by Abaqus, +! so no need to use this subroutine anymore; Marc however only provides nodal displacements, +! so in this case the ip coordinates are always calculated on the basis of this subroutine. +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FOR THE MOMENT THIS SUBROUTINE ACTUALLY CALCULATES THE CELL CENTER AND NOT THE IP COORDINATES, +! AS THE IP IS NOT (ALWAYS) LOCATED IN THE CENTER OF THE IP VOLUME. +! HAS TO BE CHANGED IN A LATER VERSION. +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipCoordinates + + implicit none + integer(pInt) :: e,t,g,c,i,n + real(pReal), dimension(3) :: myCoords + + if (.not. allocated(mesh_ipCoordinates)) & + allocate(mesh_ipCoordinates(3,theMesh%elem%nIPs,theMesh%nElems),source=0.0_pReal) + + !$OMP PARALLEL DO PRIVATE(t,g,c,myCoords) + do e = 1_pInt,theMesh%nElems ! loop over cpElems + t = mesh_element(2_pInt,e) ! get element type + g = theMesh%elem%geomType + c = theMesh%elem%cellType + do i = 1_pInt,theMesh%elem%nIPs + myCoords = 0.0_pReal + do n = 1_pInt,theMesh%elem%nCellnodesPerCell + myCoords = myCoords + mesh_cellnode(1:3,mesh_cell(n,i,e)) + enddo + mesh_ipCoordinates(1:3,i,e) = myCoords / real(theMesh%elem%nCellnodesPerCell,pReal) + enddo + enddo + !$OMP END PARALLEL DO + +end subroutine mesh_build_ipCoordinates + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates cell center coordinates. +!-------------------------------------------------------------------------------------------------- +pure function mesh_cellCenterCoordinates(ip,el) + + implicit none + integer(pInt), intent(in) :: el, & !< element number + ip !< integration point number + real(pReal), dimension(3) :: mesh_cellCenterCoordinates !< x,y,z coordinates of the cell center of the requested IP cell + integer(pInt) :: t,g,c,n + + t = mesh_element(2_pInt,el) ! get element type + g = theMesh%elem%geomType + c = theMesh%elem%cellType + mesh_cellCenterCoordinates = 0.0_pReal + do n = 1_pInt,theMesh%elem%nCellnodesPerCell + mesh_cellCenterCoordinates = mesh_cellCenterCoordinates + mesh_cellnode(1:3,mesh_cell(n,ip,el)) + enddo + mesh_cellCenterCoordinates = mesh_cellCenterCoordinates / real(theMesh%elem%nCellnodesPerCell,pReal) + + end function mesh_cellCenterCoordinates + + + + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculation of IP interface areas, allocate globals '_ipArea', and '_ipAreaNormal' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipAreas + use math, only: & + math_crossproduct + + implicit none + integer(pInt) :: e,t,g,c,i,f,n,m + real(pReal), dimension (3,FE_maxNcellnodesPerCellface) :: nodePos, normals + real(pReal), dimension(3) :: normal + + allocate(mesh_ipArea(theMesh%elem%nIPneighbors,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + allocate(mesh_ipAreaNormal(3_pInt,theMesh%elem%nIPneighbors,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + + !$OMP PARALLEL DO PRIVATE(t,g,c,nodePos,normal,normals) + do e = 1_pInt,theMesh%nElems ! loop over cpElems + t = mesh_element(2_pInt,e) ! get element type + g = theMesh%elem%geomType + c = theMesh%elem%cellType + select case (c) + + case (1_pInt,2_pInt) ! 2D 3 or 4 node + do i = 1_pInt,theMesh%elem%nIPs + do f = 1_pInt,FE_NipNeighbors(c) ! loop over cell faces + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + normal(1) = nodePos(2,2) - nodePos(2,1) ! x_normal = y_connectingVector + normal(2) = -(nodePos(1,2) - nodePos(1,1)) ! y_normal = -x_connectingVector + normal(3) = 0.0_pReal + mesh_ipArea(f,i,e) = norm2(normal) + mesh_ipAreaNormal(1:3,f,i,e) = normal / norm2(normal) ! ensure unit length of area normal + enddo + enddo + + case (3_pInt) ! 3D 4node + do i = 1_pInt,theMesh%elem%nIPs + do f = 1_pInt,FE_NipNeighbors(c) ! loop over cell faces + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + normal = math_crossproduct(nodePos(1:3,2) - nodePos(1:3,1), & + nodePos(1:3,3) - nodePos(1:3,1)) + mesh_ipArea(f,i,e) = norm2(normal) + mesh_ipAreaNormal(1:3,f,i,e) = normal / norm2(normal) ! ensure unit length of area normal + enddo + enddo + + case (4_pInt) ! 3D 8node + ! for this cell type we get the normal of the quadrilateral face as an average of + ! four normals of triangular subfaces; since the face consists only of two triangles, + ! the sum has to be divided by two; this whole prcedure tries to compensate for + ! probable non-planar cell surfaces + m = FE_NcellnodesPerCellface(c) + do i = 1_pInt,theMesh%elem%nIPs + do f = 1_pInt,FE_NipNeighbors(c) ! loop over cell faces + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + normals(1:3,n) = 0.5_pReal & + * math_crossproduct(nodePos(1:3,1+mod(n ,m)) - nodePos(1:3,n), & + nodePos(1:3,1+mod(n+1,m)) - nodePos(1:3,n)) + normal = 0.5_pReal * sum(normals,2) + mesh_ipArea(f,i,e) = norm2(normal) + mesh_ipAreaNormal(1:3,f,i,e) = normal / norm2(normal) + enddo + enddo + + end select + enddo + !$OMP END PARALLEL DO + +end subroutine mesh_build_ipAreas + + +!-------------------------------------------------------------------------------------------------- +!> @brief assignment of twin nodes for each cp node, allocate globals '_nodeTwins' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_nodeTwins + + implicit none + integer(pInt) dir, & ! direction of periodicity + node, & + minimumNode, & + maximumNode, & + n1, & + n2 + integer(pInt), dimension(mesh_Nnodes+1) :: minimumNodes, maximumNodes ! list of surface nodes (minimum and maximum coordinate value) with first entry giving the number of nodes + real(pReal) minCoord, maxCoord, & ! extreme positions in one dimension + tolerance ! tolerance below which positions are assumed identical + real(pReal), dimension(3) :: distance ! distance between two nodes in all three coordinates + logical, dimension(mesh_Nnodes) :: unpaired + + allocate(mesh_nodeTwins(3,mesh_Nnodes)) + mesh_nodeTwins = 0_pInt + + tolerance = 0.001_pReal * minval(mesh_ipVolume) ** 0.333_pReal + + do dir = 1_pInt,3_pInt ! check periodicity in directions of x,y,z + if (mesh_periodicSurface(dir)) then ! only if periodicity is requested + + + !*** find out which nodes sit on the surface + !*** and have a minimum or maximum position in this dimension + + minimumNodes = 0_pInt + maximumNodes = 0_pInt + minCoord = minval(mesh_node0(dir,:)) + maxCoord = maxval(mesh_node0(dir,:)) + do node = 1_pInt,mesh_Nnodes ! loop through all nodes and find surface nodes + if (abs(mesh_node0(dir,node) - minCoord) <= tolerance) then + minimumNodes(1) = minimumNodes(1) + 1_pInt + minimumNodes(minimumNodes(1)+1_pInt) = node + elseif (abs(mesh_node0(dir,node) - maxCoord) <= tolerance) then + maximumNodes(1) = maximumNodes(1) + 1_pInt + maximumNodes(maximumNodes(1)+1_pInt) = node + endif + enddo + + + !*** find the corresponding node on the other side with the same position in this dimension + + unpaired = .true. + do n1 = 1_pInt,minimumNodes(1) + minimumNode = minimumNodes(n1+1_pInt) + if (unpaired(minimumNode)) then + do n2 = 1_pInt,maximumNodes(1) + maximumNode = maximumNodes(n2+1_pInt) + distance = abs(mesh_node0(:,minimumNode) - mesh_node0(:,maximumNode)) + if (sum(distance) - distance(dir) <= tolerance) then ! minimum possible distance (within tolerance) + mesh_nodeTwins(dir,minimumNode) = maximumNode + mesh_nodeTwins(dir,maximumNode) = minimumNode + unpaired(maximumNode) = .false. ! remember this node, we don't have to look for his partner again + exit + endif + enddo + endif + enddo + + endif + enddo + +end subroutine mesh_build_nodeTwins + + +!-------------------------------------------------------------------------------------------------- +!> @brief get maximum count of shared elements among cpElements and build list of elements shared +!! by each node in mesh. Allocate globals '_maxNsharedElems' and '_sharedElem' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_sharedElems + + implicit none + integer(pint) e, & ! element index + g, & ! element type + node, & ! CP node index + n, & ! node index per element + myDim, & ! dimension index + nodeTwin ! node twin in the specified dimension + integer(pInt), dimension (mesh_Nnodes) :: node_count + integer(pInt), dimension(:), allocatable :: node_seen + + allocate(node_seen(maxval(FE_NmatchingNodes))) + + node_count = 0_pInt + + do e = 1_pInt,theMesh%nElems + g = theMesh%elem%geomType + node_seen = 0_pInt ! reset node duplicates + do n = 1_pInt,FE_NmatchingNodes(g) ! check each node of element + node = mesh_element(4+n,e) + if (all(node_seen /= node)) then + node_count(node) = node_count(node) + 1_pInt ! if FE node not yet encountered -> count it + do myDim = 1_pInt,3_pInt ! check in each dimension... + nodeTwin = mesh_nodeTwins(myDim,node) + if (nodeTwin > 0_pInt) & ! if I am a twin of some node... + node_count(nodeTwin) = node_count(nodeTwin) + 1_pInt ! -> count me again for the twin node + enddo + endif + node_seen(n) = node ! remember this node to be counted already + enddo + enddo + + mesh_maxNsharedElems = int(maxval(node_count),pInt) ! most shared node + + allocate(mesh_sharedElem(1+mesh_maxNsharedElems,mesh_Nnodes),source=0_pInt) + + do e = 1_pInt,theMesh%nElems + g = theMesh%elem%geomType + node_seen = 0_pInt + do n = 1_pInt,FE_NmatchingNodes(g) + node = mesh_element(4_pInt+n,e) + if (all(node_seen /= node)) then + mesh_sharedElem(1,node) = mesh_sharedElem(1,node) + 1_pInt ! count for each node the connected elements + mesh_sharedElem(mesh_sharedElem(1,node)+1_pInt,node) = e ! store the respective element id + do myDim = 1_pInt,3_pInt ! check in each dimension... + nodeTwin = mesh_nodeTwins(myDim,node) + if (nodeTwin > 0_pInt) then ! if i am a twin of some node... + mesh_sharedElem(1,nodeTwin) = mesh_sharedElem(1,nodeTwin) + 1_pInt ! ...count me again for the twin + mesh_sharedElem(mesh_sharedElem(1,nodeTwin)+1,nodeTwin) = e ! store the respective element id + endif + enddo + endif + node_seen(n) = node + enddo + enddo + +end subroutine mesh_build_sharedElems + + +!-------------------------------------------------------------------------------------------------- +!> @brief build up of IP neighborhood, allocate globals '_ipNeighborhood' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipNeighborhood + use math, only: & + math_mul3x3 + + implicit none + integer(pInt) :: myElem, & ! my CP element index + myIP, & + myType, & ! my element type + myFace, & + neighbor, & ! neighor index + neighboringIPkey, & ! positive integer indicating the neighboring IP (for intra-element) and negative integer indicating the face towards neighbor (for neighboring element) + candidateIP, & + neighboringType, & ! element type of neighbor + NlinkedNodes, & ! number of linked nodes + twin_of_linkedNode, & ! node twin of a specific linkedNode + NmatchingNodes, & ! number of matching nodes + dir, & ! direction of periodicity + matchingElem, & ! CP elem number of matching element + matchingFace, & ! face ID of matching element + a, anchor, & + neighboringIP, & + neighboringElem, & + pointingToMe + integer(pInt), dimension(FE_maxmaxNnodesAtIP) :: & + linkedNodes = 0_pInt, & + matchingNodes + logical checkTwins + + allocate(mesh_ipNeighborhood(3,theMesh%elem%nIPneighbors,theMesh%elem%nIPs,theMesh%nElems)) + mesh_ipNeighborhood = 0_pInt + + + do myElem = 1_pInt,theMesh%nElems ! loop over cpElems + myType = theMesh%elem%geomType + do myIP = 1_pInt,theMesh%elem%nIPs + + do neighbor = 1_pInt,FE_NipNeighbors(theMesh%elem%cellType) ! loop over neighbors of IP + neighboringIPkey = theMesh%elem%IPneighbor(neighbor,myIP) + + !*** if the key is positive, the neighbor is inside the element + !*** that means, we have already found our neighboring IP + + if (neighboringIPkey > 0_pInt) then + mesh_ipNeighborhood(1,neighbor,myIP,myElem) = myElem + mesh_ipNeighborhood(2,neighbor,myIP,myElem) = neighboringIPkey + + + !*** if the key is negative, the neighbor resides in a neighboring element + !*** that means, we have to look through the face indicated by the key and see which element is behind that face + + elseif (neighboringIPkey < 0_pInt) then ! neighboring element's IP + myFace = -neighboringIPkey + call mesh_faceMatch(myElem, myFace, matchingElem, matchingFace) ! get face and CP elem id of face match + if (matchingElem > 0_pInt) then ! found match? + neighboringType = theMesh%elem%geomType + + !*** trivial solution if neighbor has only one IP + + if (theMesh%elem%nIPs == 1_pInt) then + mesh_ipNeighborhood(1,neighbor,myIP,myElem) = matchingElem + mesh_ipNeighborhood(2,neighbor,myIP,myElem) = 1_pInt + cycle + endif + + !*** find those nodes which build the link to the neighbor + + NlinkedNodes = 0_pInt + linkedNodes = 0_pInt + do a = 1_pInt,theMesh%elem%maxNnodeAtIP + anchor = theMesh%elem%NnodeAtIP(a,myIP) + if (anchor /= 0_pInt) then ! valid anchor node + if (any(FE_face(:,myFace,myType) == anchor)) then ! ip anchor sits on face? + NlinkedNodes = NlinkedNodes + 1_pInt + linkedNodes(NlinkedNodes) = mesh_element(4_pInt+anchor,myElem) ! CP id of anchor node + else ! something went wrong with the linkage, since not all anchors sit on my face + NlinkedNodes = 0_pInt + linkedNodes = 0_pInt + exit + endif + endif + enddo + + !*** loop through the ips of my neighbor + !*** and try to find an ip with matching nodes + !*** also try to match with node twins + + checkCandidateIP: do candidateIP = 1_pInt,theMesh%elem%nIPs + NmatchingNodes = 0_pInt + matchingNodes = 0_pInt + do a = 1_pInt,theMesh%elem%maxNnodeAtIP + anchor = theMesh%elem%NnodeAtIP(a,candidateIP) + if (anchor /= 0_pInt) then ! valid anchor node + if (any(FE_face(:,matchingFace,neighboringType) == anchor)) then ! sits on matching face? + NmatchingNodes = NmatchingNodes + 1_pInt + matchingNodes(NmatchingNodes) = mesh_element(4+anchor,matchingElem) ! CP id of neighbor's anchor node + else ! no matching, because not all nodes sit on the matching face + NmatchingNodes = 0_pInt + matchingNodes = 0_pInt + exit + endif + endif + enddo + + if (NmatchingNodes /= NlinkedNodes) & ! this ip has wrong count of anchors on face + cycle checkCandidateIP + + !*** check "normal" nodes whether they match or not + + checkTwins = .false. + do a = 1_pInt,NlinkedNodes + if (all(matchingNodes /= linkedNodes(a))) then ! this linkedNode does not match any matchingNode + checkTwins = .true. + exit ! no need to search further + endif + enddo + + !*** if no match found, then also check node twins + + if(checkTwins) then + dir = int(maxloc(abs(mesh_ipAreaNormal(1:3,neighbor,myIP,myElem)),1),pInt) ! check for twins only in direction of the surface normal + do a = 1_pInt,NlinkedNodes + twin_of_linkedNode = mesh_nodeTwins(dir,linkedNodes(a)) + if (twin_of_linkedNode == 0_pInt .or. & ! twin of linkedNode does not exist... + all(matchingNodes /= twin_of_linkedNode)) then ! ... or it does not match any matchingNode + cycle checkCandidateIP ! ... then check next candidateIP + endif + enddo + endif + + !*** we found a match !!! + + mesh_ipNeighborhood(1,neighbor,myIP,myElem) = matchingElem + mesh_ipNeighborhood(2,neighbor,myIP,myElem) = candidateIP + exit checkCandidateIP + enddo checkCandidateIP + endif ! end of valid external matching + endif ! end of internal/external matching + enddo + enddo + enddo + do myElem = 1_pInt,theMesh%nElems ! loop over cpElems + myType = theMesh%elem%geomType + do myIP = 1_pInt,theMesh%elem%nIPs + do neighbor = 1_pInt,FE_NipNeighbors(theMesh%elem%cellType) ! loop over neighbors of IP + neighboringElem = mesh_ipNeighborhood(1,neighbor,myIP,myElem) + neighboringIP = mesh_ipNeighborhood(2,neighbor,myIP,myElem) + if (neighboringElem > 0_pInt .and. neighboringIP > 0_pInt) then ! if neighbor exists ... + neighboringType = theMesh%elem%geomType + do pointingToMe = 1_pInt,FE_NipNeighbors(theMesh%elem%cellType) ! find neighboring index that points from my neighbor to myself + if ( myElem == mesh_ipNeighborhood(1,pointingToMe,neighboringIP,neighboringElem) & + .and. myIP == mesh_ipNeighborhood(2,pointingToMe,neighboringIP,neighboringElem)) then ! possible candidate + if (math_mul3x3(mesh_ipAreaNormal(1:3,neighbor,myIP,myElem),& + mesh_ipAreaNormal(1:3,pointingToMe,neighboringIP,neighboringElem)) < 0.0_pReal) then ! area normals have opposite orientation (we have to check that because of special case for single element with two ips and periodicity. In this case the neighbor is identical in two different directions.) + mesh_ipNeighborhood(3,neighbor,myIP,myElem) = pointingToMe ! found match + exit ! so no need to search further + endif + endif + enddo + endif + enddo + enddo + enddo + + contains + + !-------------------------------------------------------------------------------------------------- +!> @brief find face-matching element of same type +!-------------------------------------------------------------------------------------------------- +subroutine mesh_faceMatch(elem, face ,matchingElem, matchingFace) + +implicit none +integer(pInt), intent(out) :: matchingElem, & ! matching CP element ID + matchingFace ! matching face ID +integer(pInt), intent(in) :: face, & ! face ID + elem ! CP elem ID +integer(pInt), dimension(FE_NmatchingNodesPerFace(face,theMesh%elem%geomType)) :: & + myFaceNodes ! global node ids on my face +integer(pInt) :: myType, & + candidateType, & + candidateElem, & + candidateFace, & + candidateFaceNode, & + minNsharedElems, & + NsharedElems, & + lonelyNode = 0_pInt, & + i, & + n, & + dir ! periodicity direction +integer(pInt), dimension(:), allocatable :: element_seen +logical checkTwins + +matchingElem = 0_pInt +matchingFace = 0_pInt +minNsharedElems = mesh_maxNsharedElems + 1_pInt ! init to worst case +myType =theMesh%elem%geomType + +do n = 1_pInt,FE_NmatchingNodesPerFace(face,myType) ! loop over nodes on face + myFaceNodes(n) = mesh_element(4_pInt+FE_face(n,face,myType),elem) ! CP id of face node + NsharedElems = mesh_sharedElem(1_pInt,myFaceNodes(n)) ! figure # shared elements for this node + if (NsharedElems < minNsharedElems) then + minNsharedElems = NsharedElems ! remember min # shared elems + lonelyNode = n ! remember most lonely node + endif +enddo + +allocate(element_seen(minNsharedElems)) +element_seen = 0_pInt + +checkCandidate: do i = 1_pInt,minNsharedElems ! iterate over lonelyNode's shared elements + candidateElem = mesh_sharedElem(1_pInt+i,myFaceNodes(lonelyNode)) ! present candidate elem + if (all(element_seen /= candidateElem)) then ! element seen for the first time? + element_seen(i) = candidateElem + candidateType = theMesh%elem%geomType +checkCandidateFace: do candidateFace = 1_pInt,FE_maxNipNeighbors ! check each face of candidate + if (FE_NmatchingNodesPerFace(candidateFace,candidateType) & + /= FE_NmatchingNodesPerFace(face,myType) & ! incompatible face + .or. (candidateElem == elem .and. candidateFace == face)) then ! this is my face + cycle checkCandidateFace + endif + checkTwins = .false. + do n = 1_pInt,FE_NmatchingNodesPerFace(candidateFace,candidateType) ! loop through nodes on face + candidateFaceNode = mesh_element(4_pInt+FE_face(n,candidateFace,candidateType),candidateElem) + if (all(myFaceNodes /= candidateFaceNode)) then ! candidate node does not match any of my face nodes + checkTwins = .true. ! perhaps the twin nodes do match + exit + endif + enddo + if(checkTwins) then +checkCandidateFaceTwins: do dir = 1_pInt,3_pInt + do n = 1_pInt,FE_NmatchingNodesPerFace(candidateFace,candidateType) ! loop through nodes on face + candidateFaceNode = mesh_element(4+FE_face(n,candidateFace,candidateType),candidateElem) + if (all(myFaceNodes /= mesh_nodeTwins(dir,candidateFaceNode))) then ! node twin does not match either + if (dir == 3_pInt) then + cycle checkCandidateFace + else + cycle checkCandidateFaceTwins ! try twins in next dimension + endif + endif + enddo + exit checkCandidateFaceTwins + enddo checkCandidateFaceTwins + endif + matchingFace = candidateFace + matchingElem = candidateElem + exit checkCandidate ! found my matching candidate + enddo checkCandidateFace + endif +enddo checkCandidate + +end subroutine mesh_faceMatch + +end subroutine mesh_build_ipNeighborhood + + +!-------------------------------------------------------------------------------------------------- +!> @brief mapping of FE element types to internal representation +!-------------------------------------------------------------------------------------------------- +integer(pInt) function FE_mapElemtype(what) + use IO, only: IO_lc, IO_error + + implicit none + character(len=*), intent(in) :: what + + select case (IO_lc(what)) + case ( '6') + FE_mapElemtype = 1_pInt ! Two-dimensional Plane Strain Triangle + case ( '155', & + '125', & + '128') + FE_mapElemtype = 2_pInt ! Two-dimensional Plane Strain triangle (155: cubic shape function, 125/128: second order isoparametric) + case ( '11') + FE_mapElemtype = 3_pInt ! Arbitrary Quadrilateral Plane-strain + case ( '27') + FE_mapElemtype = 4_pInt ! Plane Strain, Eight-node Distorted Quadrilateral + case ( '54') + FE_mapElemtype = 5_pInt ! Plane Strain, Eight-node Distorted Quadrilateral with reduced integration + case ( '134') + FE_mapElemtype = 6_pInt ! Three-dimensional Four-node Tetrahedron + case ( '157') + FE_mapElemtype = 7_pInt ! Three-dimensional, Low-order, Tetrahedron, Herrmann Formulations + case ( '127') + FE_mapElemtype = 8_pInt ! Three-dimensional Ten-node Tetrahedron + case ( '136') + FE_mapElemtype = 9_pInt ! Three-dimensional Arbitrarily Distorted Pentahedral + case ( '117', & + '123') + FE_mapElemtype = 10_pInt ! Three-dimensional Arbitrarily Distorted linear hexahedral with reduced integration + case ( '7') + FE_mapElemtype = 11_pInt ! Three-dimensional Arbitrarily Distorted Brick + case ( '57') + FE_mapElemtype = 12_pInt ! Three-dimensional Arbitrarily Distorted quad hexahedral with reduced integration + case ( '21') + FE_mapElemtype = 13_pInt ! Three-dimensional Arbitrarily Distorted quadratic hexahedral + case default + call IO_error(error_ID=190_pInt,ext_msg=IO_lc(what)) + end select + +end function FE_mapElemtype + + +!-------------------------------------------------------------------------------------------------- +!> @brief get properties of different types of finite elements +!> @details assign globals FE_cellface +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_FEdata + + implicit none + integer(pInt) :: me + allocate(FE_cellface(FE_maxNcellnodesPerCellface,FE_maxNcellfaces,FE_Ncelltypes), source=0_pInt) + + ! *** FE_cellface *** + me = 0_pInt + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 2D 3node, VTK_TRIANGLE (5) + reshape(int([& + 2,3, & + 3,1, & + 1,2 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 2D 4node, VTK_QUAD (9) + reshape(int([& + 2,3, & + 4,1, & + 3,4, & + 1,2 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 3D 4node, VTK_TETRA (10) + reshape(int([& + 1,3,2, & + 1,2,4, & + 2,3,4, & + 1,4,3 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 3D 8node, VTK_HEXAHEDRON (12) + reshape(int([& + 2,3,7,6, & + 4,1,5,8, & + 3,4,8,7, & + 1,2,6,5, & + 5,6,7,8, & + 1,4,3,2 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + +end subroutine mesh_build_FEdata + + +!-------------------------------------------------------------------------------------------------- +!> @brief Gives the FE to CP ID mapping by binary search through lookup array +!! valid questions (what) are 'elem', 'node' +!-------------------------------------------------------------------------------------------------- +integer(pInt) function mesh_FEasCP(what,myID) + use IO, only: & + IO_lc + + implicit none + character(len=*), intent(in) :: what + integer(pInt), intent(in) :: myID + + integer(pInt), dimension(:,:), pointer :: lookupMap + integer(pInt) :: lower,upper,center + + mesh_FEasCP = 0_pInt + select case(IO_lc(what(1:4))) + case('elem') + lookupMap => mesh_mapFEtoCPelem + case('node') + lookupMap => mesh_mapFEtoCPnode + case default + return + endselect + + lower = 1_pInt + upper = int(size(lookupMap,2_pInt),pInt) + + if (lookupMap(1_pInt,lower) == myID) then ! check at bounds QUESTION is it valid to extend bounds by 1 and just do binary search w/o init check at bounds? + mesh_FEasCP = lookupMap(2_pInt,lower) + return + elseif (lookupMap(1_pInt,upper) == myID) then + mesh_FEasCP = lookupMap(2_pInt,upper) + return + endif + binarySearch: do while (upper-lower > 1_pInt) + center = (lower+upper)/2_pInt + if (lookupMap(1_pInt,center) < myID) then + lower = center + elseif (lookupMap(1_pInt,center) > myID) then + upper = center + else + mesh_FEasCP = lookupMap(2_pInt,center) + exit + endif + enddo binarySearch + +end function mesh_FEasCP + +end module mesh diff --git a/src/numerics.f90 b/src/numerics.f90 index 9e585dda7..1678d0c48 100644 --- a/src/numerics.f90 +++ b/src/numerics.f90 @@ -177,13 +177,8 @@ subroutine numerics_init #include use petscsys #endif -#if !defined(Marc4DAMASK) -!$ use OMP_LIB, only: omp_set_num_threads ! Standard conforming module +!$ use OMP_LIB, only: omp_set_num_threads implicit none -#else - implicit none -!$ include "omp_lib.h" ! MSC.Marc includes this file on !its own, avoid conflict with the OMP_LIB module -#endif integer(pInt), parameter :: FILEUNIT = 300_pInt !$ integer :: gotDAMASK_NUM_THREADS = 1 integer :: i, ierr ! no pInt diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index 112592a8c..014dd737b 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -150,61 +150,34 @@ module plastic_nonlocal enum, bind(c) enumerator :: undefined_ID, & - rho_ID, & - delta_ID, & - rho_edge_ID, & - rho_screw_ID, & - rho_sgl_ID, & - delta_sgl_ID, & - rho_sgl_edge_ID, & - rho_sgl_edge_pos_ID, & - rho_sgl_edge_neg_ID, & - rho_sgl_screw_ID, & - rho_sgl_screw_pos_ID, & - rho_sgl_screw_neg_ID, & - rho_sgl_mobile_ID, & - rho_sgl_edge_mobile_ID, & rho_sgl_edge_pos_mobile_ID, & rho_sgl_edge_neg_mobile_ID, & - rho_sgl_screw_mobile_ID, & rho_sgl_screw_pos_mobile_ID, & rho_sgl_screw_neg_mobile_ID, & - rho_sgl_immobile_ID, & - rho_sgl_edge_immobile_ID, & rho_sgl_edge_pos_immobile_ID, & rho_sgl_edge_neg_immobile_ID, & - rho_sgl_screw_immobile_ID, & rho_sgl_screw_pos_immobile_ID, & rho_sgl_screw_neg_immobile_ID, & - rho_dip_ID, & - delta_dip_ID, & rho_dip_edge_ID, & rho_dip_screw_ID, & - excess_rho_ID, & - excess_rho_edge_ID, & - excess_rho_screw_ID, & rho_forest_ID, & shearrate_ID, & resolvedstress_ID, & resolvedstress_external_ID, & resolvedstress_back_ID, & resistance_ID, & - rho_dot_ID, & rho_dot_sgl_ID, & rho_dot_sgl_mobile_ID, & rho_dot_dip_ID, & rho_dot_gen_ID, & rho_dot_gen_edge_ID, & rho_dot_gen_screw_ID, & - rho_dot_sgl2dip_ID, & rho_dot_sgl2dip_edge_ID, & rho_dot_sgl2dip_screw_ID, & rho_dot_ann_ath_ID, & - rho_dot_ann_the_ID, & rho_dot_ann_the_edge_ID, & rho_dot_ann_the_screw_ID, & rho_dot_edgejogs_ID, & - rho_dot_flux_ID, & rho_dot_flux_mobile_ID, & rho_dot_flux_edge_ID, & rho_dot_flux_screw_ID, & @@ -212,28 +185,9 @@ module plastic_nonlocal velocity_edge_neg_ID, & velocity_screw_pos_ID, & velocity_screw_neg_ID, & - slipdirectionx_ID, & - slipdirectiony_ID, & - slipdirectionz_ID, & - slipnormalx_ID, & - slipnormaly_ID, & - slipnormalz_ID, & - fluxdensity_edge_posx_ID, & - fluxdensity_edge_posy_ID, & - fluxdensity_edge_posz_ID, & - fluxdensity_edge_negx_ID, & - fluxdensity_edge_negy_ID, & - fluxdensity_edge_negz_ID, & - fluxdensity_screw_posx_ID, & - fluxdensity_screw_posy_ID, & - fluxdensity_screw_posz_ID, & - fluxdensity_screw_negx_ID, & - fluxdensity_screw_negy_ID, & - fluxdensity_screw_negz_ID, & maximumdipoleheight_edge_ID, & maximumdipoleheight_screw_ID, & - accumulatedshear_ID, & - dislocationstress_ID + accumulatedshear_ID end enum integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & plastic_nonlocal_outputID !< ID of each post result output @@ -262,8 +216,7 @@ contains !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_init(fileUnit) use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) -use math, only: math_Mandel3333to66, & - math_Voigt66to3333, & +use math, only: math_Voigt66to3333, & math_mul3x3, & math_transpose33 use IO, only: IO_read, & @@ -281,9 +234,7 @@ use IO, only: IO_read, & use debug, only: debug_level, & debug_constitutive, & debug_levelBasic -use mesh, only: mesh_NcpElems, & - mesh_maxNips, & - mesh_maxNipNeighbors +use mesh, only: theMesh use material, only: phase_plasticity, & homogenization_maxNgrains, & phase_plasticityInstance, & @@ -291,11 +242,11 @@ use material, only: phase_plasticity, & PLASTICITY_NONLOCAL_label, & PLASTICITY_NONLOCAL_ID, & plasticState, & - material_phase + material_phase, & + material_allocatePlasticState use config, only: MATERIAL_partPhase use lattice -use numerics,only: & - numerics_integrator + implicit none @@ -426,76 +377,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s select case(tag) case ('(output)') select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('rho') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('delta') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = delta_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_edge') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_edge_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_screw') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_screw_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('delta_sgl') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = delta_sgl_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge_pos') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_pos_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge_neg') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_neg_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_screw') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_screw_pos') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_pos_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_screw_neg') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_neg_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_mobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_mobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge_mobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_mobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_sgl_edge_pos_mobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_pos_mobile_ID @@ -506,11 +387,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_neg_mobile_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_screw_mobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_mobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_sgl_screw_pos_mobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_pos_mobile_ID @@ -521,16 +397,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_neg_mobile_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_immobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_immobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_edge_immobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_immobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_sgl_edge_pos_immobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_pos_immobile_ID @@ -541,11 +407,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_neg_immobile_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_sgl_screw_immobile') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_immobile_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_sgl_screw_pos_immobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_pos_immobile_ID @@ -556,16 +417,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_neg_immobile_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_dip') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dip_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('delta_dip') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = delta_dip_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_dip_edge') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dip_edge_ID @@ -576,21 +427,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dip_screw_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('excess_rho') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = excess_rho_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('excess_rho_edge') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = excess_rho_edge_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('excess_rho_screw') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = excess_rho_screw_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_forest') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_forest_ID @@ -621,11 +457,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = resistance_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_dot') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_dot_sgl') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl_ID @@ -656,11 +487,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_gen_screw_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_dot_sgl2dip') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl2dip_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_dot_sgl2dip_edge') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl2dip_edge_ID @@ -676,11 +502,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ann_ath_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_dot_ann_the') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ann_the_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_dot_ann_the_edge') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ann_the_edge_ID @@ -696,11 +517,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_edgejogs_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('rho_dot_flux') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_flux_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('rho_dot_flux_mobile') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_flux_mobile_ID @@ -736,96 +552,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = velocity_screw_neg_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipdirection.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipdirectionx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipdirection.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipdirectiony_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipdirection.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipdirectionz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipnormal.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipnormalx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipnormal.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipnormaly_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('slipnormal.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipnormalz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_pos.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_posx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_pos.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_posy_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_pos.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_posz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_neg.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_negx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_neg.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_negy_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_edge_neg.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_negz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_pos.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_posx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_pos.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_posy_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_pos.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_posz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_neg.x') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_negx_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_neg.y') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_negy_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('fluxdensity_screw_neg.z') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_negz_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case ('maximumdipoleheight_edge') plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = maximumdipoleheight_edge_ID @@ -841,11 +567,6 @@ allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), s plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = accumulatedshear_ID plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - case ('dislocationstress') - plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt - plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = dislocationstress_ID - plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) end select case ('nslip') if (chunkPos(1) < 1_pInt + Nchunks_SlipFamilies) & @@ -1091,23 +812,23 @@ allocate(forestProjectionEdge(maxTotalNslip,maxTotalNslip,maxNinstances), allocate(forestProjectionScrew(maxTotalNslip,maxTotalNslip,maxNinstances), source=0.0_pReal) allocate(interactionMatrixSlipSlip(maxTotalNslip,maxTotalNslip,maxNinstances), source=0.0_pReal) allocate(lattice2slip(1:3, 1:3, maxTotalNslip,maxNinstances), source=0.0_pReal) -allocate(sourceProbability(maxTotalNslip,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & +allocate(sourceProbability(maxTotalNslip,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), & source=2.0_pReal) -allocate(rhoDotFluxOutput(maxTotalNslip,8,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & +allocate(rhoDotFluxOutput(maxTotalNslip,8,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), & source=0.0_pReal) -allocate(rhoDotMultiplicationOutput(maxTotalNslip,2,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & +allocate(rhoDotMultiplicationOutput(maxTotalNslip,2,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), & source=0.0_pReal) -allocate(rhoDotSingle2DipoleGlideOutput(maxTotalNslip,2,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & +allocate(rhoDotSingle2DipoleGlideOutput(maxTotalNslip,2,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), & source=0.0_pReal) -allocate(rhoDotAthermalAnnihilationOutput(maxTotalNslip,2,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & +allocate(rhoDotAthermalAnnihilationOutput(maxTotalNslip,2,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), & source=0.0_pReal) -allocate(rhoDotThermalAnnihilationOutput(maxTotalNslip,2,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & +allocate(rhoDotThermalAnnihilationOutput(maxTotalNslip,2,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), & source=0.0_pReal) -allocate(rhoDotEdgeJogsOutput(maxTotalNslip,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & +allocate(rhoDotEdgeJogsOutput(maxTotalNslip,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), & source=0.0_pReal) -allocate(compatibility(2,maxTotalNslip,maxTotalNslip,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems), & +allocate(compatibility(2,maxTotalNslip,maxTotalNslip,theMesh%elem%nIPneighbors,theMesh%elem%nIPs,theMesh%nElems), & source=0.0_pReal) allocate(peierlsStress(maxTotalNslip,2,maxNinstances), source=0.0_pReal) allocate(colinearSystem(maxTotalNslip,maxNinstances), source=0_pInt) @@ -1195,93 +916,8 @@ allocate(nonSchmidProjection(3,3,4,maxTotalNslip,maxNinstances), outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) select case(plastic_nonlocal_outputID(o,instance)) - case( rho_ID, & - delta_ID, & - rho_edge_ID, & - rho_screw_ID, & - rho_sgl_ID, & - delta_sgl_ID, & - rho_sgl_edge_ID, & - rho_sgl_edge_pos_ID, & - rho_sgl_edge_neg_ID, & - rho_sgl_screw_ID, & - rho_sgl_screw_pos_ID, & - rho_sgl_screw_neg_ID, & - rho_sgl_mobile_ID, & - rho_sgl_edge_mobile_ID, & - rho_sgl_edge_pos_mobile_ID, & - rho_sgl_edge_neg_mobile_ID, & - rho_sgl_screw_mobile_ID, & - rho_sgl_screw_pos_mobile_ID, & - rho_sgl_screw_neg_mobile_ID, & - rho_sgl_immobile_ID, & - rho_sgl_edge_immobile_ID, & - rho_sgl_edge_pos_immobile_ID, & - rho_sgl_edge_neg_immobile_ID, & - rho_sgl_screw_immobile_ID, & - rho_sgl_screw_pos_immobile_ID, & - rho_sgl_screw_neg_immobile_ID, & - rho_dip_ID, & - delta_dip_ID, & - rho_dip_edge_ID, & - rho_dip_screw_ID, & - excess_rho_ID, & - excess_rho_edge_ID, & - excess_rho_screw_ID, & - rho_forest_ID, & - shearrate_ID, & - resolvedstress_ID, & - resolvedstress_external_ID, & - resolvedstress_back_ID, & - resistance_ID, & - rho_dot_ID, & - rho_dot_sgl_ID, & - rho_dot_sgl_mobile_ID, & - rho_dot_dip_ID, & - rho_dot_gen_ID, & - rho_dot_gen_edge_ID, & - rho_dot_gen_screw_ID, & - rho_dot_sgl2dip_ID, & - rho_dot_sgl2dip_edge_ID, & - rho_dot_sgl2dip_screw_ID, & - rho_dot_ann_ath_ID, & - rho_dot_ann_the_ID, & - rho_dot_ann_the_edge_ID, & - rho_dot_ann_the_screw_ID, & - rho_dot_edgejogs_ID, & - rho_dot_flux_ID, & - rho_dot_flux_mobile_ID, & - rho_dot_flux_edge_ID, & - rho_dot_flux_screw_ID, & - velocity_edge_pos_ID, & - velocity_edge_neg_ID, & - velocity_screw_pos_ID, & - velocity_screw_neg_ID, & - slipdirectionx_ID, & - slipdirectiony_ID, & - slipdirectionz_ID, & - slipnormalx_ID, & - slipnormaly_ID, & - slipnormalz_ID, & - fluxdensity_edge_posx_ID, & - fluxdensity_edge_posy_ID, & - fluxdensity_edge_posz_ID, & - fluxdensity_edge_negx_ID, & - fluxdensity_edge_negy_ID, & - fluxdensity_edge_negz_ID, & - fluxdensity_screw_posx_ID, & - fluxdensity_screw_posy_ID, & - fluxdensity_screw_posz_ID, & - fluxdensity_screw_negx_ID, & - fluxdensity_screw_negy_ID, & - fluxdensity_screw_negz_ID, & - maximumdipoleheight_edge_ID, & - maximumdipoleheight_screw_ID, & - accumulatedshear_ID ) - mySize = totalNslip(instance) - case(dislocationstress_ID) - mySize = 6_pInt case default + mySize = totalNslip(instance) end select if (mySize > 0_pInt) then ! any meaningful output found @@ -1290,30 +926,14 @@ allocate(nonSchmidProjection(3,3,4,maxTotalNslip,maxNinstances), endif enddo outputsLoop - plasticState(phase)%sizeState = sizeState - plasticState(phase)%sizeDotState = sizeDotState - plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = plastic_nonlocal_sizePostResults(instance) plasticState(phase)%nonlocal = .true. - plasticState(phase)%nSlip = totalNslip(instance) - plasticState(phase)%nTwin = 0_pInt - plasticState(phase)%nTrans= 0_pInt - allocate(plasticState(phase)%aTolState (sizeState), source=0.0_pReal) - allocate(plasticState(phase)%state0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%state (sizeState,NofMyPhase), source=0.0_pReal) - - allocate(plasticState(phase)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 1_pInt)) then - allocate(plasticState(phase)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(plasticState(phase)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(plasticState(phase)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + call material_allocatePlasticState(phase,NofMyPhase,sizeState,sizeDotState,sizeDeltaState, & + totalNslip(instance),0_pInt,0_pInt) + + plasticState(phase)%offsetDeltaState = 0_pInt + plasticState(phase)%slipRate => & plasticState(phase)%dotState(iGamma(1,instance):iGamma(ns,instance),1:NofMyPhase) plasticState(phase)%accumulatedSlip => & @@ -1404,10 +1024,8 @@ use IO, only: IO_error use lattice, only: lattice_maxNslipFamily use math, only: math_sampleGaussVar use mesh, only: mesh_ipVolume, & - mesh_NcpElems, & - mesh_element, & - FE_Nips, & - FE_geomtype + theMesh, & + mesh_element use material, only: material_phase, & phase_plasticityInstance, & plasticState, & @@ -1446,8 +1064,8 @@ do instance = 1_pInt,maxNinstances minimumIpVolume = huge(1.0_pReal) totalVolume = 0.0_pReal - do e = 1_pInt,mesh_NcpElems - do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + do e = 1_pInt,theMesh%nElems + do i = 1_pInt,theMesh%elem%nIPs if (PLASTICITY_NONLOCAL_ID == phase_plasticity(material_phase(1,i,e)) & .and. instance == phase_plasticityInstance(material_phase(1,i,e))) then totalVolume = totalVolume + mesh_ipVolume(i,e) @@ -1462,8 +1080,8 @@ do instance = 1_pInt,maxNinstances meanDensity = 0.0_pReal do while(meanDensity < rhoSglRandom(instance)) call random_number(rnd) - e = nint(rnd(1)*real(mesh_NcpElems,pReal)+0.5_pReal,pInt) - i = nint(rnd(2)*real(FE_Nips(FE_geomtype(mesh_element(2,e))),pReal)+0.5_pReal,pInt) + e = nint(rnd(1)*real(theMesh%nElems,pReal)+0.5_pReal,pInt) + i = nint(rnd(2)*real(theMesh%elem%nIPs,pReal)+0.5_pReal,pInt) if (PLASTICITY_NONLOCAL_ID == phase_plasticity(material_phase(1,i,e)) & .and. instance == phase_plasticityInstance(material_phase(1,i,e))) then s = nint(rnd(3)*real(ns,pReal)+0.5_pReal,pInt) @@ -1476,8 +1094,8 @@ do instance = 1_pInt,maxNinstances enddo ! homogeneous distribution of density with some noise else - do e = 1_pInt,mesh_NcpElems - do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + do e = 1_pInt,theMesh%nElems + do i = 1_pInt,theMesh%elem%nIPs if (PLASTICITY_NONLOCAL_ID == phase_plasticity(material_phase(1,i,e)) & .and. instance == phase_plasticityInstance(material_phase(1,i,e))) then do f = 1_pInt,lattice_maxNslipFamily @@ -1559,16 +1177,13 @@ use debug, only: & debug_i, & debug_e use mesh, only: & + theMesh, & mesh_element, & mesh_ipNeighborhood, & mesh_ipCoordinates, & mesh_ipVolume, & mesh_ipAreaNormal, & - mesh_ipArea, & - FE_NipNeighbors, & - mesh_maxNipNeighbors, & - FE_geomtype, & - FE_celltype + mesh_ipArea use material, only: & material_phase, & phase_localPlasticity, & @@ -1628,7 +1243,7 @@ real(pReal), dimension(3,3) :: invFe, & ! inverse of elast invFp, & ! inverse of plastic deformation gradient connections, & invConnections -real(pReal), dimension(3,mesh_maxNipNeighbors) :: & +real(pReal), dimension(3,theMesh%elem%nIPneighbors) :: & connection_latticeConf real(pReal), dimension(2,totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))) :: & rhoExcess @@ -1639,7 +1254,7 @@ real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))), & totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))) :: & myInteractionMatrix ! corrected slip interaction matrix -real(pReal), dimension(2,maxval(totalNslip),mesh_maxNipNeighbors) :: & +real(pReal), dimension(2,maxval(totalNslip),theMesh%elem%nIPneighbors) :: & neighbor_rhoExcess, & ! excess density at neighboring material point neighbor_rhoTotal ! total density at neighboring material point real(pReal), dimension(3,totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),2) :: & @@ -1714,7 +1329,7 @@ if (.not. phase_localPlasticity(ph) .and. shortRangeStressCorrection(instance)) nRealNeighbors = 0_pInt neighbor_rhoTotal = 0.0_pReal - do n = 1_pInt,FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el)))) + do n = 1_pInt,theMesh%elem%nIPneighbors neighbor_el = mesh_ipNeighborhood(1,n,ip,el) neighbor_ip = mesh_ipNeighborhood(2,n,ip,el) np = phaseAt(1,neighbor_ip,neighbor_el) @@ -1999,10 +1614,10 @@ end subroutine plastic_nonlocal_kinetics !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_LpAndItsTangent(Lp, dLp_dTstar99, Tstar_v, Temperature, ip, el) -use math, only: math_Plain3333to99, & +use math, only: math_3333to99, & math_mul6x6, & math_mul33xx33, & - math_Mandel6to33 + math_6toSym33 use debug, only: debug_level, & debug_constitutive, & debug_levelExtensive, & @@ -2094,11 +1709,11 @@ do s = 1_pInt,ns tauNS(s,1) = tau(s) tauNS(s,2) = tau(s) if (tau(s) > 0.0_pReal) then - tauNS(s,3) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,1,s,instance)) - tauNS(s,4) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,3,s,instance)) + tauNS(s,3) = math_mul33xx33(math_6toSym33(Tstar_v), nonSchmidProjection(1:3,1:3,1,s,instance)) + tauNS(s,4) = math_mul33xx33(math_6toSym33(Tstar_v), nonSchmidProjection(1:3,1:3,3,s,instance)) else - tauNS(s,3) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,2,s,instance)) - tauNS(s,4) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,4,s,instance)) + tauNS(s,3) = math_mul33xx33(math_6toSym33(Tstar_v), nonSchmidProjection(1:3,1:3,2,s,instance)) + tauNS(s,4) = math_mul33xx33(math_6toSym33(Tstar_v), nonSchmidProjection(1:3,1:3,4,s,instance)) endif enddo forall (t = 1_pInt:4_pInt) & @@ -2173,7 +1788,7 @@ do s = 1_pInt,ns * burgers(s,instance) endif enddo -dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) +dLp_dTstar99 = math_3333to99(dLp_dTstar3333) #ifdef DEBUG @@ -2400,16 +2015,12 @@ use math, only: math_mul6x6, & math_det33, & math_transpose33, & pi -use mesh, only: mesh_NcpElems, & - mesh_maxNips, & +use mesh, only: theMesh, & mesh_element, & mesh_ipNeighborhood, & mesh_ipVolume, & mesh_ipArea, & - mesh_ipAreaNormal, & - FE_NipNeighbors, & - FE_geomtype, & - FE_celltype + mesh_ipAreaNormal use material, only: homogenization_maxNgrains, & material_phase, & phase_plasticityInstance, & @@ -2435,9 +2046,9 @@ integer(pInt), intent(in) :: ip, & real(pReal), intent(in) :: Temperature, & !< temperature timestep !< substepped crystallite time increment real(pReal), dimension(6), intent(in) :: Tstar_v !< current 2nd Piola-Kirchhoff stress in Mandel notation -real(pReal), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: & +real(pReal), dimension(homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), intent(in) :: & subfrac !< fraction of timestep at the beginning of the substepped crystallite time increment -real(pReal), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: & +real(pReal), dimension(3,3,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), intent(in) :: & Fe, & !< elastic deformation gradient Fp !< plastic deformation gradient @@ -2716,8 +2327,8 @@ if (.not. phase_localPlasticity(material_phase(1_pInt,ip,el))) then my_Fe = Fe(1:3,1:3,1_pInt,ip,el) my_F = math_mul33x33(my_Fe, Fp(1:3,1:3,1_pInt,ip,el)) - do n = 1_pInt,FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el)))) ! loop through my neighbors -! write(6,*) 'c' + do n = 1_pInt,theMesh%elem%nIPneighbors + neighbor_el = mesh_ipNeighborhood(1,n,ip,el) neighbor_ip = mesh_ipNeighborhood(2,n,ip,el) neighbor_n = mesh_ipNeighborhood(3,n,ip,el) @@ -3015,11 +2626,7 @@ use material, only: material_phase, & homogenization_maxNgrains use mesh, only: mesh_element, & mesh_ipNeighborhood, & - mesh_maxNips, & - mesh_NcpElems, & - FE_NipNeighbors, & - FE_geomtype, & - FE_celltype + theMesh use lattice, only: lattice_sn, & lattice_sd, & lattice_qDisorientation @@ -3029,7 +2636,7 @@ implicit none !* input variables integer(pInt), intent(in) :: i, & ! ip index e ! element index -type(rotation), dimension(1,mesh_maxNips,mesh_NcpElems), intent(in) :: & +type(rotation), dimension(1,theMesh%elem%nIPs,theMesh%nElems), intent(in) :: & orientation ! crystal orientation in quaternions !* local variables @@ -3048,7 +2655,7 @@ integer(pInt) Nneighbors, & real(pReal), dimension(4) :: absoluteMisorientation ! absolute misorientation (without symmetry) between me and my neighbor real(pReal), dimension(2,totalNslip(phase_plasticityInstance(material_phase(1,i,e))),& totalNslip(phase_plasticityInstance(material_phase(1,i,e))),& - FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,e))))) :: & + theMesh%elem%nIPneighbors) :: & my_compatibility ! my_compatibility for current element and ip real(pReal), dimension(3,totalNslip(phase_plasticityInstance(material_phase(1,i,e)))) :: & slipNormal, & @@ -3060,7 +2667,7 @@ logical, dimension(totalNslip(phase_plasticityInstance(material_phase(1,i,e)))) belowThreshold type(rotation) :: rot -Nneighbors = FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,e)))) +Nneighbors = theMesh%elem%nIPneighbors ph = material_phase(1,i,e) textureID = material_texture(1,i,e) instance = phase_plasticityInstance(ph) @@ -3173,15 +2780,12 @@ use math, only: math_mul33x33, & math_inv33, & math_transpose33, & pi -use mesh, only: mesh_NcpElems, & - mesh_maxNips, & +use mesh, only: theMesh, & mesh_element, & mesh_node0, & mesh_cellCenterCoordinates, & mesh_ipVolume, & - mesh_periodicSurface, & - FE_Nips, & - FE_geomtype + mesh_periodicSurface use material, only: homogenization_maxNgrains, & material_phase, & plasticState, & @@ -3196,7 +2800,7 @@ implicit none !*** input variables integer(pInt), intent(in) :: ip, & !< current integration point el !< current element -real(pReal), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: & +real(pReal), dimension(3,3,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), intent(in) :: & Fe !< elastic deformation gradient !*** output variables @@ -3294,8 +2898,8 @@ if (.not. phase_localPlasticity(ph)) then !* loop through all material points (also through their periodic images if present), !* but only consider nonlocal neighbors within a certain cutoff radius R - do neighbor_el = 1_pInt,mesh_NcpElems - ipLoop: do neighbor_ip = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,neighbor_el))) + do neighbor_el = 1_pInt,theMesh%nElems + ipLoop: do neighbor_ip = 1_pInt,theMesh%elem%nIPs neighbor_phase = material_phase(1_pInt,neighbor_ip,neighbor_el) np = phaseAt(1,neighbor_ip,neighbor_el) no = phasememberAt(1,neighbor_ip,neighbor_el) @@ -3522,8 +3126,7 @@ function plastic_nonlocal_postResults(Tstar_v,Fe,ip,el) math_mul33x33, & pi use mesh, only: & - mesh_NcpElems, & - mesh_maxNips + theMesh use material, only: & homogenization_maxNgrains, & material_phase, & @@ -3541,7 +3144,7 @@ function plastic_nonlocal_postResults(Tstar_v,Fe,ip,el) implicit none real(pReal), dimension(6), intent(in) :: & Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation - real(pReal), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: & + real(pReal), dimension(3,3,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), intent(in) :: & Fe !< elastic deformation gradient integer(pInt), intent(in) :: & ip, & !< integration point @@ -3654,45 +3257,6 @@ forall (s = 1_pInt:ns) & outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) select case(plastic_nonlocal_outputID(o,instance)) - case (rho_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl),2) + sum(rhoDip,2) - cs = cs + ns - - case (rho_sgl_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl),2) - cs = cs + ns - - case (rho_sgl_mobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,1:4)),2) - cs = cs + ns - - case (rho_sgl_immobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,5:8),2) - cs = cs + ns - - case (rho_dip_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDip,2) - cs = cs + ns - - case (rho_edge_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[1,2,5,6])),2) + rhoDip(1:ns,1) - cs = cs + ns - - case (rho_sgl_edge_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[1,2,5,6])),2) - cs = cs + ns - - case (rho_sgl_edge_mobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,1:2),2) - cs = cs + ns - - case (rho_sgl_edge_immobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,5:6),2) - cs = cs + ns - - case (rho_sgl_edge_pos_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) + abs(rhoSgl(1:ns,5)) - cs = cs + ns case (rho_sgl_edge_pos_mobile_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) @@ -3702,10 +3266,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,5) cs = cs + ns - case (rho_sgl_edge_neg_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,2) + abs(rhoSgl(1:ns,6)) - cs = cs + ns - case (rho_sgl_edge_neg_mobile_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,2) cs = cs + ns @@ -3718,26 +3278,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDip(1:ns,1) cs = cs + ns - case (rho_screw_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[3,4,7,8])),2) + rhoDip(1:ns,2) - cs = cs + ns - - case (rho_sgl_screw_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[3,4,7,8])),2) - cs = cs + ns - - case (rho_sgl_screw_mobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,3:4),2) - cs = cs + ns - - case (rho_sgl_screw_immobile_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,7:8),2) - cs = cs + ns - - case (rho_sgl_screw_pos_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) + abs(rhoSgl(1:ns,7)) - cs = cs + ns - case (rho_sgl_screw_pos_mobile_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) cs = cs + ns @@ -3745,10 +3285,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) case (rho_sgl_screw_pos_immobile_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,7) cs = cs + ns - - case (rho_sgl_screw_neg_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,4) + abs(rhoSgl(1:ns,8)) - cs = cs + ns case (rho_sgl_screw_neg_mobile_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,4) @@ -3762,38 +3298,9 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDip(1:ns,2) cs = cs + ns - case (excess_rho_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = (rhoSgl(1:ns,1) + abs(rhoSgl(1:ns,5))) & - - (rhoSgl(1:ns,2) + abs(rhoSgl(1:ns,6))) & - + (rhoSgl(1:ns,3) + abs(rhoSgl(1:ns,7))) & - - (rhoSgl(1:ns,4) + abs(rhoSgl(1:ns,8))) - cs = cs + ns - - case (excess_rho_edge_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = (rhoSgl(1:ns,1) + abs(rhoSgl(1:ns,5))) & - - (rhoSgl(1:ns,2) + abs(rhoSgl(1:ns,6))) - cs = cs + ns - - case (excess_rho_screw_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = (rhoSgl(1:ns,3) + abs(rhoSgl(1:ns,7))) & - - (rhoSgl(1:ns,4) + abs(rhoSgl(1:ns,8))) - cs = cs + ns - case (rho_forest_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoForest cs = cs + ns - - case (delta_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = 1.0_pReal / sqrt(sum(abs(rhoSgl),2) + sum(rhoDip,2)) - cs = cs + ns - - case (delta_sgl_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = 1.0_pReal / sqrt(sum(abs(rhoSgl),2)) - cs = cs + ns - - case (delta_dip_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = 1.0_pReal / sqrt(sum(rhoDip,2)) - cs = cs + ns case (shearrate_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(gdot,2) @@ -3817,12 +3324,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) case (resistance_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = tauThreshold cs = cs + ns - - case (rho_dot_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotSgl(1:ns,1:4),2) & - + sum(rhoDotSgl(1:ns,5:8)*sign(1.0_pReal,rhoSgl(1:ns,5:8)),2) & - + sum(rhoDotDip,2) - cs = cs + ns case (rho_dot_sgl_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotSgl(1:ns,1:4),2) & @@ -3837,7 +3338,7 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotDip,2) cs = cs + ns - case (rho_dot_gen_ID) + case (rho_dot_gen_ID) ! Obsolete plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotMultiplicationOutput(1:ns,1,1_pInt,ip,el) & + rhoDotMultiplicationOutput(1:ns,2,1_pInt,ip,el) cs = cs + ns @@ -3849,11 +3350,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) case (rho_dot_gen_screw_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotMultiplicationOutput(1:ns,2,1_pInt,ip,el) cs = cs + ns - - case (rho_dot_sgl2dip_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotSingle2DipoleGlideOutput(1:ns,1,1_pInt,ip,el) & - + rhoDotSingle2DipoleGlideOutput(1:ns,2,1_pInt,ip,el) - cs = cs + ns case (rho_dot_sgl2dip_edge_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotSingle2DipoleGlideOutput(1:ns,1,1_pInt,ip,el) @@ -3867,11 +3363,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotAthermalAnnihilationOutput(1:ns,1,1_pInt,ip,el) & + rhoDotAthermalAnnihilationOutput(1:ns,2,1_pInt,ip,el) cs = cs + ns - - case (rho_dot_ann_the_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotThermalAnnihilationOutput(1:ns,1,1_pInt,ip,el) & - + rhoDotThermalAnnihilationOutput(1:ns,2,1_pInt,ip,el) - cs = cs + ns case (rho_dot_ann_the_edge_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotThermalAnnihilationOutput(1:ns,1,1_pInt,ip,el) @@ -3889,11 +3380,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotFluxOutput(1:ns,1:4,1_pInt,ip,el),2) cs = cs + ns - case (rho_dot_flux_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotFluxOutput(1:ns,1:4,1_pInt,ip,el),2) & - + sum(rhoDotFluxOutput(1:ns,5:8,1_pInt,ip,el)*sign(1.0_pReal,rhoSgl(1:ns,5:8)),2) - cs = cs + ns - case (rho_dot_flux_edge_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotFluxOutput(1:ns,1:2,1_pInt,ip,el),2) & + sum(rhoDotFluxOutput(1:ns,5:6,1_pInt,ip,el)*sign(1.0_pReal,rhoSgl(1:ns,5:6)),2) @@ -3920,78 +3406,6 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = v(1:ns,4) cs = cs + ns - case (slipdirectionx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = m_currentconf(1,1:ns,1) - cs = cs + ns - - case (slipdirectiony_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = m_currentconf(2,1:ns,1) - cs = cs + ns - - case (slipdirectionz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = m_currentconf(3,1:ns,1) - cs = cs + ns - - case (slipnormalx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = n_currentconf(1,1:ns) - cs = cs + ns - - case (slipnormaly_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = n_currentconf(2,1:ns) - cs = cs + ns - - case (slipnormalz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = n_currentconf(3,1:ns) - cs = cs + ns - - case (fluxdensity_edge_posx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) * v(1:ns,1) * m_currentconf(1,1:ns,1) - cs = cs + ns - - case (fluxdensity_edge_posy_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) * v(1:ns,1) * m_currentconf(2,1:ns,1) - cs = cs + ns - - case (fluxdensity_edge_posz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) * v(1:ns,1) * m_currentconf(3,1:ns,1) - cs = cs + ns - - case (fluxdensity_edge_negx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,2) * v(1:ns,2) * m_currentconf(1,1:ns,1) - cs = cs + ns - - case (fluxdensity_edge_negy_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,2) * v(1:ns,2) * m_currentconf(2,1:ns,1) - cs = cs + ns - - case (fluxdensity_edge_negz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,2) * v(1:ns,2) * m_currentconf(3,1:ns,1) - cs = cs + ns - - case (fluxdensity_screw_posx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) * v(1:ns,3) * m_currentconf(1,1:ns,2) - cs = cs + ns - - case (fluxdensity_screw_posy_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) * v(1:ns,3) * m_currentconf(2,1:ns,2) - cs = cs + ns - - case (fluxdensity_screw_posz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) * v(1:ns,3) * m_currentconf(3,1:ns,2) - cs = cs + ns - - case (fluxdensity_screw_negx_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,4) * v(1:ns,4) * m_currentconf(1,1:ns,2) - cs = cs + ns - - case (fluxdensity_screw_negy_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,4) * v(1:ns,4) * m_currentconf(2,1:ns,2) - cs = cs + ns - - case (fluxdensity_screw_negz_ID) - plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,4) * v(1:ns,4) * m_currentconf(3,1:ns,2) - cs = cs + ns - case (maximumdipoleheight_edge_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = dUpper(1:ns,1) cs = cs + ns @@ -3999,17 +3413,7 @@ outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) case (maximumdipoleheight_screw_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = dUpper(1:ns,2) cs = cs + ns - - case(dislocationstress_ID) - sigma = plastic_nonlocal_dislocationstress(Fe, ip, el) - plastic_nonlocal_postResults(cs+1_pInt) = sigma(1,1) - plastic_nonlocal_postResults(cs+2_pInt) = sigma(2,2) - plastic_nonlocal_postResults(cs+3_pInt) = sigma(3,3) - plastic_nonlocal_postResults(cs+4_pInt) = sigma(1,2) - plastic_nonlocal_postResults(cs+5_pInt) = sigma(2,3) - plastic_nonlocal_postResults(cs+6_pInt) = sigma(3,1) - cs = cs + 6_pInt - + case(accumulatedshear_ID) plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = plasticState(ph)%state(iGamma(1:ns,instance),of) cs = cs + ns diff --git a/src/source_damage_anisoBrittle.f90 b/src/source_damage_anisoBrittle.f90 index 6b222c37c..98aec49b3 100644 --- a/src/source_damage_anisoBrittle.f90 +++ b/src/source_damage_anisoBrittle.f90 @@ -12,7 +12,6 @@ module source_damage_anisoBrittle implicit none private integer(pInt), dimension(:), allocatable, public, protected :: & - source_damage_anisoBrittle_sizePostResults, & !< cumulative size of post results source_damage_anisoBrittle_offset, & !< which source is my current source mechanism? source_damage_anisoBrittle_instance !< instance of source mechanism @@ -22,31 +21,32 @@ module source_damage_anisoBrittle character(len=64), dimension(:,:), allocatable, target, public :: & source_damage_anisoBrittle_output !< name of each post result output - integer(pInt), dimension(:), allocatable, target, public :: & - source_damage_anisoBrittle_Noutput !< number of outputs per instance of this source - - integer(pInt), dimension(:), allocatable, private :: & - source_damage_anisoBrittle_totalNcleavage !< total number of cleavage systems - integer(pInt), dimension(:,:), allocatable, private :: & source_damage_anisoBrittle_Ncleavage !< number of cleavage systems per family - - real(pReal), dimension(:), allocatable, private :: & - source_damage_anisoBrittle_aTol, & - source_damage_anisoBrittle_sdot_0, & - source_damage_anisoBrittle_N - - real(pReal), dimension(:,:), allocatable, private :: & - source_damage_anisoBrittle_critDisp, & - source_damage_anisoBrittle_critLoad enum, bind(c) enumerator :: undefined_ID, & damage_drivingforce_ID end enum - - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - source_damage_anisoBrittle_outputID !< ID of each post result output + + + type, private :: tParameters !< container type for internal constitutive parameters + real(pReal) :: & + aTol, & + sdot_0, & + N + real(pReal), dimension(:), allocatable :: & + critDisp, & + critLoad + integer(pInt) :: & + totalNcleavage + integer(pInt), dimension(:), allocatable :: & + Ncleavage + integer(kind(undefined_ID)), allocatable, dimension(:) :: & + outputID !< ID of each post result output + end type tParameters + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) public :: & @@ -62,30 +62,24 @@ contains !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- -subroutine source_damage_anisoBrittle_init(fileUnit) +subroutine source_damage_anisoBrittle_init #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 use, intrinsic :: iso_fortran_env, only: & compiler_version, & compiler_options #endif + use prec, only: & + pStringLen use debug, only: & debug_level,& debug_constitutive,& debug_levelBasic use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF + IO_error + use math, only: & + math_expand use material, only: & + material_allocateSourceState, & phase_source, & phase_Nsources, & phase_Noutput, & @@ -94,35 +88,34 @@ subroutine source_damage_anisoBrittle_init(fileUnit) material_phase, & sourceState use config, only: & + config_phase, & material_Nphase, & MATERIAL_partPhase - use numerics,only: & - numerics_integrator use lattice, only: & - lattice_maxNcleavageFamily, & - lattice_NcleavageSystem + lattice_maxNcleavageFamily implicit none - integer(pInt), intent(in) :: fileUnit - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,mySize=0_pInt,phase,instance,source,sourceOffset,o - integer(pInt) :: sizeState, sizeDotState, sizeDeltaState - integer(pInt) :: NofMyPhase - integer(pInt) :: Nchunks_CleavageFamilies = 0_pInt, j - character(len=65536) :: & - tag = '', & - line = '' + integer(pInt) :: Ninstance,phase,instance,source,sourceOffset + integer(pInt) :: NofMyPhase,p ,i + integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + integer(kind(undefined_ID)) :: & + outputID - write(6,'(/,a)') ' <<<+- source_'//SOURCE_damage_anisoBrittle_LABEL//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() + character(len=pStringLen) :: & + extmsg = '' + character(len=65536), dimension(:), allocatable :: & + outputs + + write(6,'(/,a)') ' <<<+- source_'//SOURCE_DAMAGE_ANISOBRITTLE_LABEL//' init -+>>>' #include "compilation_info.f90" - maxNinstance = int(count(phase_source == SOURCE_damage_anisoBrittle_ID),pInt) - if (maxNinstance == 0_pInt) return + Ninstance = int(count(phase_source == SOURCE_damage_anisoBrittle_ID),pInt) + if (Ninstance == 0_pInt) return if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance allocate(source_damage_anisoBrittle_offset(material_Nphase), source=0_pInt) allocate(source_damage_anisoBrittle_instance(material_Nphase), source=0_pInt) @@ -133,160 +126,89 @@ subroutine source_damage_anisoBrittle_init(fileUnit) source_damage_anisoBrittle_offset(phase) = source enddo enddo - - allocate(source_damage_anisoBrittle_sizePostResults(maxNinstance), source=0_pInt) - allocate(source_damage_anisoBrittle_sizePostResult(maxval(phase_Noutput),maxNinstance), source=0_pInt) - allocate(source_damage_anisoBrittle_output(maxval(phase_Noutput),maxNinstance)) - source_damage_anisoBrittle_output = '' - allocate(source_damage_anisoBrittle_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) - allocate(source_damage_anisoBrittle_Noutput(maxNinstance), source=0_pInt) - allocate(source_damage_anisoBrittle_critDisp(lattice_maxNcleavageFamily,maxNinstance), source=0.0_pReal) - allocate(source_damage_anisoBrittle_critLoad(lattice_maxNcleavageFamily,maxNinstance), source=0.0_pReal) - allocate(source_damage_anisoBrittle_Ncleavage(lattice_maxNcleavageFamily,maxNinstance), source=0_pInt) - allocate(source_damage_anisoBrittle_totalNcleavage(maxNinstance), source=0_pInt) - allocate(source_damage_anisoBrittle_aTol(maxNinstance), source=0.0_pReal) - allocate(source_damage_anisoBrittle_sdot_0(maxNinstance), source=0.0_pReal) - allocate(source_damage_anisoBrittle_N(maxNinstance), source=0.0_pReal) - - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_damage_anisoBrittle_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - instance = source_damage_anisoBrittle_instance(phase) ! which instance of my damage is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('(output)') - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('anisobrittle_drivingforce') - source_damage_anisoBrittle_Noutput(instance) = source_damage_anisoBrittle_Noutput(instance) + 1_pInt - source_damage_anisoBrittle_outputID(source_damage_anisoBrittle_Noutput(instance),instance) = damage_drivingforce_ID - source_damage_anisoBrittle_output(source_damage_anisoBrittle_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - end select + allocate(source_damage_anisoBrittle_sizePostResult(maxval(phase_Noutput),Ninstance), source=0_pInt) + allocate(source_damage_anisoBrittle_output(maxval(phase_Noutput),Ninstance)) + source_damage_anisoBrittle_output = '' - case ('anisobrittle_atol') - source_damage_anisoBrittle_aTol(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('anisobrittle_sdot0') - source_damage_anisoBrittle_sdot_0(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('anisobrittle_ratesensitivity') - source_damage_anisoBrittle_N(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('ncleavage') ! - Nchunks_CleavageFamilies = chunkPos(1) - 1_pInt - do j = 1_pInt, Nchunks_CleavageFamilies - source_damage_anisoBrittle_Ncleavage(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) - enddo + allocate(source_damage_anisoBrittle_Ncleavage(lattice_maxNcleavageFamily,Ninstance), source=0_pInt) - case ('anisobrittle_criticaldisplacement') - do j = 1_pInt, Nchunks_CleavageFamilies - source_damage_anisoBrittle_critDisp(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo + allocate(param(Ninstance)) + + do p=1, size(config_phase) + if (all(phase_source(:,p) /= SOURCE_DAMAGE_ANISOBRITTLE_ID)) cycle + associate(prm => param(source_damage_anisoBrittle_instance(p)), & + config => config_phase(p)) + + prm%aTol = config%getFloat('anisobrittle_atol',defaultVal = 1.0e-3_pReal) - case ('anisobrittle_criticalload') - do j = 1_pInt, Nchunks_CleavageFamilies - source_damage_anisoBrittle_critLoad(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo + prm%N = config%getFloat('anisobrittle_ratesensitivity') + prm%sdot_0 = config%getFloat('anisobrittle_sdot0') + + ! sanity checks + if (prm%aTol < 0.0_pReal) extmsg = trim(extmsg)//' anisobrittle_atol' + + if (prm%N <= 0.0_pReal) extmsg = trim(extmsg)//' anisobrittle_ratesensitivity' + if (prm%sdot_0 <= 0.0_pReal) extmsg = trim(extmsg)//' anisobrittle_sdot0' + + prm%Ncleavage = config%getInts('ncleavage',defaultVal=emptyIntArray) + + prm%critDisp = config%getFloats('anisobrittle_criticaldisplacement',requiredSize=size(prm%Ncleavage)) + prm%critLoad = config%getFloats('anisobrittle_criticalload', requiredSize=size(prm%Ncleavage)) + + ! expand: family => system + prm%critDisp = math_expand(prm%critDisp, prm%Ncleavage) + prm%critLoad = math_expand(prm%critLoad, prm%Ncleavage) + + if (any(prm%critLoad < 0.0_pReal)) extmsg = trim(extmsg)//' anisobrittle_criticalload' + if (any(prm%critDisp < 0.0_pReal)) extmsg = trim(extmsg)//' anisobrittle_criticaldisplacement' +!-------------------------------------------------------------------------------------------------- +! exit if any parameter is out of range + if (extmsg /= '') & + call IO_error(211_pInt,ext_msg=trim(extmsg)//'('//SOURCE_DAMAGE_ANISOBRITTLE_LABEL//')') + +!-------------------------------------------------------------------------------------------------- +! output pararameters + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) + allocate(prm%outputID(0)) + do i=1_pInt, size(outputs) + outputID = undefined_ID + select case(outputs(i)) + + case ('anisobrittle_drivingforce') + source_damage_anisoBrittle_sizePostResult(i,source_damage_anisoBrittle_instance(p)) = 1_pInt + source_damage_anisoBrittle_output(i,source_damage_anisoBrittle_instance(p)) = outputs(i) + prm%outputID = [prm%outputID, damage_drivingforce_ID] end select - endif; endif - enddo parsingFile -!-------------------------------------------------------------------------------------------------- -! sanity checks - sanityChecks: do phase = 1_pInt, material_Nphase - myPhase: if (any(phase_source(:,phase) == SOURCE_damage_anisoBrittle_ID)) then - instance = source_damage_anisoBrittle_instance(phase) - source_damage_anisoBrittle_Ncleavage(1:lattice_maxNcleavageFamily,instance) = & - min(lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,phase),& ! limit active cleavage systems per family to min of available and requested - source_damage_anisoBrittle_Ncleavage(1:lattice_maxNcleavageFamily,instance)) - source_damage_anisoBrittle_totalNcleavage(instance) = sum(source_damage_anisoBrittle_Ncleavage(:,instance)) ! how many cleavage systems altogether - if (source_damage_anisoBrittle_aTol(instance) < 0.0_pReal) & - source_damage_anisoBrittle_aTol(instance) = 1.0e-3_pReal ! default absolute tolerance 1e-3 - if (source_damage_anisoBrittle_sdot_0(instance) <= 0.0_pReal) & - call IO_error(211_pInt,el=instance,ext_msg='sdot_0 ('//SOURCE_damage_anisoBrittle_LABEL//')') - if (any(source_damage_anisoBrittle_critDisp(1:Nchunks_CleavageFamilies,instance) < 0.0_pReal)) & - call IO_error(211_pInt,el=instance,ext_msg='critical_displacement ('//SOURCE_damage_anisoBrittle_LABEL//')') - if (any(source_damage_anisoBrittle_critLoad(1:Nchunks_CleavageFamilies,instance) < 0.0_pReal)) & - call IO_error(211_pInt,el=instance,ext_msg='critical_load ('//SOURCE_damage_anisoBrittle_LABEL//')') - if (source_damage_anisoBrittle_N(instance) <= 0.0_pReal) & - call IO_error(211_pInt,el=instance,ext_msg='rate_sensitivity ('//SOURCE_damage_anisoBrittle_LABEL//')') - endif myPhase - enddo sanityChecks + enddo + + end associate + + phase = p + NofMyPhase=count(material_phase==phase) + instance = source_damage_anisoBrittle_instance(phase) + sourceOffset = source_damage_anisoBrittle_offset(phase) + + + call material_allocateSourceState(phase,sourceOffset,NofMyPhase,1_pInt,1_pInt,0_pInt) + sourceState(phase)%p(sourceOffset)%sizePostResults = sum(source_damage_anisoBrittle_sizePostResult(:,instance)) + sourceState(phase)%p(sourceOffset)%aTolState=param(instance)%aTol + + + source_damage_anisoBrittle_Ncleavage(1:size(param(instance)%Ncleavage),instance) = param(instance)%Ncleavage + enddo + - initializeInstances: do phase = 1_pInt, material_Nphase - if (any(phase_source(:,phase) == SOURCE_damage_anisoBrittle_ID)) then - NofMyPhase=count(material_phase==phase) - instance = source_damage_anisoBrittle_instance(phase) - sourceOffset = source_damage_anisoBrittle_offset(phase) - -!-------------------------------------------------------------------------------------------------- -! Determine size of postResults array - outputsLoop: do o = 1_pInt,source_damage_anisoBrittle_Noutput(instance) - select case(source_damage_anisoBrittle_outputID(o,instance)) - case(damage_drivingforce_ID) - mySize = 1_pInt - end select - - if (mySize > 0_pInt) then ! any meaningful output found - source_damage_anisoBrittle_sizePostResult(o,instance) = mySize - source_damage_anisoBrittle_sizePostResults(instance) = source_damage_anisoBrittle_sizePostResults(instance) + mySize - endif - enddo outputsLoop - -!-------------------------------------------------------------------------------------------------- -! Determine size of state array - sizeDotState = 1_pInt - sizeDeltaState = 0_pInt - sizeState = 1_pInt - - sourceState(phase)%p(sourceOffset)%sizeState = sizeState - sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState - sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState - sourceState(phase)%p(sourceOffset)%sizePostResults = source_damage_anisoBrittle_sizePostResults(instance) - allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), & - source=source_damage_anisoBrittle_aTol(instance)) - allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) - - allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 1_pInt)) then - allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) - - endif - - enddo initializeInstances end subroutine source_damage_anisoBrittle_init !-------------------------------------------------------------------------------------------------- !> @brief calculates derived quantities from state !-------------------------------------------------------------------------------------------------- -subroutine source_damage_anisoBrittle_dotState(Tstar_v, ipc, ip, el) +subroutine source_damage_anisoBrittle_dotState(S, ipc, ip, el) + use math, only: & + math_mul33xx33 use material, only: & phaseAt, phasememberAt, & sourceState, & @@ -294,7 +216,7 @@ subroutine source_damage_anisoBrittle_dotState(Tstar_v, ipc, ip, el) damage, & damageMapping use lattice, only: & - lattice_Scleavage_v, & + lattice_Scleavage, & lattice_maxNcleavageFamily, & lattice_NcleavageSystem @@ -303,8 +225,8 @@ subroutine source_damage_anisoBrittle_dotState(Tstar_v, ipc, ip, el) ipc, & !< component-ID of integration point ip, & !< integration point el !< element - real(pReal), intent(in), dimension(6) :: & - Tstar_v !< 2nd Piola Kirchhoff stress tensor (Mandel) + real(pReal), intent(in), dimension(3,3) :: & + S integer(pInt) :: & phase, & constituent, & @@ -312,7 +234,7 @@ subroutine source_damage_anisoBrittle_dotState(Tstar_v, ipc, ip, el) sourceOffset, & damageOffset, & homog, & - f, i, index_myFamily + f, i, index_myFamily, index real(pReal) :: & traction_d, traction_t, traction_n, traction_crit @@ -324,23 +246,26 @@ subroutine source_damage_anisoBrittle_dotState(Tstar_v, ipc, ip, el) damageOffset = damageMapping(homog)%p(ip,el) sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = 0.0_pReal + + index = 1_pInt do f = 1_pInt,lattice_maxNcleavageFamily - index_myFamily = sum(lattice_NcleavageSystem(1:f-1_pInt,phase)) ! at which index starts my family - do i = 1_pInt,source_damage_anisoBrittle_Ncleavage(f,instance) ! process each (active) cleavage system in family - traction_d = dot_product(Tstar_v,lattice_Scleavage_v(1:6,1,index_myFamily+i,phase)) - traction_t = dot_product(Tstar_v,lattice_Scleavage_v(1:6,2,index_myFamily+i,phase)) - traction_n = dot_product(Tstar_v,lattice_Scleavage_v(1:6,3,index_myFamily+i,phase)) + index_myFamily = sum(lattice_NcleavageSystem(1:f-1_pInt,phase)) ! at which index starts my family + do i = 1_pInt,source_damage_anisoBrittle_Ncleavage(f,instance) ! process each (active) cleavage system in family + traction_d = math_mul33xx33(S,lattice_Scleavage(1:3,1:3,1,index_myFamily+i,phase)) + traction_t = math_mul33xx33(S,lattice_Scleavage(1:3,1:3,2,index_myFamily+i,phase)) + traction_n = math_mul33xx33(S,lattice_Scleavage(1:3,1:3,3,index_myFamily+i,phase)) - traction_crit = source_damage_anisoBrittle_critLoad(f,instance)* & + traction_crit = param(instance)%critLoad(index)* & damage(homog)%p(damageOffset)*damage(homog)%p(damageOffset) sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = & sourceState(phase)%p(sourceOffset)%dotState(1,constituent) + & - source_damage_anisoBrittle_sdot_0(instance)* & - ((max(0.0_pReal, abs(traction_d) - traction_crit)/traction_crit)**source_damage_anisoBrittle_N(instance) + & - (max(0.0_pReal, abs(traction_t) - traction_crit)/traction_crit)**source_damage_anisoBrittle_N(instance) + & - (max(0.0_pReal, abs(traction_n) - traction_crit)/traction_crit)**source_damage_anisoBrittle_N(instance))/ & - source_damage_anisoBrittle_critDisp(f,instance) + param(instance)%sdot_0* & + ((max(0.0_pReal, abs(traction_d) - traction_crit)/traction_crit)**param(instance)%N + & + (max(0.0_pReal, abs(traction_t) - traction_crit)/traction_crit)**param(instance)%N + & + (max(0.0_pReal, abs(traction_n) - traction_crit)/traction_crit)**param(instance)%N)/ & + param(instance)%critDisp(index) + index = index + 1_pInt enddo enddo @@ -349,30 +274,26 @@ end subroutine source_damage_anisoBrittle_dotState !-------------------------------------------------------------------------------------------------- !> @brief returns local part of nonlocal damage driving force !-------------------------------------------------------------------------------------------------- -subroutine source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, ipc, ip, el) +subroutine source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) use material, only: & - phaseAt, phasememberAt, & sourceState implicit none integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element + phase, & + constituent real(pReal), intent(in) :: & phi real(pReal), intent(out) :: & localphiDot, & dLocalphiDot_dPhi integer(pInt) :: & - phase, constituent, sourceOffset + sourceOffset - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) sourceOffset = source_damage_anisoBrittle_offset(phase) - localphiDot = 1.0_pReal - & - sourceState(phase)%p(sourceOffset)%state(1,constituent)*phi + localphiDot = 1.0_pReal & + - sourceState(phase)%p(sourceOffset)%state(1,constituent)*phi dLocalphiDot_dPhi = -sourceState(phase)%p(sourceOffset)%state(1,constituent) @@ -381,33 +302,28 @@ end subroutine source_damage_anisobrittle_getRateAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief return array of local damage results !-------------------------------------------------------------------------------------------------- -function source_damage_anisoBrittle_postResults(ipc,ip,el) +function source_damage_anisoBrittle_postResults(phase, constituent) use material, only: & - phaseAt, phasememberAt, & sourceState implicit none - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element - real(pReal), dimension(source_damage_anisoBrittle_sizePostResults( & - source_damage_anisoBrittle_instance(phaseAt(ipc,ip,el)))) :: & + integer(pInt), intent(in) :: & + phase, & + constituent + real(pReal), dimension(sum(source_damage_anisoBrittle_sizePostResult(:, & + source_damage_anisoBrittle_instance(phase)))) :: & source_damage_anisoBrittle_postResults integer(pInt) :: & - instance, phase, constituent, sourceOffset, o, c + instance, sourceOffset, o, c - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) instance = source_damage_anisoBrittle_instance(phase) sourceOffset = source_damage_anisoBrittle_offset(phase) c = 0_pInt - source_damage_anisoBrittle_postResults = 0.0_pReal - do o = 1_pInt,source_damage_anisoBrittle_Noutput(instance) - select case(source_damage_anisoBrittle_outputID(o,instance)) + do o = 1_pInt,size(param(instance)%outputID) + select case(param(instance)%outputID(o)) case (damage_drivingforce_ID) source_damage_anisoBrittle_postResults(c+1_pInt) = & sourceState(phase)%p(sourceOffset)%state(1,constituent) diff --git a/src/source_damage_anisoDuctile.f90 b/src/source_damage_anisoDuctile.f90 index 5978960fb..945688e8a 100644 --- a/src/source_damage_anisoDuctile.f90 +++ b/src/source_damage_anisoDuctile.f90 @@ -12,7 +12,6 @@ module source_damage_anisoDuctile implicit none private integer(pInt), dimension(:), allocatable, public, protected :: & - source_damage_anisoDuctile_sizePostResults, & !< cumulative size of post results source_damage_anisoDuctile_offset, & !< which source is my current damage mechanism? source_damage_anisoDuctile_instance !< instance of damage source mechanism @@ -22,35 +21,31 @@ module source_damage_anisoDuctile character(len=64), dimension(:,:), allocatable, target, public :: & source_damage_anisoDuctile_output !< name of each post result output - integer(pInt), dimension(:), allocatable, target, public :: & - source_damage_anisoDuctile_Noutput !< number of outputs per instance of this damage - - integer(pInt), dimension(:), allocatable, private :: & - source_damage_anisoDuctile_totalNslip !< total number of slip systems integer(pInt), dimension(:,:), allocatable, private :: & source_damage_anisoDuctile_Nslip !< number of slip systems per family - real(pReal), dimension(:), allocatable, private :: & - source_damage_anisoDuctile_aTol - - real(pReal), dimension(:,:), allocatable, private :: & - source_damage_anisoDuctile_critPlasticStrain - - real(pReal), dimension(:), allocatable, private :: & - source_damage_anisoDuctile_sdot_0, & - source_damage_anisoDuctile_N - - real(pReal), dimension(:,:), allocatable, private :: & - source_damage_anisoDuctile_critLoad - enum, bind(c) enumerator :: undefined_ID, & damage_drivingforce_ID end enum - - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - source_damage_anisoDuctile_outputID !< ID of each post result output + + + type, private :: tParameters !< container type for internal constitutive parameters + real(pReal) :: & + aTol, & + N + real(pReal), dimension(:), allocatable :: & + critPlasticStrain + integer(pInt) :: & + totalNslip + integer(pInt), dimension(:), allocatable :: & + Nslip + integer(kind(undefined_ID)), allocatable, dimension(:) :: & + outputID + end type tParameters + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) public :: & @@ -66,30 +61,24 @@ contains !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- -subroutine source_damage_anisoDuctile_init(fileUnit) +subroutine source_damage_anisoDuctile_init #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 use, intrinsic :: iso_fortran_env, only: & compiler_version, & compiler_options #endif + use prec, only: & + pStringLen use debug, only: & debug_level,& debug_constitutive,& debug_levelBasic use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF + IO_error + use math, only: & + math_expand use material, only: & + material_allocateSourceState, & phase_source, & phase_Nsources, & phase_Noutput, & @@ -98,35 +87,35 @@ subroutine source_damage_anisoDuctile_init(fileUnit) material_phase, & sourceState use config, only: & + config_phase, & material_Nphase, & MATERIAL_partPhase - use numerics,only: & - numerics_integrator use lattice, only: & - lattice_maxNslipFamily, & - lattice_NslipSystem - + lattice_maxNslipFamily + implicit none - integer(pInt), intent(in) :: fileUnit - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,mySize=0_pInt,phase,instance,source,sourceOffset,o - integer(pInt) :: sizeState, sizeDotState, sizeDeltaState - integer(pInt) :: NofMyPhase - integer(pInt) :: Nchunks_SlipFamilies = 0_pInt, j - character(len=65536) :: & - tag = '', & - line = '' + integer(pInt) :: Ninstance,phase,instance,source,sourceOffset + integer(pInt) :: NofMyPhase,p ,i - write(6,'(/,a)') ' <<<+- source_'//SOURCE_damage_anisoDuctile_LABEL//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() + integer(pInt), dimension(0), parameter :: emptyIntArray = [integer(pInt)::] + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + integer(kind(undefined_ID)) :: & + outputID + + character(len=pStringLen) :: & + extmsg = '' + character(len=65536), dimension(:), allocatable :: & + outputs + + write(6,'(/,a)') ' <<<+- source_'//SOURCE_DAMAGE_ANISODUCTILE_LABEL//' init -+>>>' #include "compilation_info.f90" - maxNinstance = int(count(phase_source == SOURCE_damage_anisoDuctile_ID),pInt) - if (maxNinstance == 0_pInt) return + Ninstance = int(count(phase_source == SOURCE_damage_anisoDuctile_ID),pInt) + if (Ninstance == 0_pInt) return if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance allocate(source_damage_anisoDuctile_offset(material_Nphase), source=0_pInt) allocate(source_damage_anisoDuctile_instance(material_Nphase), source=0_pInt) @@ -138,151 +127,75 @@ subroutine source_damage_anisoDuctile_init(fileUnit) enddo enddo - allocate(source_damage_anisoDuctile_sizePostResults(maxNinstance), source=0_pInt) - allocate(source_damage_anisoDuctile_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) - allocate(source_damage_anisoDuctile_output(maxval(phase_Noutput),maxNinstance)) + allocate(source_damage_anisoDuctile_sizePostResult(maxval(phase_Noutput),Ninstance),source=0_pInt) + allocate(source_damage_anisoDuctile_output(maxval(phase_Noutput),Ninstance)) source_damage_anisoDuctile_output = '' - allocate(source_damage_anisoDuctile_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) - allocate(source_damage_anisoDuctile_Noutput(maxNinstance), source=0_pInt) - allocate(source_damage_anisoDuctile_critLoad(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) - allocate(source_damage_anisoDuctile_critPlasticStrain(lattice_maxNslipFamily,maxNinstance),source=0.0_pReal) - allocate(source_damage_anisoDuctile_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) - allocate(source_damage_anisoDuctile_totalNslip(maxNinstance), source=0_pInt) - allocate(source_damage_anisoDuctile_N(maxNinstance), source=0.0_pReal) - allocate(source_damage_anisoDuctile_sdot_0(maxNinstance), source=0.0_pReal) - allocate(source_damage_anisoDuctile_aTol(maxNinstance), source=0.0_pReal) - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo + allocate(source_damage_anisoDuctile_Nslip(lattice_maxNslipFamily,Ninstance), source=0_pInt) + + allocate(param(Ninstance)) - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_damage_anisoDuctile_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - instance = source_damage_anisoDuctile_instance(phase) ! which instance of my damage is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('(output)') - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('anisoductile_drivingforce') - source_damage_anisoDuctile_Noutput(instance) = source_damage_anisoDuctile_Noutput(instance) + 1_pInt - source_damage_anisoDuctile_outputID(source_damage_anisoDuctile_Noutput(instance),instance) = damage_drivingforce_ID - source_damage_anisoDuctile_output(source_damage_anisoDuctile_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - end select + do p=1, size(config_phase) + if (all(phase_source(:,p) /= SOURCE_DAMAGE_ANISODUCTILE_ID)) cycle + associate(prm => param(source_damage_anisoDuctile_instance(p)), & + config => config_phase(p)) + + prm%aTol = config%getFloat('anisoductile_atol',defaultVal = 1.0e-3_pReal) - case ('anisoductile_atol') - source_damage_anisoDuctile_aTol(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('nslip') ! - Nchunks_SlipFamilies = chunkPos(1) - 1_pInt - do j = 1_pInt, Nchunks_SlipFamilies - source_damage_anisoDuctile_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) - enddo + prm%N = config%getFloat('anisoductile_ratesensitivity') + + ! sanity checks + if (prm%aTol < 0.0_pReal) extmsg = trim(extmsg)//' anisoductile_atol' + + if (prm%N <= 0.0_pReal) extmsg = trim(extmsg)//' anisoductile_ratesensitivity' + + prm%Nslip = config%getInts('nslip',defaultVal=emptyIntArray) + + prm%critPlasticStrain = config%getFloats('anisoductile_criticalplasticstrain',requiredSize=size(prm%Nslip)) - case ('anisoductile_sdot0') - source_damage_anisoDuctile_sdot_0(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('anisoductile_criticalplasticstrain') - do j = 1_pInt, Nchunks_SlipFamilies - source_damage_anisoDuctile_critPlasticStrain(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo - - case ('anisoductile_ratesensitivity') - source_damage_anisoDuctile_N(instance) = IO_floatValue(line,chunkPos,2_pInt) + ! expand: family => system + prm%critPlasticStrain = math_expand(prm%critPlasticStrain, prm%Nslip) + + if (any(prm%critPlasticStrain < 0.0_pReal)) extmsg = trim(extmsg)//' anisoductile_criticalplasticstrain' + +!-------------------------------------------------------------------------------------------------- +! exit if any parameter is out of range + if (extmsg /= '') & + call IO_error(211_pInt,ext_msg=trim(extmsg)//'('//SOURCE_DAMAGE_ANISODUCTILE_LABEL//')') + +!-------------------------------------------------------------------------------------------------- +! output pararameters + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) + allocate(prm%outputID(0)) + do i=1_pInt, size(outputs) + outputID = undefined_ID + select case(outputs(i)) + + case ('anisoductile_drivingforce') + source_damage_anisoDuctile_sizePostResult(i,source_damage_anisoDuctile_instance(p)) = 1_pInt + source_damage_anisoDuctile_output(i,source_damage_anisoDuctile_instance(p)) = outputs(i) + prm%outputID = [prm%outputID, damage_drivingforce_ID] - case ('anisoductile_criticalload') - do j = 1_pInt, Nchunks_SlipFamilies - source_damage_anisoDuctile_critLoad(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) - enddo - end select - endif; endif - enddo parsingFile -!-------------------------------------------------------------------------------------------------- -! sanity checks - sanityChecks: do phase = 1_pInt, size(phase_source) - myPhase: if (any(phase_source(:,phase) == SOURCE_damage_anisoDuctile_ID)) then - instance = source_damage_anisoDuctile_instance(phase) - source_damage_anisoDuctile_Nslip(1:lattice_maxNslipFamily,instance) = & - min(lattice_NslipSystem(1:lattice_maxNslipFamily,phase),& ! limit active cleavage systems per family to min of available and requested - source_damage_anisoDuctile_Nslip(1:lattice_maxNslipFamily,instance)) - source_damage_anisoDuctile_totalNslip(instance) = sum(source_damage_anisoDuctile_Nslip(:,instance)) - if (source_damage_anisoDuctile_aTol(instance) < 0.0_pReal) & - source_damage_anisoDuctile_aTol(instance) = 1.0e-3_pReal ! default absolute tolerance 1e-3 - if (source_damage_anisoDuctile_sdot_0(instance) <= 0.0_pReal) & - call IO_error(211_pInt,el=instance,ext_msg='sdot_0 ('//SOURCE_damage_anisoDuctile_LABEL//')') - if (any(source_damage_anisoDuctile_critPlasticStrain(:,instance) < 0.0_pReal)) & - call IO_error(211_pInt,el=instance,ext_msg='criticaPlasticStrain ('//SOURCE_damage_anisoDuctile_LABEL//')') - if (source_damage_anisoDuctile_N(instance) <= 0.0_pReal) & - call IO_error(211_pInt,el=instance,ext_msg='rate_sensitivity ('//SOURCE_damage_anisoDuctile_LABEL//')') - endif myPhase - enddo sanityChecks + enddo + + end associate + + phase = p + + NofMyPhase=count(material_phase==phase) + instance = source_damage_anisoDuctile_instance(phase) + sourceOffset = source_damage_anisoDuctile_offset(phase) + + call material_allocateSourceState(phase,sourceOffset,NofMyPhase,1_pInt,1_pInt,0_pInt) + sourceState(phase)%p(sourceOffset)%sizePostResults = sum(source_damage_anisoDuctile_sizePostResult(:,instance)) + sourceState(phase)%p(sourceOffset)%aTolState=param(instance)%aTol + + source_damage_anisoDuctile_Nslip(1:size(param(instance)%Nslip),instance) = param(instance)%Nslip + + enddo - - initializeInstances: do phase = 1_pInt, material_Nphase - if (any(phase_source(:,phase) == SOURCE_damage_anisoDuctile_ID)) then - NofMyPhase=count(material_phase==phase) - instance = source_damage_anisoDuctile_instance(phase) - sourceOffset = source_damage_anisoDuctile_offset(phase) - -!-------------------------------------------------------------------------------------------------- -! Determine size of postResults array - outputsLoop: do o = 1_pInt,source_damage_anisoDuctile_Noutput(instance) - select case(source_damage_anisoDuctile_outputID(o,instance)) - case(damage_drivingforce_ID) - mySize = 1_pInt - end select - - if (mySize > 0_pInt) then ! any meaningful output found - source_damage_anisoDuctile_sizePostResult(o,instance) = mySize - source_damage_anisoDuctile_sizePostResults(instance) = source_damage_anisoDuctile_sizePostResults(instance) + mySize - endif - enddo outputsLoop - -!-------------------------------------------------------------------------------------------------- -! Determine size of state array - sizeDotState = 1_pInt - sizeDeltaState = 0_pInt - sizeState = 1_pInt - sourceState(phase)%p(sourceOffset)%sizeState = sizeState - sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState - sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState - sourceState(phase)%p(sourceOffset)%sizePostResults = source_damage_anisoDuctile_sizePostResults(instance) - allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), & - source=source_damage_anisoDuctile_aTol(instance)) - allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) - - allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 1_pInt)) then - allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) - - endif - - enddo initializeInstances end subroutine source_damage_anisoDuctile_init !-------------------------------------------------------------------------------------------------- @@ -326,8 +239,7 @@ subroutine source_damage_anisoDuctile_dotState(ipc, ip, el) sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = & sourceState(phase)%p(sourceOffset)%dotState(1,constituent) + & plasticState(phase)%slipRate(index,constituent)/ & - ((damage(homog)%p(damageOffset))**source_damage_anisoDuctile_N(instance))/ & - source_damage_anisoDuctile_critPlasticStrain(f,instance) + ((damage(homog)%p(damageOffset))**param(instance)%N)/param(instance)%critPlasticStrain(index) index = index + 1_pInt enddo @@ -338,31 +250,26 @@ end subroutine source_damage_anisoDuctile_dotState !-------------------------------------------------------------------------------------------------- !> @brief returns local part of nonlocal damage driving force !-------------------------------------------------------------------------------------------------- -subroutine source_damage_anisoDuctile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, ipc, ip, el) +subroutine source_damage_anisoDuctile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) use material, only: & - phaseAt, phasememberAt, & sourceState implicit none integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element + phase, & + constituent real(pReal), intent(in) :: & phi real(pReal), intent(out) :: & localphiDot, & dLocalphiDot_dPhi integer(pInt) :: & - phase, constituent, sourceOffset + sourceOffset - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) sourceOffset = source_damage_anisoDuctile_offset(phase) - localphiDot = 1.0_pReal - & - sourceState(phase)%p(sourceOffset)%state(1,constituent)* & - phi + localphiDot = 1.0_pReal & + - sourceState(phase)%p(sourceOffset)%state(1,constituent) * phi dLocalphiDot_dPhi = -sourceState(phase)%p(sourceOffset)%state(1,constituent) @@ -371,33 +278,28 @@ end subroutine source_damage_anisoDuctile_getRateAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief return array of local damage results !-------------------------------------------------------------------------------------------------- -function source_damage_anisoDuctile_postResults(ipc,ip,el) +function source_damage_anisoDuctile_postResults(phase, constituent) use material, only: & - phaseAt, phasememberAt, & sourceState implicit none - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element - real(pReal), dimension(source_damage_anisoDuctile_sizePostResults( & - source_damage_anisoDuctile_instance(phaseAt(ipc,ip,el)))) :: & + integer(pInt), intent(in) :: & + phase, & + constituent + real(pReal), dimension(sum(source_damage_anisoDuctile_sizePostResult(:, & + source_damage_anisoDuctile_instance(phase)))) :: & source_damage_anisoDuctile_postResults integer(pInt) :: & - instance, phase, constituent, sourceOffset, o, c + instance, sourceOffset, o, c - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) instance = source_damage_anisoDuctile_instance(phase) sourceOffset = source_damage_anisoDuctile_offset(phase) c = 0_pInt - source_damage_anisoDuctile_postResults = 0.0_pReal - do o = 1_pInt,source_damage_anisoDuctile_Noutput(instance) - select case(source_damage_anisoDuctile_outputID(o,instance)) + do o = 1_pInt,size(param(instance)%outputID) + select case(param(instance)%outputID(o)) case (damage_drivingforce_ID) source_damage_anisoDuctile_postResults(c+1_pInt) = & sourceState(phase)%p(sourceOffset)%state(1,constituent) diff --git a/src/source_damage_isoBrittle.f90 b/src/source_damage_isoBrittle.f90 index 5aa3648f3..ae0f2a0d2 100644 --- a/src/source_damage_isoBrittle.f90 +++ b/src/source_damage_isoBrittle.f90 @@ -12,7 +12,6 @@ module source_damage_isoBrittle implicit none private integer(pInt), dimension(:), allocatable, public, protected :: & - source_damage_isoBrittle_sizePostResults, & !< cumulative size of post results source_damage_isoBrittle_offset, & !< which source is my current damage mechanism? source_damage_isoBrittle_instance !< instance of damage source mechanism @@ -21,22 +20,23 @@ module source_damage_isoBrittle character(len=64), dimension(:,:), allocatable, target, public :: & source_damage_isoBrittle_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - source_damage_isoBrittle_Noutput !< number of outputs per instance of this damage - - real(pReal), dimension(:), allocatable, private :: & - source_damage_isoBrittle_aTol, & - source_damage_isoBrittle_N, & - source_damage_isoBrittle_critStrainEnergy enum, bind(c) enumerator :: undefined_ID, & damage_drivingforce_ID end enum !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11 ToDo - - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - source_damage_isoBrittle_outputID !< ID of each post result output + + + type, private :: tParameters !< container type for internal constitutive parameters + real(pReal) :: & + critStrainEnergy, & + N, & + aTol + integer(kind(undefined_ID)), allocatable, dimension(:) :: & + outputID + end type tParameters + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) public :: & @@ -52,30 +52,22 @@ contains !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- -subroutine source_damage_isoBrittle_init(fileUnit) +subroutine source_damage_isoBrittle_init #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 use, intrinsic :: iso_fortran_env, only: & compiler_version, & compiler_options #endif + use prec, only: & + pStringLen use debug, only: & debug_level,& debug_constitutive,& debug_levelBasic use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF + IO_error use material, only: & + material_allocateSourceState, & phase_source, & phase_Nsources, & phase_Noutput, & @@ -84,31 +76,31 @@ subroutine source_damage_isoBrittle_init(fileUnit) material_phase, & sourceState use config, only: & + config_phase, & material_Nphase, & MATERIAL_partPhase - use numerics,only: & - numerics_integrator implicit none - integer(pInt), intent(in) :: fileUnit - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,mySize=0_pInt,phase,instance,source,sourceOffset,o - integer(pInt) :: sizeState, sizeDotState, sizeDeltaState - integer(pInt) :: NofMyPhase - character(len=65536) :: & - tag = '', & - line = '' + integer(pInt) :: Ninstance,phase,instance,source,sourceOffset + integer(pInt) :: NofMyPhase,p,i + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + integer(kind(undefined_ID)) :: & + outputID - write(6,'(/,a)') ' <<<+- source_'//SOURCE_damage_isoBrittle_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() + character(len=pStringLen) :: & + extmsg = '' + character(len=65536), dimension(:), allocatable :: & + outputs + + write(6,'(/,a)') ' <<<+- source_'//SOURCE_DAMAGE_ISOBRITTLE_LABEL//' init -+>>>' #include "compilation_info.f90" - maxNinstance = int(count(phase_source == SOURCE_damage_isoBrittle_ID),pInt) - if (maxNinstance == 0_pInt) return + Ninstance = int(count(phase_source == SOURCE_damage_isoBrittle_ID),pInt) + if (Ninstance == 0_pInt) return if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance allocate(source_damage_isoBrittle_offset(material_Nphase), source=0_pInt) allocate(source_damage_isoBrittle_instance(material_Nphase), source=0_pInt) @@ -120,121 +112,64 @@ subroutine source_damage_isoBrittle_init(fileUnit) enddo enddo - allocate(source_damage_isoBrittle_sizePostResults(maxNinstance), source=0_pInt) - allocate(source_damage_isoBrittle_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) - allocate(source_damage_isoBrittle_output(maxval(phase_Noutput),maxNinstance)) + allocate(source_damage_isoBrittle_sizePostResult(maxval(phase_Noutput),Ninstance),source=0_pInt) + allocate(source_damage_isoBrittle_output(maxval(phase_Noutput),Ninstance)) source_damage_isoBrittle_output = '' - allocate(source_damage_isoBrittle_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) - allocate(source_damage_isoBrittle_Noutput(maxNinstance), source=0_pInt) - allocate(source_damage_isoBrittle_critStrainEnergy(maxNinstance), source=0.0_pReal) - allocate(source_damage_isoBrittle_N(maxNinstance), source=1.0_pReal) - allocate(source_damage_isoBrittle_aTol(maxNinstance), source=0.0_pReal) - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) + allocate(param(Ninstance)) + + do p=1, size(config_phase) + if (all(phase_source(:,p) /= SOURCE_DAMAGE_ISOBRITTLE_ID)) cycle + associate(prm => param(source_damage_isoBrittle_instance(p)), & + config => config_phase(p)) + + prm%aTol = config%getFloat('isobrittle_atol',defaultVal = 1.0e-3_pReal) + + prm%N = config%getFloat('isobrittle_n') + prm%critStrainEnergy = config%getFloat('isobrittle_criticalstrainenergy') + + ! sanity checks + if (prm%aTol < 0.0_pReal) extmsg = trim(extmsg)//' isobrittle_atol' + + if (prm%N <= 0.0_pReal) extmsg = trim(extmsg)//' isobrittle_n' + if (prm%critStrainEnergy <= 0.0_pReal) extmsg = trim(extmsg)//' isobrittle_criticalstrainenergy' + +!-------------------------------------------------------------------------------------------------- +! exit if any parameter is out of range + if (extmsg /= '') & + call IO_error(211_pInt,ext_msg=trim(extmsg)//'('//SOURCE_DAMAGE_ISOBRITTLE_LABEL//')') + +!-------------------------------------------------------------------------------------------------- +! output pararameters + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) + allocate(prm%outputID(0)) + do i=1_pInt, size(outputs) + outputID = undefined_ID + select case(outputs(i)) + + case ('isobrittle_drivingforce') + source_damage_isoBrittle_sizePostResult(i,source_damage_isoBrittle_instance(p)) = 1_pInt + source_damage_isoBrittle_output(i,source_damage_isoBrittle_instance(p)) = outputs(i) + prm%outputID = [prm%outputID, damage_drivingforce_ID] + + end select + + enddo + + end associate + + phase = p + + NofMyPhase=count(material_phase==phase) + instance = source_damage_isoBrittle_instance(phase) + sourceOffset = source_damage_isoBrittle_offset(phase) + + call material_allocateSourceState(phase,sourceOffset,NofMyPhase,1_pInt,1_pInt,1_pInt) + sourceState(phase)%p(sourceOffset)%sizePostResults = sum(source_damage_isoBrittle_sizePostResult(:,instance)) + sourceState(phase)%p(sourceOffset)%aTolState=param(instance)%aTol + enddo - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_damage_isoBrittle_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - instance = source_damage_isoBrittle_instance(phase) ! which instance of my damage is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('(output)') - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('isobrittle_drivingforce') - source_damage_isoBrittle_Noutput(instance) = source_damage_isoBrittle_Noutput(instance) + 1_pInt - source_damage_isoBrittle_outputID(source_damage_isoBrittle_Noutput(instance),instance) = damage_drivingforce_ID - source_damage_isoBrittle_output(source_damage_isoBrittle_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - end select - - case ('isobrittle_criticalstrainenergy') - source_damage_isoBrittle_critStrainEnergy(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('isobrittle_n') - source_damage_isoBrittle_N(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('isobrittle_atol') - source_damage_isoBrittle_aTol(instance) = IO_floatValue(line,chunkPos,2_pInt) - - end select - endif; endif - enddo parsingFile - - -!-------------------------------------------------------------------------------------------------- -! sanity checks - sanityChecks: do phase = 1_pInt, material_Nphase - myPhase: if (any(phase_source(:,phase) == SOURCE_damage_isoBrittle_ID)) then - instance = source_damage_isoBrittle_instance(phase) - if (source_damage_isoBrittle_aTol(instance) < 0.0_pReal) & - source_damage_isoBrittle_aTol(instance) = 1.0e-3_pReal ! default absolute tolerance 1e-3 - if (source_damage_isoBrittle_critStrainEnergy(instance) <= 0.0_pReal) & - call IO_error(211_pInt,el=instance,ext_msg='criticalStrainEnergy ('//SOURCE_damage_isoBrittle_LABEL//')') - endif myPhase - enddo sanityChecks - - initializeInstances: do phase = 1_pInt, material_Nphase - if (any(phase_source(:,phase) == SOURCE_damage_isoBrittle_ID)) then - NofMyPhase=count(material_phase==phase) - instance = source_damage_isoBrittle_instance(phase) - sourceOffset = source_damage_isoBrittle_offset(phase) -!-------------------------------------------------------------------------------------------------- -! Determine size of postResults array - outputsLoop: do o = 1_pInt,source_damage_isoBrittle_Noutput(instance) - select case(source_damage_isoBrittle_outputID(o,instance)) - case(damage_drivingforce_ID) - mySize = 1_pInt - end select - - if (mySize > 0_pInt) then ! any meaningful output found - source_damage_isoBrittle_sizePostResult(o,instance) = mySize - source_damage_isoBrittle_sizePostResults(instance) = source_damage_isoBrittle_sizePostResults(instance) + mySize - endif - enddo outputsLoop -! Determine size of state array - sizeDotState = 1_pInt - sizeDeltaState = 1_pInt - sizeState = 1_pInt - - sourceState(phase)%p(sourceOffset)%sizeState = sizeState - sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState - sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState - sourceState(phase)%p(sourceOffset)%sizePostResults = source_damage_isoBrittle_sizePostResults(instance) - allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), & - source=source_damage_isoBrittle_aTol(instance)) - allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) - - allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 1_pInt)) then - allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) - - endif - - enddo initializeInstances end subroutine source_damage_isoBrittle_init !-------------------------------------------------------------------------------------------------- @@ -243,15 +178,11 @@ end subroutine source_damage_isoBrittle_init subroutine source_damage_isoBrittle_deltaState(C, Fe, ipc, ip, el) use material, only: & phaseAt, phasememberAt, & - sourceState, & - material_homog, & - phase_NstiffnessDegradations, & - phase_stiffnessDegradation + sourceState use math, only : & + math_sym33to6, & math_mul33x33, & math_mul66x6, & - math_Mandel33to6, & - math_transpose33, & math_I3 implicit none @@ -264,10 +195,9 @@ subroutine source_damage_isoBrittle_deltaState(C, Fe, ipc, ip, el) real(pReal), intent(in), dimension(6,6) :: & C integer(pInt) :: & - phase, constituent, instance, sourceOffset, mech + phase, constituent, instance, sourceOffset real(pReal) :: & strain(6), & - stiffness(6,6), & strainenergy phase = phaseAt(ipc,ip,el) !< phase ID at ipc,ip,el @@ -276,11 +206,11 @@ subroutine source_damage_isoBrittle_deltaState(C, Fe, ipc, ip, el) instance = source_damage_isoBrittle_instance(phase) !< instance of damage_isoBrittle source sourceOffset = source_damage_isoBrittle_offset(phase) - stiffness = C - strain = 0.5_pReal*math_Mandel33to6(math_mul33x33(math_transpose33(Fe),Fe)-math_I3) + + strain = 0.5_pReal*math_sym33to6(math_mul33x33(transpose(Fe),Fe)-math_I3) - strainenergy = 2.0_pReal*sum(strain*math_mul66x6(stiffness,strain))/ & - source_damage_isoBrittle_critStrainEnergy(instance) + strainenergy = 2.0_pReal*sum(strain*math_mul66x6(C,strain))/param(instance)%critStrainEnergy + if (strainenergy > sourceState(phase)%p(sourceOffset)%subState0(1,constituent)) then sourceState(phase)%p(sourceOffset)%deltaState(1,constituent) = & strainenergy - sourceState(phase)%p(sourceOffset)%state(1,constituent) @@ -295,33 +225,29 @@ end subroutine source_damage_isoBrittle_deltaState !-------------------------------------------------------------------------------------------------- !> @brief returns local part of nonlocal damage driving force !-------------------------------------------------------------------------------------------------- -subroutine source_damage_isoBrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, ipc, ip, el) +subroutine source_damage_isoBrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) use material, only: & - phaseAt, phasememberAt, & sourceState implicit none integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element + phase, & + constituent real(pReal), intent(in) :: & phi real(pReal), intent(out) :: & localphiDot, & dLocalphiDot_dPhi integer(pInt) :: & - phase, constituent, instance, sourceOffset + instance, sourceOffset - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) instance = source_damage_isoBrittle_instance(phase) sourceOffset = source_damage_isoBrittle_offset(phase) - localphiDot = (1.0_pReal - phi)**(source_damage_isoBrittle_N(instance) - 1.0_pReal) - & + localphiDot = (1.0_pReal - phi)**(param(instance)%N - 1.0_pReal) - & phi*sourceState(phase)%p(sourceOffset)%state(1,constituent) - dLocalphiDot_dPhi = - (source_damage_isoBrittle_N(instance) - 1.0_pReal)* & - (1.0_pReal - phi)**max(0.0_pReal,source_damage_isoBrittle_N(instance) - 2.0_pReal) & + dLocalphiDot_dPhi = - (param(instance)%N - 1.0_pReal)* & + (1.0_pReal - phi)**max(0.0_pReal,param(instance)%N - 2.0_pReal) & - sourceState(phase)%p(sourceOffset)%state(1,constituent) end subroutine source_damage_isoBrittle_getRateAndItsTangent @@ -329,33 +255,28 @@ end subroutine source_damage_isoBrittle_getRateAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief return array of local damage results !-------------------------------------------------------------------------------------------------- -function source_damage_isoBrittle_postResults(ipc,ip,el) +function source_damage_isoBrittle_postResults(phase, constituent) use material, only: & - phaseAt, phasememberAt, & sourceState implicit none - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element - real(pReal), dimension(source_damage_isoBrittle_sizePostResults( & - source_damage_isoBrittle_instance(phaseAt(ipc,ip,el)))) :: & + integer(pInt), intent(in) :: & + phase, & + constituent + real(pReal), dimension(sum(source_damage_isoBrittle_sizePostResult(:, & + source_damage_isoBrittle_instance(phase)))) :: & source_damage_isoBrittle_postResults integer(pInt) :: & - instance, phase, constituent, sourceOffset, o, c + instance, sourceOffset, o, c - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) instance = source_damage_isoBrittle_instance(phase) sourceOffset = source_damage_isoBrittle_offset(phase) c = 0_pInt - source_damage_isoBrittle_postResults = 0.0_pReal - do o = 1_pInt,source_damage_isoBrittle_Noutput(instance) - select case(source_damage_isoBrittle_outputID(o,instance)) + do o = 1_pInt,size(param(instance)%outputID) + select case(param(instance)%outputID(o)) case (damage_drivingforce_ID) source_damage_isoBrittle_postResults(c+1_pInt) = sourceState(phase)%p(sourceOffset)%state(1,constituent) c = c + 1 diff --git a/src/source_damage_isoDuctile.f90 b/src/source_damage_isoDuctile.f90 index e843be728..f29d60226 100644 --- a/src/source_damage_isoDuctile.f90 +++ b/src/source_damage_isoDuctile.f90 @@ -12,7 +12,6 @@ module source_damage_isoDuctile implicit none private integer(pInt), dimension(:), allocatable, public, protected :: & - source_damage_isoDuctile_sizePostResults, & !< cumulative size of post results source_damage_isoDuctile_offset, & !< which source is my current damage mechanism? source_damage_isoDuctile_instance !< instance of damage source mechanism @@ -21,22 +20,23 @@ module source_damage_isoDuctile character(len=64), dimension(:,:), allocatable, target, public :: & source_damage_isoDuctile_output !< name of each post result output - - integer(pInt), dimension(:), allocatable, target, public :: & - source_damage_isoDuctile_Noutput !< number of outputs per instance of this damage - real(pReal), dimension(:), allocatable, private :: & - source_damage_isoDuctile_aTol, & - source_damage_isoDuctile_critPlasticStrain, & - source_damage_isoDuctile_N enum, bind(c) enumerator :: undefined_ID, & damage_drivingforce_ID end enum !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11 ToDo - - integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & - source_damage_isoDuctile_outputID !< ID of each post result output + + type, private :: tParameters !< container type for internal constitutive parameters + real(pReal) :: & + critPlasticStrain, & + N, & + aTol + integer(kind(undefined_ID)), allocatable, dimension(:) :: & + outputID + end type tParameters + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) public :: & @@ -52,30 +52,23 @@ contains !> @brief module initialization !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- -subroutine source_damage_isoDuctile_init(fileUnit) +subroutine source_damage_isoDuctile_init #if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 use, intrinsic :: iso_fortran_env, only: & compiler_version, & compiler_options #endif + use prec, only: & + pStringLen use debug, only: & debug_level,& debug_constitutive,& debug_levelBasic use IO, only: & - IO_read, & - IO_lc, & - IO_getTag, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & IO_warning, & - IO_error, & - IO_timeStamp, & - IO_EOF + IO_error use material, only: & + material_allocateSourceState, & phase_source, & phase_Nsources, & phase_Noutput, & @@ -84,32 +77,31 @@ subroutine source_damage_isoDuctile_init(fileUnit) material_phase, & sourceState use config, only: & + config_phase, & material_Nphase, & MATERIAL_partPhase - - use numerics,only: & - numerics_integrator implicit none - integer(pInt), intent(in) :: fileUnit - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: maxNinstance,mySize=0_pInt,phase,instance,source,sourceOffset,o - integer(pInt) :: sizeState, sizeDotState, sizeDeltaState - integer(pInt) :: NofMyPhase - character(len=65536) :: & - tag = '', & - line = '' + integer(pInt) :: Ninstance,phase,instance,source,sourceOffset + integer(pInt) :: NofMyPhase,p,i + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + integer(kind(undefined_ID)) :: & + outputID - write(6,'(/,a)') ' <<<+- source_'//SOURCE_damage_isoDuctile_label//' init -+>>>' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() + character(len=pStringLen) :: & + extmsg = '' + character(len=65536), dimension(:), allocatable :: & + outputs + + write(6,'(/,a)') ' <<<+- source_'//SOURCE_DAMAGE_ISODUCTILE_LABEL//' init -+>>>' #include "compilation_info.f90" - maxNinstance = int(count(phase_source == SOURCE_damage_isoDuctile_ID),pInt) - if (maxNinstance == 0_pInt) return + Ninstance = int(count(phase_source == SOURCE_damage_isoDuctile_ID),pInt) + if (Ninstance == 0_pInt) return if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & - write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance allocate(source_damage_isoDuctile_offset(material_Nphase), source=0_pInt) allocate(source_damage_isoDuctile_instance(material_Nphase), source=0_pInt) @@ -121,121 +113,64 @@ subroutine source_damage_isoDuctile_init(fileUnit) enddo enddo - allocate(source_damage_isoDuctile_sizePostResults(maxNinstance), source=0_pInt) - allocate(source_damage_isoDuctile_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) - allocate(source_damage_isoDuctile_output(maxval(phase_Noutput),maxNinstance)) + allocate(source_damage_isoDuctile_sizePostResult(maxval(phase_Noutput),Ninstance),source=0_pInt) + allocate(source_damage_isoDuctile_output(maxval(phase_Noutput),Ninstance)) source_damage_isoDuctile_output = '' - allocate(source_damage_isoDuctile_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) - allocate(source_damage_isoDuctile_Noutput(maxNinstance), source=0_pInt) - allocate(source_damage_isoDuctile_critPlasticStrain(maxNinstance), source=0.0_pReal) - allocate(source_damage_isoDuctile_N(maxNinstance), source=0.0_pReal) - allocate(source_damage_isoDuctile_aTol(maxNinstance), source=0.0_pReal) - rewind(fileUnit) - phase = 0_pInt - do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to - line = IO_read(fileUnit) - enddo + allocate(param(Ninstance)) - parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part - line = IO_read(fileUnit) - if (IO_isBlank(line)) cycle ! skip empty lines - if (IO_getTag(line,'<','>') /= '') then ! stop at next part - line = IO_read(fileUnit, .true.) ! reset IO_read - exit - endif - if (IO_getTag(line,'[',']') /= '') then ! next phase section - phase = phase + 1_pInt ! advance phase section counter - cycle ! skip to next line - endif - if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_damage_isoDuctile_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran - instance = source_damage_isoDuctile_instance(phase) ! which instance of my damage is present phase - chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key - select case(tag) - case ('(output)') - select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) - case ('isoductile_drivingforce') - source_damage_isoDuctile_Noutput(instance) = source_damage_isoDuctile_Noutput(instance) + 1_pInt - source_damage_isoDuctile_outputID(source_damage_isoDuctile_Noutput(instance),instance) = damage_drivingforce_ID - source_damage_isoDuctile_output(source_damage_isoDuctile_Noutput(instance),instance) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) - end select + do p=1, size(config_phase) + if (all(phase_source(:,p) /= SOURCE_DAMAGE_ISODUCTILE_ID)) cycle + associate(prm => param(source_damage_isoDuctile_instance(p)), & + config => config_phase(p)) + + prm%aTol = config%getFloat('isoductile_atol',defaultVal = 1.0e-3_pReal) - case ('isoductile_criticalplasticstrain') - source_damage_isoDuctile_critPlasticStrain(instance) = IO_floatValue(line,chunkPos,2_pInt) + prm%N = config%getFloat('isoductile_ratesensitivity') + prm%critPlasticStrain = config%getFloat('isoductile_criticalplasticstrain') + + ! sanity checks + if (prm%aTol < 0.0_pReal) extmsg = trim(extmsg)//' isoductile_atol' + + if (prm%N <= 0.0_pReal) extmsg = trim(extmsg)//' isoductile_ratesensitivity' + if (prm%critPlasticStrain <= 0.0_pReal) extmsg = trim(extmsg)//' isoductile_criticalplasticstrain' + +!-------------------------------------------------------------------------------------------------- +! exit if any parameter is out of range + if (extmsg /= '') & + call IO_error(211_pInt,ext_msg=trim(extmsg)//'('//SOURCE_DAMAGE_ISODUCTILE_LABEL//')') - case ('isoductile_ratesensitivity') - source_damage_isoDuctile_N(instance) = IO_floatValue(line,chunkPos,2_pInt) - - case ('isoductile_atol') - source_damage_isoDuctile_aTol(instance) = IO_floatValue(line,chunkPos,2_pInt) +!-------------------------------------------------------------------------------------------------- +! output pararameters + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) + allocate(prm%outputID(0)) + do i=1_pInt, size(outputs) + outputID = undefined_ID + select case(outputs(i)) + + case ('isoductile_drivingforce') + source_damage_isoDuctile_sizePostResult(i,source_damage_isoDuctile_instance(p)) = 1_pInt + source_damage_isoDuctile_output(i,source_damage_isoDuctile_instance(p)) = outputs(i) + prm%outputID = [prm%outputID, damage_drivingforce_ID] end select - endif; endif - enddo parsingFile + enddo -!-------------------------------------------------------------------------------------------------- -! sanity checks - sanityChecks: do phase = 1_pInt, material_Nphase - myPhase: if (any(phase_source(:,phase) == SOURCE_damage_isoDuctile_ID)) then - instance = source_damage_isoDuctile_instance(phase) - if (source_damage_isoDuctile_aTol(instance) < 0.0_pReal) & - source_damage_isoDuctile_aTol(instance) = 1.0e-3_pReal ! default absolute tolerance 1e-3 - if (source_damage_isoDuctile_critPlasticStrain(instance) <= 0.0_pReal) & - call IO_error(211_pInt,el=instance,ext_msg='critical plastic strain ('//SOURCE_damage_isoDuctile_LABEL//')') - endif myPhase - enddo sanityChecks + end associate + + phase = p + NofMyPhase=count(material_phase==phase) + instance = source_damage_isoDuctile_instance(phase) + sourceOffset = source_damage_isoDuctile_offset(phase) - initializeInstances: do phase = 1_pInt, material_Nphase - if (any(phase_source(:,phase) == SOURCE_damage_isoDuctile_ID)) then - NofMyPhase=count(material_phase==phase) - instance = source_damage_isoDuctile_instance(phase) - sourceOffset = source_damage_isoDuctile_offset(phase) -!-------------------------------------------------------------------------------------------------- -! Determine size of postResults array - outputsLoop: do o = 1_pInt,source_damage_isoDuctile_Noutput(instance) - select case(source_damage_isoDuctile_outputID(o,instance)) - case(damage_drivingforce_ID) - mySize = 1_pInt - end select + call material_allocateSourceState(phase,sourceOffset,NofMyPhase,1_pInt,1_pInt,0_pInt) + sourceState(phase)%p(sourceOffset)%sizePostResults = sum(source_damage_isoDuctile_sizePostResult(:,instance)) + sourceState(phase)%p(sourceOffset)%aTolState=param(instance)%aTol + - if (mySize > 0_pInt) then ! any meaningful output found - source_damage_isoDuctile_sizePostResult(o,instance) = mySize - source_damage_isoDuctile_sizePostResults(instance) = source_damage_isoDuctile_sizePostResults(instance) + mySize - endif - enddo outputsLoop -! Determine size of state array - sizeDotState = 1_pInt - sizeDeltaState = 0_pInt - sizeState = 1_pInt - - sourceState(phase)%p(sourceOffset)%sizeState = sizeState - sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState - sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState - sourceState(phase)%p(sourceOffset)%sizePostResults = source_damage_isoDuctile_sizePostResults(instance) - allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), & - source=source_damage_isoDuctile_aTol(instance)) - allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) - - allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 1_pInt)) then - allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) - allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) - endif - if (any(numerics_integrator == 4_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) - if (any(numerics_integrator == 5_pInt)) & - allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) - - endif + enddo - enddo initializeInstances end subroutine source_damage_isoDuctile_init !-------------------------------------------------------------------------------------------------- @@ -267,39 +202,34 @@ subroutine source_damage_isoDuctile_dotState(ipc, ip, el) sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = & sum(plasticState(phase)%slipRate(:,constituent))/ & - ((damage(homog)%p(damageOffset))**source_damage_isoDuctile_N(instance))/ & - source_damage_isoDuctile_critPlasticStrain(instance) + ((damage(homog)%p(damageOffset))**param(instance)%N)/ & + param(instance)%critPlasticStrain end subroutine source_damage_isoDuctile_dotState !-------------------------------------------------------------------------------------------------- !> @brief returns local part of nonlocal damage driving force !-------------------------------------------------------------------------------------------------- -subroutine source_damage_isoDuctile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, ipc, ip, el) +subroutine source_damage_isoDuctile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) use material, only: & - phaseAt, phasememberAt, & sourceState implicit none integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element + phase, & + constituent real(pReal), intent(in) :: & phi real(pReal), intent(out) :: & localphiDot, & dLocalphiDot_dPhi integer(pInt) :: & - phase, constituent, sourceOffset + sourceOffset - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) sourceOffset = source_damage_isoDuctile_offset(phase) - localphiDot = 1.0_pReal - & - sourceState(phase)%p(sourceOffset)%state(1,constituent)* & - phi + localphiDot = 1.0_pReal & + - sourceState(phase)%p(sourceOffset)%state(1,constituent) * phi dLocalphiDot_dPhi = -sourceState(phase)%p(sourceOffset)%state(1,constituent) @@ -308,33 +238,28 @@ end subroutine source_damage_isoDuctile_getRateAndItsTangent !-------------------------------------------------------------------------------------------------- !> @brief return array of local damage results !-------------------------------------------------------------------------------------------------- -function source_damage_isoDuctile_postResults(ipc,ip,el) +function source_damage_isoDuctile_postResults(phase, constituent) use material, only: & - phaseAt, phasememberAt, & sourceState implicit none - integer(pInt), intent(in) :: & - ipc, & !< component-ID of integration point - ip, & !< integration point - el !< element - real(pReal), dimension(source_damage_isoDuctile_sizePostResults( & - source_damage_isoDuctile_instance(phaseAt(ipc,ip,el)))) :: & + integer(pInt), intent(in) :: & + phase, & + constituent + real(pReal), dimension(sum(source_damage_isoDuctile_sizePostResult(:, & + source_damage_isoDuctile_instance(phase)))) :: & source_damage_isoDuctile_postResults integer(pInt) :: & - instance, phase, constituent, sourceOffset, o, c + instance, sourceOffset, o, c - phase = phaseAt(ipc,ip,el) - constituent = phasememberAt(ipc,ip,el) instance = source_damage_isoDuctile_instance(phase) sourceOffset = source_damage_isoDuctile_offset(phase) c = 0_pInt - source_damage_isoDuctile_postResults = 0.0_pReal - do o = 1_pInt,source_damage_isoDuctile_Noutput(instance) - select case(source_damage_isoDuctile_outputID(o,instance)) + do o = 1_pInt,size(param(instance)%outputID) + select case(param(instance)%outputID(o)) case (damage_drivingforce_ID) source_damage_isoDuctile_postResults(c+1_pInt) = sourceState(phase)%p(sourceOffset)%state(1,constituent) c = c + 1 diff --git a/src/system_routines.f90 b/src/system_routines.f90 index bea777a3d..27f0cae34 100644 --- a/src/system_routines.f90 +++ b/src/system_routines.f90 @@ -3,11 +3,17 @@ !> @brief provides wrappers to C routines !-------------------------------------------------------------------------------------------------- module system_routines - + use, intrinsic :: ISO_C_Binding, only: & + C_INT, & + C_CHAR, & + C_NULL_CHAR + implicit none private public :: & + signalusr1_C, & + signalusr2_C, & isDirectory, & getCWD, & getHostName, & @@ -27,7 +33,7 @@ interface use, intrinsic :: ISO_C_Binding, only: & C_INT, & C_CHAR - character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array + character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array integer(C_INT),intent(out) :: stat end subroutine getCurrentWorkDir_C @@ -35,7 +41,7 @@ interface use, intrinsic :: ISO_C_Binding, only: & C_INT, & C_CHAR - character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array + character(kind=C_CHAR), dimension(1024), intent(out) :: str ! C string is an array integer(C_INT),intent(out) :: stat end subroutine getHostName_C @@ -46,31 +52,38 @@ interface integer(C_INT) :: chdir_C character(kind=C_CHAR), dimension(1024), intent(in) :: path ! C string is an array end function chdir_C + + subroutine signalusr1_C(handler) bind(C) + use, intrinsic :: ISO_C_Binding, only: & + C_FUNPTR + type(C_FUNPTR), intent(in), value :: handler + end subroutine signalusr1_C + + subroutine signalusr2_C(handler) bind(C) + use, intrinsic :: ISO_C_Binding, only: & + C_FUNPTR + type(C_FUNPTR), intent(in), value :: handler + end subroutine signalusr2_C end interface - contains !-------------------------------------------------------------------------------------------------- !> @brief figures out if a given path is a directory (and not an ordinary file) !-------------------------------------------------------------------------------------------------- logical function isDirectory(path) - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR, & - C_NULL_CHAR - implicit none - character(len=*), intent(in) :: path - character(kind=C_CHAR), dimension(1024) :: strFixedLength - integer :: i + implicit none + character(len=*), intent(in) :: path + character(kind=C_CHAR), dimension(1024) :: strFixedLength ! C string as array + integer :: i - strFixedLength = repeat(C_NULL_CHAR,len(strFixedLength)) - do i=1,len(path) ! copy array components - strFixedLength(i)=path(i:i) - enddo - isDirectory=merge(.True.,.False.,isDirectory_C(strFixedLength) /= 0_C_INT) + strFixedLength = repeat(C_NULL_CHAR,len(strFixedLength)) + do i=1,len(path) ! copy array components + strFixedLength(i)=path(i:i) + enddo + isDirectory=merge(.True.,.False.,isDirectory_C(strFixedLength) /= 0_C_INT) end function isDirectory @@ -79,29 +92,25 @@ end function isDirectory !> @brief gets the current working directory !-------------------------------------------------------------------------------------------------- character(len=1024) function getCWD() - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR, & - C_NULL_CHAR - implicit none - character(kind=C_CHAR), dimension(1024) :: charArray ! C string is an array - integer(C_INT) :: stat - integer :: i + implicit none + character(kind=C_CHAR), dimension(1024) :: charArray ! C string is an array + integer(C_INT) :: stat + integer :: i - call getCurrentWorkDir_C(charArray,stat) - if (stat /= 0_C_INT) then - getCWD = 'Error occured when getting currend working directory' - else - getCWD = repeat('',len(getCWD)) - arrayToString: do i=1,len(getCWD) - if (charArray(i) /= C_NULL_CHAR) then - getCWD(i:i)=charArray(i) - else - exit - endif - enddo arrayToString - endif + call getCurrentWorkDir_C(charArray,stat) + if (stat /= 0_C_INT) then + getCWD = 'Error occured when getting currend working directory' + else + getCWD = repeat('',len(getCWD)) + arrayToString: do i=1,len(getCWD) + if (charArray(i) /= C_NULL_CHAR) then + getCWD(i:i)=charArray(i) + else + exit + endif + enddo arrayToString + endif end function getCWD @@ -110,51 +119,42 @@ end function getCWD !> @brief gets the current host name !-------------------------------------------------------------------------------------------------- character(len=1024) function getHostName() - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR, & - C_NULL_CHAR + implicit none + character(kind=C_CHAR), dimension(1024) :: charArray ! C string is an array + integer(C_INT) :: stat + integer :: i - implicit none - character(kind=C_CHAR), dimension(1024) :: charArray ! C string is an array - integer(C_INT) :: stat - integer :: i - - call getHostName_C(charArray,stat) - if (stat /= 0_C_INT) then - getHostName = 'Error occured when getting host name' - else - getHostName = repeat('',len(getHostName)) - arrayToString: do i=1,len(getHostName) - if (charArray(i) /= C_NULL_CHAR) then - getHostName(i:i)=charArray(i) - else - exit - endif - enddo arrayToString - endif + call getHostName_C(charArray,stat) + if (stat /= 0_C_INT) then + getHostName = 'Error occured when getting host name' + else + getHostName = repeat('',len(getHostName)) + arrayToString: do i=1,len(getHostName) + if (charArray(i) /= C_NULL_CHAR) then + getHostName(i:i)=charArray(i) + else + exit + endif + enddo arrayToString + endif end function getHostName + !-------------------------------------------------------------------------------------------------- !> @brief changes the current working directory !-------------------------------------------------------------------------------------------------- logical function setCWD(path) - use, intrinsic :: ISO_C_Binding, only: & - C_INT, & - C_CHAR, & - C_NULL_CHAR + implicit none + character(len=*), intent(in) :: path + character(kind=C_CHAR), dimension(1024) :: strFixedLength ! C string is an array + integer :: i - implicit none - character(len=*), intent(in) :: path - character(kind=C_CHAR), dimension(1024) :: strFixedLength ! C string is an array - integer :: i - - strFixedLength = repeat(C_NULL_CHAR,len(strFixedLength)) - do i=1,len(path) ! copy array components - strFixedLength(i)=path(i:i) - enddo - setCWD=merge(.True.,.False.,chdir_C(strFixedLength) /= 0_C_INT) + strFixedLength = repeat(C_NULL_CHAR,len(strFixedLength)) + do i=1,len(path) ! copy array components + strFixedLength(i)=path(i:i) + enddo + setCWD=merge(.True.,.False.,chdir_C(strFixedLength) /= 0_C_INT) end function setCWD