diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index df8991900..6cc082346 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -51,24 +51,24 @@ variables: # ++++++++++++ Compiler ++++++++++++++++++++++++++++++++++++++++++++++ IntelCompiler16_0: "Compiler/Intel/16.0 Libraries/IMKL/2016" IntelCompiler17_0: "Compiler/Intel/17.0 Libraries/IMKL/2017" + IntelCompiler18_1: "Compiler/Intel/18.1 Libraries/IMKL/2018" GNUCompiler5_3: "Compiler/GNU/5.3" # ------------ Defaults ---------------------------------------------- - IntelCompiler: "$IntelCompiler17_0" + IntelCompiler: "$IntelCompiler18_1" GNUCompiler: "$GNUCompiler5_3" # ++++++++++++ MPI +++++++++++++++++++++++++++++++++++++++++++++++++++ MPICH3_2Intel17_0: "MPI/Intel/17.0/MPICH/3.2" - MPICH3_2GNU5_3: "MPI/GNU/5.3/MPICH/3.2" + MPICH3_2Intel18_1: "MPI/Intel/18.1/MPICH/3.2.1" + MPICH3_2GNU5_3: "MPI/GNU/5.3/MPICH/3.2.1" # ------------ Defaults ---------------------------------------------- MPICH_GNU: "$MPICH3_2GNU5_3" - MPICH_Intel: "$MPICH3_2Intel17_0" + MPICH_Intel: "$MPICH3_2Intel18_1" # ++++++++++++ PETSc +++++++++++++++++++++++++++++++++++++++++++++++++ - PETSc3_7_6MPICH3_2Intel17_0: "Libraries/PETSc/3.7.6/Intel-17.0-MPICH-3.2" - PETSc3_7_5MPICH3_2Intel17_0: "Libraries/PETSc/3.7.5/Intel-17.0-MPICH-3.2" - PETSc3_6_4MPICH3_2Intel17_0: "Libraries/PETSc/3.6.4/Intel-17.0-MPICH-3.2" - PETSc3_7_5MPICH3_2GNU5_3: "Libraries/PETSc/3.7.5/GNU-5.3-MPICH-3.2" + PETSc3_9_1MPICH3_2Intel18_1: "Libraries/PETSc/3.9.1/Intel-18.1-MPICH-3.2.1" + PETSc3_9_1MPICH3_2GNU5_3: "Libraries/PETSc/3.9.1/GNU-5.3-MPICH-3.2.1" # ------------ Defaults ---------------------------------------------- - PETSc_MPICH_Intel: "$PETSc3_7_6MPICH3_2Intel17_0" - PETSc_MPICH_GNU: "$PETSc3_7_5MPICH3_2GNU5_3" + PETSc_MPICH_Intel: "$PETSc3_9_1MPICH3_2Intel18_1" + PETSc_MPICH_GNU: "$PETSc3_9_1MPICH3_2GNU5_3" # ++++++++++++ FEM +++++++++++++++++++++++++++++++++++++++++++++++++++ Abaqus2016: "FEM/Abaqus/2016" Abaqus2017: "FEM/Abaqus/2017" @@ -324,6 +324,13 @@ HybridIA: - master - release +TextureComponents: + stage: spectral + script: TextureComponents/test.py + except: + - master + - release + ################################################################################################### Marc_compileIfort2014: stage: compileMarc2014 diff --git a/CMakeLists.txt b/CMakeLists.txt index f5d6546a9..cd33a4b31 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -203,7 +203,9 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") # -fast = -ipo, -O3, -no-prec-div, -static, -fp-model fast=2, and -xHost" endif () - set (STANDARD_CHECK "-stand f08 -standard-semantics") + # -assume std_mod_proc_name (included in -standard-semantics) causes problems if other modules + # (PETSc, HDF5) are not compiled with this option (https://software.intel.com/en-us/forums/intel-fortran-compiler-for-linux-and-mac-os-x/topic/62172) + set (STANDARD_CHECK "-stand f08 -standard-semantics -assume nostd_mod_proc_name") set (LINKER_FLAGS "${LINKER_FLAGS} -shared-intel") # Link against shared Intel libraries instead of static ones @@ -215,13 +217,6 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") set (COMPILE_FLAGS "${COMPILE_FLAGS} -ftz") # flush underflow to zero, automatically set if -O[1,2,3] - set (COMPILE_FLAGS "${COMPILE_FLAGS} -assume") - # assume ... - set (COMPILE_FLAGS "${COMPILE_FLAGS} byterecl") - # ... record length is given in bytes (also set by -standard-semantics) - set (COMPILE_FLAGS "${COMPILE_FLAGS},fpe_summary") - # ... print list of floating point exceptions occured during execution - set (COMPILE_FLAGS "${COMPILE_FLAGS} -diag-disable") # disables warnings ... set (COMPILE_FLAGS "${COMPILE_FLAGS} 5268") diff --git a/DAMASK_env.csh b/DAMASK_env.csh deleted file mode 120000 index e8a0a2c05..000000000 --- a/DAMASK_env.csh +++ /dev/null @@ -1 +0,0 @@ -env/DAMASK.csh \ No newline at end of file diff --git a/DAMASK_env.sh b/DAMASK_env.sh deleted file mode 120000 index 264b07d52..000000000 --- a/DAMASK_env.sh +++ /dev/null @@ -1 +0,0 @@ -env/DAMASK.sh \ No newline at end of file diff --git a/DAMASK_env.zsh b/DAMASK_env.zsh deleted file mode 120000 index cf3a247ef..000000000 --- a/DAMASK_env.zsh +++ /dev/null @@ -1 +0,0 @@ -env/DAMASK.zsh \ No newline at end of file diff --git a/DAMASK_prerequisites.sh b/DAMASK_prerequisites.sh index 3f5e25a71..4877d4b22 100755 --- a/DAMASK_prerequisites.sh +++ b/DAMASK_prerequisites.sh @@ -23,7 +23,7 @@ if which $1 &> /dev/null; then $1 $2 echo -e '\n' else - echo $ does not exist + echo $1 not found fi } diff --git a/PRIVATE b/PRIVATE index 7c69abfc5..cd02f6c1a 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 7c69abfc5bf54c083b9096511abde7d74b806b7f +Subproject commit cd02f6c1a481491eb4517651516b8311348b4777 diff --git a/VERSION b/VERSION index 488dd8695..affc2508b 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.1-1138-gfcac08c +v2.0.2-4-g35ba260 diff --git a/examples/ConfigFiles/numerics.config b/examples/ConfigFiles/numerics.config index ab8903927..3a654513e 100644 --- a/examples/ConfigFiles/numerics.config +++ b/examples/ConfigFiles/numerics.config @@ -67,7 +67,7 @@ maxCutBack 3 # maximum cut back level (0: 1, 1: 0.5, 2 memory_efficient 1 # Precalculate Gamma-operator (81 double per point) update_gamma 0 # Update Gamma-operator with current dPdF (not possible if memory_efficient=1) divergence_correction 2 # Use size-independent divergence criterion -spectralsolver basicPETSc # Type of spectral solver (basicPETSc: basic with PETSc, AL: augmented Lagrange) +spectralsolver basicPETSc # Type of spectral solver (basicPETSc/polarisation) spectralfilter none # Type of filtering method to mitigate Gibb's phenomenon (none, cosine, ...) petsc_options -snes_type ngmres -snes_ngmres_anderson # PetSc solver options regridMode 0 # 0: no regrid; 1: regrid if DAMASK doesn't converge; 2: regrid if DAMASK or BVP Solver doesn't converge diff --git a/examples/SpectralMethod/Polycrystal/orientation.seeds b/examples/SpectralMethod/Polycrystal/orientation.seeds new file mode 100644 index 000000000..bcc091cc8 --- /dev/null +++ b/examples/SpectralMethod/Polycrystal/orientation.seeds @@ -0,0 +1,56 @@ +5 header +seeds_fromRandom v2.0.1-1138-gfcac08c -N 50 -g 128 128 128 +grid a 128 b 128 c 128 +microstructures 50 +randomSeed 3336946323 +1_pos 2_pos 3_pos 1_euler 2_euler 3_euler microstructure +0.54457843603947365 0.84911587396210719 0.34846714169395199 146.18027121829002 137.38970467457548 64.889274068548971 1.0 +0.30082506347847232 0.98313838966599176 0.44557226838658942 277.4997516434205 39.360506400353323 71.246613676352894 2.0 +0.40772634005027159 0.9616152434202665 0.058204060548736787 357.09763745092783 25.490253793203657 268.023521027068 3.0 +0.58904198203278091 0.72270060278093695 0.31942765324679046 350.68488850223423 130.4171465853421 250.42731366202318 4.0 +0.51285660590703486 0.96889097226822973 0.65275467737350745 23.745542919457275 118.98401463018114 322.60963659419878 5.0 +0.78608003485028433 0.83273743685098622 0.46591785719509976 124.52498788960992 100.66865249263579 43.350904777210218 6.0 +0.65676045955005913 0.90612854270261067 0.46812684725311626 206.73481508655914 108.36640892186001 80.109515277983789 7.0 +0.41091744799856139 0.019203430085754657 0.87577849258950335 294.38492822136715 146.40525644850072 307.47368257125362 8.0 +0.2895339668620191 0.44890615451191845 0.98331278676555256 155.95129760119522 47.149690499466338 129.03566717283138 9.0 +0.19961281156351873 0.52634383062850942 0.65188451822931848 147.12314868626314 111.70076966247582 118.18572187802707 10.0 +0.86414247862963223 0.1358065510164656 0.66025345324864337 164.3847245485006 106.948282223783 169.81246394416348 11.0 +0.22971651291623074 0.092972318577821886 0.29406405983067813 152.69170803150587 154.25570085621541 12.482717398044327 12.0 +0.26338815658881415 0.34338560362947429 0.55845211616339796 34.576603888911734 112.1396081205236 231.97898012368159 13.0 +0.75109304237913643 0.32426372309630619 0.24464858180476037 287.27773986438422 132.7748719439447 29.566044111233396 14.0 +0.011464166371603362 0.038504815611266896 0.31848008962612995 3.6027692030412783 128.19004192002171 318.21386202740894 15.0 +0.40531294455896061 0.89392258706810201 0.47360685251709117 224.94453046189483 91.073774858498993 174.6238603309032 16.0 +0.53642882463725594 0.12961813440684475 0.33670742966203715 275.10050328051165 143.71902154901966 46.372591362351443 17.0 +0.025264257063423813 0.86284946730733791 0.67853751997904233 286.09297442950589 84.366012495567063 168.12310601585438 18.0 +0.46082042086486502 0.79920741984567956 0.84550103531963372 338.58981410067844 115.61172937509538 33.588172611417498 19.0 +0.22570807057805362 0.074166418124772107 0.35703686595525042 123.22376691705952 84.092264279947017 358.5702863996658 20.0 +0.05386086781200651 0.33174190751238741 0.22207351758975458 347.73707141532731 68.522081814108546 343.42676588519805 21.0 +0.843158604433492 0.92955496315098074 0.64647123931005734 11.343815482295781 80.300931773797004 9.6393328996438079 22.0 +0.38975306778625629 0.24157610260940071 0.71161594028191588 321.39703457206355 30.680985581522023 310.97284763119887 23.0 +0.29080297238998321 0.7438587097696947 0.27827316089105131 318.66484094014749 129.93793511237541 136.82657482859585 24.0 +0.39382389364070247 0.28978401907200979 0.25701142568390795 322.47065731551987 13.846167927307052 301.54027053054892 25.0 +0.61050322346481545 0.13737535992809438 0.36661645869662263 352.54143971537871 57.8511858353625 133.84653788992898 26.0 +0.79736663927764695 0.20513299822009629 0.79699332479250651 290.58637400802854 44.449209602954802 275.77563923277597 27.0 +0.75235587126626513 0.11041486201059918 0.8131872750127791 70.389885527768058 106.61781772242031 249.0896396040977 28.0 +0.47139010668774128 0.12192484253468709 0.21955576044612418 82.523861430871293 130.07642048077489 161.94830004765717 29.0 +0.58577411200822327 0.55808726366080907 0.68861538513192688 4.5456602316904782 68.430488072013802 279.06105056042912 30.0 +0.078221348390348527 0.38485150106633381 0.70002412594863284 44.840105036355524 52.915732353957182 321.10892793267385 31.0 +0.67648574989589816 0.36189363050547918 0.1744438641736718 56.290857666353922 79.852422734452261 218.87802771695559 32.0 +0.66993786328789628 0.24839196429109262 0.22913111586511459 90.545592617209479 111.73679898243722 50.777738624812869 33.0 +0.97253038612350284 0.5008359837170796 0.22908814679929382 258.2784447839781 81.324197699117292 308.75839223966972 34.0 +0.57267221923324418 0.57812183688041852 0.27747089968489891 44.241276881211661 104.39672542923724 263.41942696808212 35.0 +0.20684173793886379 0.43993013267805814 0.65735383309297513 343.60408990114365 51.644327943351122 302.98734797140071 36.0 +0.74510273339709676 0.73117975286639059 0.88155543772031653 318.38483613589898 93.903589849536274 302.06468871599935 37.0 +0.96140945332061889 0.16540946028864878 0.40824265860818898 97.086714635901274 130.50888029759304 221.78895191070089 38.0 +0.76663076605317781 0.85911002545479809 0.11281299879667539 163.06393615448818 43.363447677950042 338.05013375241901 39.0 +0.41268673658765898 0.24787882796675886 0.57686480644197569 200.12920794363012 45.222523931505947 280.23271113977307 40.0 +0.77256877568016891 0.88174830744168597 0.85149237688892054 116.81358850313981 71.413890894473454 115.54962789790765 41.0 +0.26725724981852333 0.2962688497890511 0.89524301333622525 254.14781916777747 83.176346219908254 33.979304092964192 42.0 +0.58047025880020098 0.57494408407976194 0.61595960318628096 334.70268656247265 42.480438737564974 177.92796756121371 43.0 +0.52102440567302477 0.7145666401672387 0.21858506378351775 178.43052543384653 153.21174542887405 324.42119289220273 44.0 +0.77321583279723483 0.96647383074249249 0.5062943967878929 230.42797261926012 99.507340620849902 169.75007570059978 45.0 +0.3364367026326 0.45790436703027437 0.27197669375839439 218.70321774431869 60.819721511735267 217.80859716828817 46.0 +0.41823530342173082 0.077759964416919514 0.66113722050248613 189.26108507623661 50.425749120256064 78.019878648192815 47.0 +0.8754300454839713 0.094969845269609401 0.42632522145904467 250.899467172654 33.14582034295529 150.05888748377424 48.0 +0.1950290416819265 0.59474264558516909 0.93298429220138601 232.236367110732 47.258083025548189 34.83912199551915 49.0 +0.91993054481220637 0.48586729788450678 0.10933899155043697 246.05124283375034 131.539860458254 249.58739755697601 50.0 diff --git a/installation/mods_Abaqus/abaqus_v6.env b/installation/mods_Abaqus/abaqus_v6.env index 8d040cb23..b4710e198 100644 --- a/installation/mods_Abaqus/abaqus_v6.env +++ b/installation/mods_Abaqus/abaqus_v6.env @@ -16,24 +16,26 @@ from damask import version as DAMASKVERSION # Use the version in $PATH fortCmd = "ifort" -# -free to use free-format FORTRAN 90 syntax -# -O <0-3> optimization level -# -fpp use FORTRAN preprocessor on source code -# -openmp build with openMP support -# -w90 -w95 suppress messages about use of non-standard Fortran (previous version of abaqus_v6.env only) -# -WB turn a compile-time bounds check into a warning (previous version of abaqus_v6.env only) -# -mP2OPT_hpo_vec_divbyzero=F inofficial compiler switch, proposed by abaqus but highly dubios (previous version of abaqus_v6.env only) -# -ftz flush underflow to zero -# -diag-disable 5268 disable warnings about line length > 132 (only comments there anyway) -# -implicitnone assume no implicit types (e.g. i for integer) -# -assume byterecl count record length in bytes -# -real-size 64 -DFLOAT=8 assume size of real to be 8 bytes, matches our definition of pReal -# -integer-size 32 -DINT=4 assume size of integer to be 4 bytes, matches our definition of pInt +# -free to use free-format FORTRAN 90 syntax +# -O <0-3> optimization level +# -fpp use FORTRAN preprocessor on source code +# -openmp build with openMP support +# -w90 -w95 suppress messages about use of non-standard Fortran (previous version of abaqus_v6.env only) +# -WB turn a compile-time bounds check into a warning (previous version of abaqus_v6.env only) +# -mP2OPT_hpo_vec_divbyzero=F inofficial compiler switch, proposed by abaqus but highly dubios (previous version of abaqus_v6.env only) +# -ftz flush underflow to zero +# -diag-disable 5268 disable warnings about line length > 132 (only comments there anyway) +# -implicitnone assume no implicit types (e.g. i for integer) +# -standard-semantics sets standard (Fortran 2008) and some other conventions +# -assume nostd_mod_proc_name avoid problems with libraries compiled without that option +# -real-size 64 -DFLOAT=8 assume size of real to be 8 bytes, matches our definition of pReal +# -integer-size 32 -DINT=4 assume size of integer to be 4 bytes, matches our definition of pInt compile_fortran = (fortCmd + " -c -fPIC -auto -shared-intel " + "-I%I -free -O1 -fpp -openmp " + "-ftz -diag-disable 5268 " + - "-implicitnone -assume byterecl -stand f08 -standard-semantics " + + "-implicitnone -standard-semantics " + + "-assume nostd_mod_proc_name " + "-real-size 64 -integer-size 32 -DFLOAT=8 -DINT=4 " + '-DDAMASKVERSION=\\\"%s\\\"'%DAMASKVERSION) diff --git a/installation/mods_Abaqus/abaqus_v6_serial.env b/installation/mods_Abaqus/abaqus_v6_serial.env index 8e4d8e367..c608b6993 100644 --- a/installation/mods_Abaqus/abaqus_v6_serial.env +++ b/installation/mods_Abaqus/abaqus_v6_serial.env @@ -16,24 +16,25 @@ from damask import version as DAMASKVERSION # Use the version in $PATH fortCmd = "ifort" -# -free to use free-format FORTRAN 90 syntax -# -O <0-3> optimization level -# -fpp use FORTRAN preprocessor on source code -# -openmp build with openMP support -# -w90 -w95 suppress messages about use of non-standard Fortran (previous version of abaqus_v6.env only) -# -WB turn a compile-time bounds check into a warning (previous version of abaqus_v6.env only) -# -mP2OPT_hpo_vec_divbyzero=F inofficial compiler switch, proposed by abaqus but highly dubios (previous version of abaqus_v6.env only) -# -ftz flush underflow to zero -# -diag-disable 5268 disable warnings about line length > 132 (only comments there anyway) -# -implicitnone assume no implicit types (e.g. i for integer) -# -assume byterecl count record length in bytes -# -real-size 64 -DFLOAT=8 assume size of real to be 8 bytes, matches our definition of pReal -# -integer-size 32 -DINT=4 assume size of integer to be 4 bytes, matches our definition of pInt +# -free to use free-format FORTRAN 90 syntax +# -O <0-3> optimization level +# -fpp use FORTRAN preprocessor on source code +# -w90 -w95 suppress messages about use of non-standard Fortran (previous version of abaqus_v6.env only) +# -WB turn a compile-time bounds check into a warning (previous version of abaqus_v6.env only) +# -mP2OPT_hpo_vec_divbyzero=F inofficial compiler switch, proposed by abaqus but highly dubios (previous version of abaqus_v6.env only) +# -ftz flush underflow to zero +# -diag-disable 5268 disable warnings about line length > 132 (only comments there anyway) +# -implicitnone assume no implicit types (e.g. i for integer) +# -standard-semantics sets standard (Fortran 2008) and some other conventions +# -assume nostd_mod_proc_name avoid problems with libraries compiled without that option +# -real-size 64 -DFLOAT=8 assume size of real to be 8 bytes, matches our definition of pReal +# -integer-size 32 -DINT=4 assume size of integer to be 4 bytes, matches our definition of pInt compile_fortran = (fortCmd + " -c -fPIC -auto -shared-intel " + "-I%I -free -O1 -fpp " + "-ftz -diag-disable 5268 " + - "-implicitnone -assume byterecl -stand f08 -standard-semantics " + + "-implicitnone -standard-semantics " + + "-assume nostd_mod_proc_name " + "-real-size 64 -integer-size 32 -DFLOAT=8 -DINT=4 " + '-DDAMASKVERSION=\\\"%s\\\"'%DAMASKVERSION) diff --git a/installation/mods_MarcMentat/2014.2/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2014.2/Marc_tools/include_linux64 index ba9258f1e..5ea0df864 100644 --- a/installation/mods_MarcMentat/2014.2/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2014.2/Marc_tools/include_linux64 @@ -416,7 +416,7 @@ then PROFILE=" $PROFILE -pg" fi -FORT_OPT="-c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr -mp1 -WB" +FORT_OPT="-c -implicitnone -stand f08 -standard-semantics -assume nostd_std_mod_proc_name -safe_cray_ptr -mp1 -WB" if test "$MTHREAD" = "OPENMP" then FORT_OPT=" $FORT_OPT -openmp" @@ -458,21 +458,21 @@ DAMASKVERSION="'"$DAMASKVERSION"'" DFORTLOW="$FCOMP $FORT_OPT $PROFILE -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTLOWMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_std_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTRAN="$FCOMP $FORT_OPT $PROFILE -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTRANMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_std_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTHIGH="$FCOMP $FORT_OPT $PROFILE -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTHIGHMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_std_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" @@ -492,21 +492,21 @@ then DFORTLOW="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTLOWMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_std_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2.2 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTRAN="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTRANMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_std_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTHIGH="$FCOMP $FORT_OPT $PROFILE -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTHIGHMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_std_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014.2 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" diff --git a/installation/mods_MarcMentat/2014/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2014/Marc_tools/include_linux64 index b7e6bb140..e67f8158e 100644 --- a/installation/mods_MarcMentat/2014/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2014/Marc_tools/include_linux64 @@ -410,7 +410,7 @@ then PROFILE="-prof-gen=srcpos" fi -FORT_OPT="-c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr -mp1 -WB" +FORT_OPT="-c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr -mp1 -WB" if test "$MTHREAD" = "OPENMP" then FORT_OPT=" $FORT_OPT -openmp" @@ -452,21 +452,21 @@ DAMASKVERSION="'"$DAMASKVERSION"'" DFORTLOW="$FCOMP $FORT_OPT $PROFILE -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTLOWMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTRAN="$FCOMP $FORT_OPT $PROFILE -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTRANMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTHIGH="$FCOMP $FORT_OPT $PROFILE -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTHIGHMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" @@ -486,21 +486,21 @@ then DFORTLOW="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTLOWMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTRAN="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTRANMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTHIGH="$FCOMP $FORT_OPT $PROFILE -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTHIGHMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2014 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" diff --git a/installation/mods_MarcMentat/2015/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2015/Marc_tools/include_linux64 index 0a315f85b..2f1abe6ba 100644 --- a/installation/mods_MarcMentat/2015/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2015/Marc_tools/include_linux64 @@ -419,7 +419,7 @@ then PROFILE=" $PROFILE -pg" fi -FORT_OPT="-c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr -mp1 -WB" +FORT_OPT="-c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr -mp1 -WB" if test "$MTHREAD" = "OPENMP" then FORT_OPT=" $FORT_OPT -openmp" @@ -454,21 +454,21 @@ fi DFORTLOW="$FCOMP $FORT_OPT $PROFILE -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTLOWMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTRAN="$FCOMP $FORT_OPT $PROFILE -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTRANMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTHIGH="$FCOMP $FORT_OPT $PROFILE -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTHIGHMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" @@ -488,21 +488,21 @@ then DFORTLOW="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTLOWMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTRAN="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTRANMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTHIGH="$FCOMP $FORT_OPT $PROFILE -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTHIGHMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2015 -DDAMASKVERSION=$DAMASKVERSION \ -openmp -openmp_report2 -openmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" diff --git a/installation/mods_MarcMentat/2016/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2016/Marc_tools/include_linux64 index a6cc7e2f9..767226bac 100644 --- a/installation/mods_MarcMentat/2016/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2016/Marc_tools/include_linux64 @@ -449,7 +449,7 @@ then PROFILE=" $PROFILE -pg" fi -FORT_OPT="-c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr -mp1 -WB -fp-model source" +FORT_OPT="-c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr -mp1 -WB -fp-model source" if test "$MTHREAD" = "OPENMP" then FORT_OPT=" $FORT_OPT -qopenmp" @@ -484,21 +484,21 @@ fi DFORTLOW="$FCOMP $FORT_OPT $PROFILE -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTLOWMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTRAN="$FCOMP $FORT_OPT $PROFILE -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTRANMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTHIGH="$FCOMP $FORT_OPT $PROFILE -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" -DFORTHIGHMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" @@ -518,21 +518,21 @@ then DFORTLOW="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTLOWMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTRAN="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTRANMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" DFORTHIGH="$FCOMP $FORT_OPT $PROFILE -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" - DFORTHIGHMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS" diff --git a/installation/mods_MarcMentat/2017/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2017/Marc_tools/include_linux64 index e42191a14..d2ab3f77f 100644 --- a/installation/mods_MarcMentat/2017/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2017/Marc_tools/include_linux64 @@ -457,7 +457,7 @@ then PROFILE=" $PROFILE -pg" fi -FORT_OPT="-c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr -mp1 -WB -fp-model source" +FORT_OPT="-c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr -mp1 -WB -fp-model source" if test "$MTHREAD" = "OPENMP" then FORT_OPT=" $FORT_OPT -qopenmp" @@ -494,21 +494,21 @@ fi DFORTLOW="$FCOMP $FORT_OPT $PROFILE -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" -DFORTLOWMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" DFORTRAN="$FCOMP $FORT_OPT $PROFILE -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" -DFORTRANMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O1 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" DFORTHIGH="$FCOMP $FORT_OPT $PROFILE -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" -DFORTHIGHMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ +DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias -O2 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" @@ -528,21 +528,21 @@ then DFORTLOW="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" - DFORTLOWMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" DFORTRAN="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" - DFORTRANMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTRANMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" DFORTHIGH="$FCOMP $FORT_OPT $PROFILE -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-enable sc3 -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" - DFORTHIGHMP="$FCOMP -c -assume byterecl -stand f08 -standard-semantics -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ + DFORTHIGHMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -fno-alias $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2016 -DDAMASKVERSION=$DAMASKVERSION \ -qopenmp -qopenmp-threadprivate=compat\ -I$MARC_SOURCE/${BCS_DIR}/common -I$MARC_SOURCE/mumpssolver/include $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD" diff --git a/installation/mods_MarcMentat/installation.txt b/installation/mods_MarcMentat/installation.txt index d463387af..ae1bca772 100644 --- a/installation/mods_MarcMentat/installation.txt +++ b/installation/mods_MarcMentat/installation.txt @@ -16,7 +16,7 @@ The Intel Fortran compiler needs to be installed. APPENDIX: -The structure of this directory should be (VERSION = 2010.2 or 2011 or 2012 or 2013 or 2014): +The structure of this directory should be (VERSION = 20XX or 20XX.Y) ./installation.txt this text ./apply_MPIE_modifications script file to apply modifications to the installation diff --git a/lib/damask/util.py b/lib/damask/util.py old mode 100755 new mode 100644 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index eade66e17..9789ec67d 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -74,6 +74,7 @@ add_library (PLASTIC OBJECT "plastic_disloUCLA.f90" "plastic_isotropic.f90" "plastic_phenopowerlaw.f90" + "plastic_kinematichardening.f90" "plastic_nonlocal.f90" "plastic_none.f90") add_dependencies(PLASTIC DAMASK_HELPERS) @@ -165,7 +166,6 @@ if ("${PROJECT_NAME}" STREQUAL "DAMASK_spectral") add_library(SPECTRAL_SOLVER OBJECT "spectral_thermal.f90" "spectral_damage.f90" - "spectral_mech_AL.f90" "spectral_mech_Polarisation.f90" "spectral_mech_Basic.f90") add_dependencies(SPECTRAL_SOLVER SPECTRAL_UTILITIES) diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index 44e7e5693..66aa11433 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -162,6 +162,7 @@ subroutine CPFEM_init write(6,'(/,a)') ' <<<+- CPFEM init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" + flush(6) endif mainProcess ! initialize stress and jacobian to zero @@ -242,8 +243,8 @@ subroutine CPFEM_init write(6,'(a32,1x,6(i8,1x))') 'CPFEM_dcsdE: ', shape(CPFEM_dcsdE) write(6,'(a32,1x,6(i8,1x),/)') 'CPFEM_dcsdE_knownGood: ', shape(CPFEM_dcsdE_knownGood) write(6,'(a32,l1)') 'symmetricSolver: ', symmetricSolver + flush(6) endif - flush(6) end subroutine CPFEM_init diff --git a/src/C_routines.c b/src/C_routines.c index 5bc09745f..e3891765a 100644 --- a/src/C_routines.c +++ b/src/C_routines.c @@ -11,9 +11,9 @@ int isdirectory_c(const char *dir){ struct stat statbuf; - if(stat(dir, &statbuf) != 0) - return 0; - return S_ISDIR(statbuf.st_mode); + if(stat(dir, &statbuf) != 0) /* error */ + return 0; /* return "NO, this is not a directory" */ + return S_ISDIR(statbuf.st_mode); /* 1 => is directory, 0 => this is NOT a directory */ } @@ -29,7 +29,7 @@ void getcurrentworkdir_c(char cwd[], int *stat ){ } -void gethostname_c(char hostname[], int *stat ){ +void gethostname_c(char hostname[], int *stat){ char hostname_tmp[1024]; if(gethostname(hostname_tmp, sizeof(hostname_tmp)) == 0){ strcpy(hostname,hostname_tmp); @@ -39,3 +39,8 @@ void gethostname_c(char hostname[], int *stat ){ *stat = 1; } } + + +int chdir_c(const char *dir){ + return chdir(dir); +} diff --git a/src/DAMASK_spectral.f90 b/src/DAMASK_spectral.f90 index 5bb882e2d..f340b683d 100644 --- a/src/DAMASK_spectral.f90 +++ b/src/DAMASK_spectral.f90 @@ -12,6 +12,8 @@ program DAMASK_spectral compiler_version, & compiler_options #endif +#include + use PETScsys use prec, only: & pInt, & pLongInt, & @@ -70,7 +72,6 @@ program DAMASK_spectral DAMAGE_nonlocal_ID use spectral_utilities, only: & utilities_init, & - utilities_destroy, & tSolutionState, & tLoadCase, & cutBack, & @@ -80,16 +81,12 @@ program DAMASK_spectral FIELD_THERMAL_ID, & FIELD_DAMAGE_ID use spectral_mech_Basic - use spectral_mech_AL use spectral_mech_Polarisation use spectral_damage use spectral_thermal - implicit none -#include - !-------------------------------------------------------------------------------------------------- ! variables related to information from load case and geom file real(pReal), dimension(9) :: temp_valueVector = 0.0_pReal !< temporarily from loadcase file when reading in tensors (initialize to 0.0) @@ -144,24 +141,17 @@ program DAMASK_spectral integer(pInt), parameter :: maxByteOut = 2147483647-4096 !< limit of one file output write https://trac.mpich.org/projects/mpich/ticket/1742 integer(pInt), parameter :: maxRealOut = maxByteOut/pReal integer(pLongInt), dimension(2) :: outputIndex - PetscErrorCode :: ierr + integer :: ierr + external :: & - quit, & - MPI_file_open, & - MPI_file_close, & - MPI_file_seek, & - MPI_file_get_position, & - MPI_file_write, & - MPI_abort, & - MPI_finalize, & - MPI_allreduce, & - PETScFinalize + quit + !-------------------------------------------------------------------------------------------------- ! init DAMASK (all modules) call CPFEM_initAll(el = 1_pInt, ip = 1_pInt) write(6,'(/,a)') ' <<<+- DAMASK_spectral init -+>>>' - write(6,'(/,a)') ' Roters et al., Computational Materials Science, 2018' + write(6,'(/,a,/)') ' Roters et al., Computational Materials Science, 2018' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" @@ -367,11 +357,7 @@ program DAMASK_spectral select case (spectral_solver) case (DAMASK_spectral_SolverBasicPETSc_label) call basicPETSc_init - case (DAMASK_spectral_SolverAL_label) - if(iand(debug_level(debug_spectral),debug_levelBasic)/= 0) & - call IO_warning(42_pInt, ext_msg='debug Divergence') - call AL_init - + case (DAMASK_spectral_SolverPolarisation_label) if(iand(debug_level(debug_spectral),debug_levelBasic)/= 0) & call IO_warning(42_pInt, ext_msg='debug Divergence') @@ -447,10 +433,9 @@ program DAMASK_spectral do i = 1, size(materialpoint_results,3)/(maxByteOut/(materialpoint_sizeResults*pReal))+1 ! slice the output of my process in chunks not exceeding the limit for one output outputIndex = int([(i-1_pInt)*((maxRealOut)/materialpoint_sizeResults)+1_pInt, & ! QUESTION: why not starting i at 0 instead of murky 1? min(i*((maxRealOut)/materialpoint_sizeResults),size(materialpoint_results,3))],pLongInt) - call MPI_file_write(resUnit, & - reshape(materialpoint_results(:,:,outputIndex(1):outputIndex(2)), & - [(outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)]), & - (outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt), & + call MPI_file_write(resUnit,reshape(materialpoint_results(:,:,outputIndex(1):outputIndex(2)), & + [(outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)]), & + int((outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)), & MPI_DOUBLE, MPI_STATUS_IGNORE, ierr) if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_file_write') enddo @@ -534,12 +519,7 @@ program DAMASK_spectral deformation_BC = loadCases(currentLoadCase)%deformation, & stress_BC = loadCases(currentLoadCase)%stress, & rotation_BC = loadCases(currentLoadCase)%rotation) - case (DAMASK_spectral_SolverAL_label) - call AL_forward (& - guess,timeinc,timeIncOld,remainingLoadCaseTime, & - deformation_BC = loadCases(currentLoadCase)%deformation, & - stress_BC = loadCases(currentLoadCase)%stress, & - rotation_BC = loadCases(currentLoadCase)%rotation) + case (DAMASK_spectral_SolverPolarisation_label) call Polarisation_forward (& guess,timeinc,timeIncOld,remainingLoadCaseTime, & @@ -568,12 +548,6 @@ program DAMASK_spectral stress_BC = loadCases(currentLoadCase)%stress, & rotation_BC = loadCases(currentLoadCase)%rotation) - case (DAMASK_spectral_SolverAL_label) - solres(field) = AL_solution (& - incInfo,timeinc,timeIncOld, & - stress_BC = loadCases(currentLoadCase)%stress, & - rotation_BC = loadCases(currentLoadCase)%rotation) - case (DAMASK_spectral_SolverPolarisation_label) solres(field) = Polarisation_solution (& incInfo,timeinc,timeIncOld, & @@ -650,8 +624,8 @@ program DAMASK_spectral outputIndex=int([(i-1_pInt)*((maxRealOut)/materialpoint_sizeResults)+1_pInt, & min(i*((maxRealOut)/materialpoint_sizeResults),size(materialpoint_results,3))],pLongInt) call MPI_file_write(resUnit,reshape(materialpoint_results(:,:,outputIndex(1):outputIndex(2)),& - [(outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)]), & - (outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt),& + [(outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)]), & + int((outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)),& MPI_DOUBLE, MPI_STATUS_IGNORE, ierr) if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='MPI_file_write') enddo @@ -698,24 +672,12 @@ end program DAMASK_spectral !> stderr. Exit code 3 signals no severe problems, but some increments did not converge !-------------------------------------------------------------------------------------------------- subroutine quit(stop_id) +#include + use MPI use prec, only: & pInt - use spectral_mech_Basic, only: & - BasicPETSC_destroy - use spectral_mech_AL, only: & - AL_destroy - use spectral_mech_Polarisation, only: & - Polarisation_destroy - use spectral_damage, only: & - spectral_damage_destroy - use spectral_thermal, only: & - spectral_thermal_destroy - use spectral_utilities, only: & - utilities_destroy - - implicit none -#include + implicit none integer(pInt), intent(in) :: stop_id integer, dimension(8) :: dateAndTime ! type default integer integer(pInt) :: error = 0_pInt @@ -723,15 +685,7 @@ subroutine quit(stop_id) logical :: ErrorInQuit external :: & - PETScFinalize, & - MPI_finalize - - call BasicPETSC_destroy() - call AL_destroy() - call Polarisation_destroy() - call spectral_damage_destroy() - call spectral_thermal_destroy() - call utilities_destroy() + PETScFinalize call PETScFinalize(ierr) if (ierr /= 0) write(6,'(a)') ' Error in PETScFinalize' diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 51848ece5..f57f03467 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -28,6 +28,7 @@ #include "plastic_none.f90" #include "plastic_isotropic.f90" #include "plastic_phenopowerlaw.f90" +#include "plastic_kinematichardening.f90" #include "plastic_dislotwin.f90" #include "plastic_disloUCLA.f90" #include "plastic_nonlocal.f90" diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 8efd387e0..a62245f99 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -74,6 +74,7 @@ subroutine constitutive_init() PLASTICITY_none_ID, & PLASTICITY_isotropic_ID, & PLASTICITY_phenopowerlaw_ID, & + PLASTICITY_kinehardening_ID, & PLASTICITY_dislotwin_ID, & PLASTICITY_disloucla_ID, & PLASTICITY_nonlocal_ID ,& @@ -95,6 +96,7 @@ subroutine constitutive_init() PLASTICITY_NONE_label, & PLASTICITY_ISOTROPIC_label, & PLASTICITY_PHENOPOWERLAW_label, & + PLASTICITY_KINEHARDENING_label, & PLASTICITY_DISLOTWIN_label, & PLASTICITY_DISLOUCLA_label, & PLASTICITY_NONLOCAL_label, & @@ -113,6 +115,7 @@ subroutine constitutive_init() use plastic_none use plastic_isotropic use plastic_phenopowerlaw + use plastic_kinehardening use plastic_dislotwin use plastic_disloucla use plastic_nonlocal @@ -156,6 +159,7 @@ subroutine constitutive_init() if (any(phase_plasticity == PLASTICITY_NONE_ID)) call plastic_none_init if (any(phase_plasticity == PLASTICITY_ISOTROPIC_ID)) call plastic_isotropic_init(FILEUNIT) if (any(phase_plasticity == PLASTICITY_PHENOPOWERLAW_ID)) call plastic_phenopowerlaw_init(FILEUNIT) + if (any(phase_plasticity == PLASTICITY_KINEHARDENING_ID)) call plastic_kinehardening_init(FILEUNIT) if (any(phase_plasticity == PLASTICITY_DISLOTWIN_ID)) call plastic_dislotwin_init(FILEUNIT) if (any(phase_plasticity == PLASTICITY_DISLOUCLA_ID)) call plastic_disloucla_init(FILEUNIT) if (any(phase_plasticity == PLASTICITY_NONLOCAL_ID)) then @@ -214,6 +218,11 @@ subroutine constitutive_init() thisNoutput => plastic_phenopowerlaw_Noutput thisOutput => plastic_phenopowerlaw_output thisSize => plastic_phenopowerlaw_sizePostResult + case (PLASTICITY_KINEHARDENING_ID) plasticityType + outputName = PLASTICITY_KINEHARDENING_label + thisNoutput => plastic_kinehardening_Noutput + thisOutput => plastic_kinehardening_output + thisSize => plastic_kinehardening_sizePostResult case (PLASTICITY_DISLOTWIN_ID) plasticityType outputName = PLASTICITY_DISLOTWIN_label thisNoutput => plastic_dislotwin_Noutput @@ -472,6 +481,7 @@ subroutine constitutive_LpAndItsTangent(Lp, dLp_dTstar3333, dLp_dFi3333, Tstar_v PLASTICITY_NONE_ID, & PLASTICITY_ISOTROPIC_ID, & PLASTICITY_PHENOPOWERLAW_ID, & + PLASTICITY_KINEHARDENING_ID, & PLASTICITY_DISLOTWIN_ID, & PLASTICITY_DISLOUCLA_ID, & PLASTICITY_NONLOCAL_ID @@ -479,6 +489,8 @@ subroutine constitutive_LpAndItsTangent(Lp, dLp_dTstar3333, dLp_dFi3333, Tstar_v plastic_isotropic_LpAndItsTangent use plastic_phenopowerlaw, only: & plastic_phenopowerlaw_LpAndItsTangent + use plastic_kinehardening, only: & + plastic_kinehardening_LpAndItsTangent use plastic_dislotwin, only: & plastic_dislotwin_LpAndItsTangent use plastic_disloucla, only: & @@ -522,18 +534,20 @@ subroutine constitutive_LpAndItsTangent(Lp, dLp_dTstar3333, dLp_dFi3333, Tstar_v Lp = 0.0_pReal dLp_dMstar = 0.0_pReal case (PLASTICITY_ISOTROPIC_ID) plasticityType - call plastic_isotropic_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v,ipc,ip,el) + call plastic_isotropic_LpAndItsTangent (Lp,dLp_dMstar,Mstar_v,ipc,ip,el) case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType - call plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v,ipc,ip,el) + call plastic_phenopowerlaw_LpAndItsTangent (Lp,dLp_dMstar,Mstar_v,ipc,ip,el) + case (PLASTICITY_KINEHARDENING_ID) plasticityType + call plastic_kinehardening_LpAndItsTangent (Lp,dLp_dMstar,Mstar_v,ipc,ip,el) case (PLASTICITY_NONLOCAL_ID) plasticityType - call plastic_nonlocal_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v, & - temperature(ho)%p(tme),ip,el) + call plastic_nonlocal_LpAndItsTangent (Lp,dLp_dMstar,Mstar_v, & + temperature(ho)%p(tme),ip,el) case (PLASTICITY_DISLOTWIN_ID) plasticityType - call plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v, & - temperature(ho)%p(tme),ipc,ip,el) + call plastic_dislotwin_LpAndItsTangent (Lp,dLp_dMstar,Mstar_v, & + temperature(ho)%p(tme),ipc,ip,el) case (PLASTICITY_DISLOUCLA_ID) plasticityType - call plastic_disloucla_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v, & - temperature(ho)%p(tme), ipc,ip,el) + call plastic_disloucla_LpAndItsTangent (Lp,dLp_dMstar,Mstar_v, & + temperature(ho)%p(tme), ipc,ip,el) end select plasticityType dLp_dTstar3333 = math_Plain99to3333(dLp_dMstar) @@ -717,7 +731,7 @@ end function constitutive_initialFi !-------------------------------------------------------------------------------------------------- !> @brief returns the 2nd Piola-Kirchhoff stress tensor and its tangent with respect to !> the elastic deformation gradient depending on the selected elastic law (so far no case switch -!! because only hooke is implemented +!! because only Hooke is implemented !-------------------------------------------------------------------------------------------------- subroutine constitutive_TandItsTangent(T, dT_dFe, dT_dFi, Fe, Fi, ipc, ip, el) use prec, only: & @@ -844,6 +858,7 @@ subroutine constitutive_collectDotState(Tstar_v, FeArray, FpArray, subdt, subfra PLASTICITY_none_ID, & PLASTICITY_isotropic_ID, & PLASTICITY_phenopowerlaw_ID, & + PLASTICITY_kinehardening_ID, & PLASTICITY_dislotwin_ID, & PLASTICITY_disloucla_ID, & PLASTICITY_nonlocal_ID, & @@ -855,6 +870,8 @@ subroutine constitutive_collectDotState(Tstar_v, FeArray, FpArray, subdt, subfra plastic_isotropic_dotState use plastic_phenopowerlaw, only: & plastic_phenopowerlaw_dotState + use plastic_kinehardening, only: & + plastic_kinehardening_dotState use plastic_dislotwin, only: & plastic_dislotwin_dotState use plastic_disloucla, only: & @@ -905,6 +922,8 @@ subroutine constitutive_collectDotState(Tstar_v, FeArray, FpArray, subdt, subfra call plastic_isotropic_dotState (Tstar_v,ipc,ip,el) case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType call plastic_phenopowerlaw_dotState(Tstar_v,ipc,ip,el) + case (PLASTICITY_KINEHARDENING_ID) plasticityType + call plastic_kinehardening_dotState(Tstar_v,ipc,ip,el) case (PLASTICITY_DISLOTWIN_ID) plasticityType call plastic_dislotwin_dotState (Tstar_v,temperature(ho)%p(tme), & ipc,ip,el) @@ -959,10 +978,13 @@ subroutine constitutive_collectDeltaState(Tstar_v, Fe, ipc, ip, el) phase_source, & phase_Nsources, & material_phase, & + PLASTICITY_KINEHARDENING_ID, & PLASTICITY_NONLOCAL_ID, & SOURCE_damage_isoBrittle_ID, & SOURCE_vacancy_irradiation_ID, & SOURCE_vacancy_thermalfluc_ID + use plastic_kinehardening, only: & + plastic_kinehardening_deltaState use plastic_nonlocal, only: & plastic_nonlocal_deltaState use source_damage_isoBrittle, only: & @@ -991,15 +1013,18 @@ subroutine constitutive_collectDeltaState(Tstar_v, Fe, ipc, ip, el) if (iand(debug_level(debug_constitutive), debug_levelBasic) /= 0_pInt) & call system_clock(count=tick,count_rate=tickrate,count_max=maxticks) - if(phase_plasticity(material_phase(ipc,ip,el)) == PLASTICITY_NONLOCAL_ID) & - call plastic_nonlocal_deltaState(Tstar_v,ip,el) - + plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) + case (PLASTICITY_KINEHARDENING_ID) plasticityType + call plastic_kinehardening_deltaState(Tstar_v,ipc,ip,el) + case (PLASTICITY_NONLOCAL_ID) plasticityType + call plastic_nonlocal_deltaState(Tstar_v,ip,el) + end select plasticityType SourceLoop: do s = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) sourceType: select case (phase_source(s,material_phase(ipc,ip,el))) case (SOURCE_damage_isoBrittle_ID) sourceType call source_damage_isoBrittle_deltaState (constitutive_homogenizedC(ipc,ip,el), Fe, & - ipc, ip, el) + ipc, ip, el) case (SOURCE_vacancy_irradiation_ID) sourceType call source_vacancy_irradiation_deltaState(ipc, ip, el) case (SOURCE_vacancy_thermalfluc_ID) sourceType @@ -1043,6 +1068,7 @@ function constitutive_postResults(Tstar_v, FeArray, ipc, ip, el) PLASTICITY_NONE_ID, & PLASTICITY_ISOTROPIC_ID, & PLASTICITY_PHENOPOWERLAW_ID, & + PLASTICITY_KINEHARDENING_ID, & PLASTICITY_DISLOTWIN_ID, & PLASTICITY_DISLOUCLA_ID, & PLASTICITY_NONLOCAL_ID, & @@ -1054,6 +1080,8 @@ function constitutive_postResults(Tstar_v, FeArray, ipc, ip, el) plastic_isotropic_postResults use plastic_phenopowerlaw, only: & plastic_phenopowerlaw_postResults + use plastic_kinehardening, only: & + plastic_kinehardening_postResults use plastic_dislotwin, only: & plastic_dislotwin_postResults use plastic_disloucla, only: & @@ -1102,6 +1130,9 @@ function constitutive_postResults(Tstar_v, FeArray, ipc, ip, el) case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType constitutive_postResults(startPos:endPos) = & plastic_phenopowerlaw_postResults(Tstar_v,ipc,ip,el) + case (PLASTICITY_KINEHARDENING_ID) plasticityType + constitutive_postResults(startPos:endPos) = & + plastic_kinehardening_postResults(Tstar_v,ipc,ip,el) case (PLASTICITY_DISLOTWIN_ID) plasticityType constitutive_postResults(startPos:endPos) = & plastic_dislotwin_postResults(Tstar_v,temperature(ho)%p(tme),ipc,ip,el) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 3ff4417fe..12bf19871 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -986,7 +986,9 @@ subroutine crystallite_stressAndItsTangent(updateJaco) crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > subStepMinCryst ! still on track or already done (beyond repair) !$OMP FLUSH(crystallite_todo) #ifdef DEBUG - if (iand(debug_level(debug_crystallite),debug_levelBasic) /= 0_pInt) then + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & + .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt)) then if (crystallite_todo(c,i,e)) then write(6,'(a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST >> cutback step in crystallite_stressAndItsTangent & &with new crystallite_subStep: ',& @@ -1042,16 +1044,25 @@ subroutine crystallite_stressAndItsTangent(updateJaco) endif timeSyncing2 if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then - write(6,'(/,a,e12.5)') '<< CRYST >> min(subStep) ',minval(crystallite_subStep) - write(6,'(a,e12.5)') '<< CRYST >> max(subStep) ',maxval(crystallite_subStep) - write(6,'(a,e12.5)') '<< CRYST >> min(subFrac) ',minval(crystallite_subFrac) - write(6,'(a,e12.5,/)') '<< CRYST >> max(subFrac) ',maxval(crystallite_subFrac) + write(6,'(/,a,f8.5)') '<< CRYST >> min(subStep) ',minval(crystallite_subStep) + write(6,'(a,f8.5)') '<< CRYST >> max(subStep) ',maxval(crystallite_subStep) + write(6,'(a,f8.5)') '<< CRYST >> min(subFrac) ',minval(crystallite_subFrac) + write(6,'(a,f8.5,/)') '<< CRYST >> max(subFrac) ',maxval(crystallite_subFrac) flush(6) + if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt) then + write(6,'(/,a,f8.5,1x,a,1x,f8.5,1x,a)') '<< CRYST >> subFrac + subStep = ',& + crystallite_subFrac(debug_g,debug_i,debug_e),'+',crystallite_subStep(debug_g,debug_i,debug_e),'@selective' + flush(6) + endif endif ! --- integrate --- requires fully defined state array (basic + dependent state) if (any(crystallite_todo)) then + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then + write(6,'(/,a,i3)') '<< CRYST >> using state integrator ',numerics_integrator(numerics_integrationMode) + flush(6) + endif select case(numerics_integrator(numerics_integrationMode)) case(1_pInt) call crystallite_integrateStateFPI() @@ -2702,6 +2713,9 @@ subroutine crystallite_integrateStateFPI() singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo at start of state integration' + !-------------------------------------------------------------------------------------------------- ! initialize dotState if (.not. singleRun) then @@ -2754,6 +2768,8 @@ subroutine crystallite_integrateStateFPI() NaN = NaN .or. any(IEEE_is_NaN(sourceState(p)%p(mySource)%dotState(:,c))) enddo if (NaN) then ! NaN occured in any dotState + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,*) '<< CRYST >> dotstate ',plasticState(p)%dotState(:,c) if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken is a non-local... !$OMP CRITICAL (checkTodo) crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals done (and broken) @@ -2767,6 +2783,9 @@ subroutine crystallite_integrateStateFPI() !$OMP ENDDO ! --- UPDATE STATE --- + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo after preguess of state' + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains @@ -2822,6 +2841,9 @@ subroutine crystallite_integrateStateFPI() ! --- STRESS INTEGRATION --- + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo before stress integration' + !$OMP DO do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains !$OMP FLUSH(crystallite_todo) @@ -2976,7 +2998,11 @@ subroutine crystallite_integrateStateFPI() .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> update state at el ip g ',e,i,g write(6,'(a,f6.1,/)') '<< CRYST >> plasticstatedamper ',plasticStatedamper - write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> plastic state residuum',plasticStateResiduum(1:mySizePlasticDotState) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> plastic state residuum',& + abs(plasticStateResiduum(1:mySizePlasticDotState)) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> abstol dotstate',plasticState(p)%aTolState(1:mySizePlasticDotState) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> reltol dotstate',rTol_crystalliteState* & + abs(tempPlasticState(1:mySizePlasticDotState)) write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state',tempPlasticState(1:mySizePlasticDotState) endif #endif @@ -3036,8 +3062,8 @@ subroutine crystallite_integrateStateFPI() !$OMP END PARALLEL if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & - write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & - ' grains converged after state integration #', NiterationState + write(6,'(a,i8,a,i2)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & + ' grains converged after state integration #', NiterationState ! --- NON-LOCAL CONVERGENCE CHECK --- @@ -3152,8 +3178,8 @@ logical function crystallite_stateJump(ipc,ip,el) write(6,'(a,i8,1x,i2,1x,i3, /)') '<< CRYST >> update state at el ip ipc ',el,ip,ipc write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> deltaState', plasticState(p)%deltaState(1:mySizePlasticDeltaState,c) write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', & - plasticState(p)%state(myOffsetSourceDeltaState + 1_pInt : & - myOffsetSourceDeltaState + mySizeSourceDeltaState,c) + plasticState(p)%state(myOffsetPlasticDeltaState + 1_pInt : & + myOffsetPlasticDeltaState + mySizePlasticDeltaState,c) endif #endif @@ -3195,9 +3221,9 @@ end function crystallite_push33ToRef !> intermediate acceleration of the Newton-Raphson correction !-------------------------------------------------------------------------------------------------- logical function crystallite_integrateStress(& - ipc,& ! grain number - ip,& ! integration point number - el,& ! element number + ipc,& ! grain number + ip,& ! integration point number + el,& ! element number timeFraction & ) use, intrinsic :: & @@ -3252,10 +3278,10 @@ logical function crystallite_integrateStress(& #endif implicit none - integer(pInt), intent(in):: el, & ! element index - ip, & ! integration point index - ipc ! grain index - real(pReal), optional, intent(in) :: timeFraction ! fraction of timestep + integer(pInt), intent(in):: el, & ! element index + ip, & ! integration point index + ipc ! grain index + real(pReal), optional, intent(in) :: timeFraction ! fraction of timestep !*** local variables ***! real(pReal), dimension(3,3):: Fg_new, & ! deformation gradient at end of timestep @@ -3330,7 +3356,6 @@ logical function crystallite_integrateStress(& write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> integrateStress at el ip ipc ',el,ip,ipc #endif - !* only integrate over fraction of timestep? if (present(timeFraction)) then @@ -3417,7 +3442,7 @@ logical function crystallite_integrateStress(& #ifdef DEBUG if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & write(6,'(a,i3,a,i8,1x,a,i8,a,1x,i2,1x,i3,/)') '<< CRYST >> integrateStress reached loop limit',nStress, & - ' at el (elFE) ip ipc ', el,mesh_element(1,el),ip,ipc + ' at el (elFE) ip ipc ', el,'(',mesh_element(1,el),')',ip,ipc #endif return endif loopsExeced @@ -3426,7 +3451,8 @@ logical function crystallite_integrateStress(& B = math_I3 - dt*Lpguess Fe = math_mul33x33(math_mul33x33(A,B), invFi_new) ! current elastic deformation tensor - call constitutive_TandItsTangent(Tstar, dT_dFe3333, dT_dFi3333, Fe, Fi_new, ipc, ip, el) ! call constitutive law to calculate 2nd Piola-Kirchhoff stress and its derivative in unloaded configuration + call constitutive_TandItsTangent(Tstar, dT_dFe3333, dT_dFi3333, & + Fe, Fi_new, ipc, ip, el) ! call constitutive law to calculate 2nd Piola-Kirchhoff stress and its derivative in unloaded configuration Tstar_v = math_Mandel33to6(Tstar) !* calculate plastic velocity gradient and its tangent from constitutive law @@ -3434,6 +3460,17 @@ logical function crystallite_integrateStress(& if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & call system_clock(count=tick,count_rate=tickrate,count_max=maxticks) +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i3,/)') '<< CRYST >> stress iteration ', NiterationStressLp + write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST >> Lpguess', math_transpose33(Lpguess) + write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST >> Fi', math_transpose33(Fi_new) + write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST >> Fe', math_transpose33(Fe) + write(6,'(a,/,6(e20.10,1x))') '<< CRYST >> Tstar', Tstar_v + endif +#endif call constitutive_LpAndItsTangent(Lp_constitutive, dLp_dT3333, dLp_dFi3333, & Tstar_v, Fi_new, ipc, ip, el) @@ -3451,9 +3488,7 @@ logical function crystallite_integrateStress(& if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then - write(6,'(a,i3,/)') '<< CRYST >> stress iteration ', NiterationStressLp - write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Lp_constitutive', math_transpose33(Lp_constitutive) - write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Lpguess', math_transpose33(Lpguess) + write(6,'(a,/,3(12x,3(e20.10,1x)/))') '<< CRYST >> Lp_constitutive', math_transpose33(Lp_constitutive) endif #endif @@ -3483,6 +3518,13 @@ logical function crystallite_integrateStress(& else ! not converged and residuum not improved... steplengthLp = subStepSizeLp * steplengthLp ! ...try with smaller step length in same direction Lpguess = Lpguess_old + steplengthLp * deltaLp +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,1x,f7.4)') '<< CRYST >> linear search for Lpguess with step', steplengthLp + endif +#endif cycle LpLoop endif @@ -3496,6 +3538,16 @@ logical function crystallite_integrateStress(& dFe_dLp3333 = - dt * dFe_dLp3333 dRLp_dLp = math_identity2nd(9_pInt) & - math_Plain3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dT3333,dT_dFe3333),dFe_dLp3333)) +#ifdef DEBUG + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST >> dLp_dT', math_Plain3333to99(dLp_dT3333) + write(6,'(a,1x,e20.10)') '<< CRYST >> dLp_dT norm', norm2(math_Plain3333to99(dLp_dT3333)) + write(6,'(a,/,9(12x,9(e12.4,1x)/))') '<< CRYST >> dRLp_dLp', dRLp_dLp - math_identity2nd(9_pInt) + write(6,'(a,1x,e20.10)') '<< CRYST >> dRLp_dLp norm', norm2(dRLp_dLp - math_identity2nd(9_pInt)) + endif +#endif dRLp_dLp2 = dRLp_dLp ! will be overwritten in first call to LAPACK routine work = math_plain33to9(residuumLp) call dgesv(9,1,dRLp_dLp2,9,ipiv,work,9,ierr) ! solve dRLp/dLp * delta Lp = -res for delta Lp diff --git a/src/debug.f90 b/src/debug.f90 index c4c3ddd60..feb1c9fe4 100644 --- a/src/debug.f90 +++ b/src/debug.f90 @@ -443,13 +443,15 @@ subroutine debug_info write(6,'(a15,i10,1x,i10)') ' total',integral,sum(debug_MaterialpointLoopDistribution) endif debugOutputHomog - debugOutputCPFEM: if (iand(debug_level(debug_CPFEM),debug_LEVELBASIC) /= 0) then - write(6,'(2/,a,/)') ' Extreme values of returned stress and jacobian' + debugOutputCPFEM: if (iand(debug_level(debug_CPFEM),debug_LEVELBASIC) /= 0 & + .and. any(debug_stressMinLocation /= 0_pInt) & + .and. any(debug_stressMaxLocation /= 0_pInt) ) then + write(6,'(2/,a,/)') ' Extreme values of returned stress and Jacobian' write(6,'(a39)') ' value el ip' - write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') ' stress min :', debug_stressMin, debug_stressMinLocation - write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') ' max :', debug_stressMax, debug_stressMaxLocation - write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') ' jacobian min :', debug_jacobianMin, debug_jacobianMinLocation - write(6,'(a14,1x,e12.3,1x,i6,1x,i4,/)') ' max :', debug_jacobianMax, debug_jacobianMaxLocation + write(6,'(a14,1x,e12.3,1x,i8,1x,i4)') ' stress min :', debug_stressMin, debug_stressMinLocation + write(6,'(a14,1x,e12.3,1x,i8,1x,i4)') ' max :', debug_stressMax, debug_stressMaxLocation + write(6,'(a14,1x,e12.3,1x,i8,1x,i4)') ' Jacobian min :', debug_jacobianMin, debug_jacobianMinLocation + write(6,'(a14,1x,e12.3,1x,i8,1x,i4,/)') ' max :', debug_jacobianMax, debug_jacobianMaxLocation endif debugOutputCPFEM !$OMP END CRITICAL (write2out) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index fe9885215..95dab049f 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -166,52 +166,30 @@ subroutine homogenization_RGC_init(fileUnit) tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key select case(tag) case ('(output)') + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt + homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) case('constitutivework') - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = constitutivework_ID - homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case('penaltyenergy') - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = penaltyenergy_ID - homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case('volumediscrepancy') - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = volumediscrepancy_ID - homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case('averagerelaxrate') - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = averagerelaxrate_ID - homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case('maximumrelaxrate') - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = maximumrelaxrate_ID - homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case('magnitudemismatch') - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = magnitudemismatch_ID - homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case('ipcoords') - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = ipcoords_ID - homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case('avgdefgrad','avgf') - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = avgdefgrad_ID - homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) case('avgp','avgfirstpiola','avg1stpiola') - homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = avgfirstpiola_ID - homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & - IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case default + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) -1_pInt ! correct for invalid end select case ('clustersize') diff --git a/src/material.f90 b/src/material.f90 index 090b94023..25d115520 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -25,6 +25,7 @@ module material PLASTICITY_none_label = 'none', & PLASTICITY_isotropic_label = 'isotropic', & PLASTICITY_phenopowerlaw_label = 'phenopowerlaw', & + PLASTICITY_kinehardening_label = 'kinehardening', & PLASTICITY_dislotwin_label = 'dislotwin', & PLASTICITY_disloucla_label = 'disloucla', & PLASTICITY_nonlocal_label = 'nonlocal', & @@ -72,6 +73,7 @@ module material PLASTICITY_none_ID, & PLASTICITY_isotropic_ID, & PLASTICITY_phenopowerlaw_ID, & + PLASTICITY_kinehardening_ID, & PLASTICITY_dislotwin_ID, & PLASTICITY_disloucla_ID, & PLASTICITY_nonlocal_ID @@ -308,6 +310,7 @@ module material PLASTICITY_none_ID, & PLASTICITY_isotropic_ID, & PLASTICITY_phenopowerlaw_ID, & + PLASTICITY_kinehardening_ID, & PLASTICITY_dislotwin_ID, & PLASTICITY_disloucla_ID, & PLASTICITY_nonlocal_ID, & @@ -983,6 +986,8 @@ subroutine material_parsePhase(fileUnit,myPart) phase_plasticity(section) = PLASTICITY_ISOTROPIC_ID case (PLASTICITY_PHENOPOWERLAW_label) phase_plasticity(section) = PLASTICITY_PHENOPOWERLAW_ID + case (PLASTICITY_KINEHARDENING_label) + phase_plasticity(section) = PLASTICITY_KINEHARDENING_ID case (PLASTICITY_DISLOTWIN_label) phase_plasticity(section) = PLASTICITY_DISLOTWIN_ID case (PLASTICITY_DISLOUCLA_label) diff --git a/src/math.f90 b/src/math.f90 index 82945a822..f253a1b28 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -74,6 +74,7 @@ module math public :: & math_init, & math_qsort, & + math_expand, & math_range, & math_identity2nd, & math_identity4th, & @@ -162,10 +163,8 @@ module math math_limit, & math_expand private :: & - halton, & - halton_memory, & - halton_ndim_set, & - halton_seed_set + math_check, & + halton contains @@ -217,10 +216,6 @@ subroutine math_init write(6,'(a,4(/,26x,f17.14),/)') ' start of random sequence: ', randTest call random_seed(put = randInit) - - call halton_seed_set(int(randInit(1), pInt)) - call halton_ndim_set(3_pInt) - call math_check() end subroutine math_init @@ -284,7 +279,7 @@ subroutine math_check endif ! +++ check rotation sense of q and R +++ - call halton(3_pInt,v) ! random vector + v = halton([2_pInt,8_pInt,5_pInt]) ! random vector R = math_qToR(q) if (any(abs(math_mul33x3(R,v) - math_qRot(q,v)) > tol_math_check)) then write (error_msg, '(a)' ) 'R(q)*v has different sense than q*v' @@ -1241,7 +1236,7 @@ function math_qRand() real(pReal), dimension(4) :: math_qRand real(pReal), dimension(3) :: rnd - call halton(3_pInt,rnd) + rnd = halton([8_pInt,4_pInt,9_pInt]) math_qRand = [cos(2.0_pReal*PI*rnd(1))*sqrt(rnd(3)), & sin(2.0_pReal*PI*rnd(2))*sqrt(1.0_pReal-rnd(3)), & cos(2.0_pReal*PI*rnd(2))*sqrt(1.0_pReal-rnd(3)), & @@ -1529,7 +1524,7 @@ pure function math_axisAngleToR(axis,omega) norm = norm2(axis) wellDefined: if (norm > 1.0e-8_pReal) then - n = axis/norm ! normalize axis to be sure + n = axis/norm ! normalize axis to be sure s = sin(omega) c = cos(omega) @@ -1764,7 +1759,7 @@ function math_sampleRandomOri() implicit none real(pReal), dimension(3) :: math_sampleRandomOri, rnd - call halton(3_pInt,rnd) + rnd = halton([1_pInt,7_pInt,3_pInt]) math_sampleRandomOri = [rnd(1)*2.0_pReal*PI, & acos(2.0_pReal*rnd(2)-1.0_pReal), & rnd(3)*2.0_pReal*PI] @@ -1773,118 +1768,96 @@ end function math_sampleRandomOri !-------------------------------------------------------------------------------------------------- -!> @brief draw a random sample from Gauss component with noise (in radians) half-width +!> @brief draw a sample from an Gaussian distribution around given orientation and Full Width +! at Half Maximum (FWHM) +!> @details: A uniform misorientation (limited to 2*FWHM) is sampled followed by convolution with +! a Gausian distribution !-------------------------------------------------------------------------------------------------- -function math_sampleGaussOri(center,noise) - use prec, only: & - tol_math_check +function math_sampleGaussOri(center,FWHM) implicit none - real(pReal), intent(in) :: noise + real(pReal), intent(in) :: FWHM real(pReal), dimension(3), intent(in) :: center - real(pReal) :: cosScatter,scatter - real(pReal), dimension(3) :: math_sampleGaussOri, disturb - real(pReal), dimension(3), parameter :: ORIGIN = 0.0_pReal - real(pReal), dimension(5) :: rnd + real(pReal) :: angle + real(pReal), dimension(3) :: math_sampleGaussOri, axis + real(pReal), dimension(4) :: rnd + real(pReal), dimension(3,3) :: R - noScatter: if (abs(noise) < tol_math_check) then + if (FWHM < 0.1_pReal*INRAD) then math_sampleGaussOri = center - else noScatter - ! Helming uses different distribution with Bessel functions - ! therefore the gauss scatter width has to be scaled differently - scatter = 0.95_pReal * noise - cosScatter = cos(scatter) + else + GaussConvolution: do + rnd = halton([8_pInt,3_pInt,6_pInt,11_pInt]) + axis(1) = rnd(1)*2.0_pReal-1.0_pReal ! uniform on [-1,1] + axis(2:3) = [sqrt(1.0-axis(1)**2.0_pReal)*cos(rnd(2)*2.0*PI),& + sqrt(1.0-axis(1)**2.0_pReal)*sin(rnd(2)*2.0*PI)] ! random axis + angle = (rnd(3)-0.5_pReal)*4.0_pReal*FWHM ! rotation by [0, +-2 FWHM] + R = math_axisAngleToR(axis,angle) + angle = math_EulerMisorientation([0.0_pReal,0.0_pReal,0.0_pReal],math_RtoEuler(R)) + if (rnd(4) <= exp(-4.0_pReal*log(2.0_pReal)*(angle/FWHM)**2_pReal)) exit ! rejection sampling (Gaussian) + enddo GaussConvolution + math_sampleGaussOri = math_RtoEuler(math_mul33x33(R,math_EulerToR(center))) + endif - do - call halton(5_pInt,rnd) - rnd(1:3) = 2.0_pReal*rnd(1:3)-1.0_pReal ! expand 1:3 to range [-1,+1] - disturb = [ scatter * rnd(1), & ! phi1 - sign(1.0_pReal,rnd(2))*acos(cosScatter+(1.0_pReal-cosScatter)*rnd(4)), & ! Phi - scatter * rnd(3)] ! phi2 - if (rnd(5) <= exp(-1.0_pReal*(math_EulerMisorientation(ORIGIN,disturb)/scatter)**2_pReal)) exit - enddo - - math_sampleGaussOri = math_RtoEuler(math_mul33x33(math_EulerToR(disturb),math_EulerToR(center))) - endif noScatter end function math_sampleGaussOri !-------------------------------------------------------------------------------------------------- -!> @brief draw a random sample from Fiber component with noise (in radians) -!-------------------------------------------------------------------------------------------------- -function math_sampleFiberOri(alpha,beta,noise) - use prec, only: & - tol_math_check +!> @brief draw a sample from an Gaussian distribution around given fiber texture and Full Width +! at Half Maximum (FWHM) +!------------------------------------------------------------------------------------------------- +function math_sampleFiberOri(alpha,beta,FWHM) implicit none - real(pReal), dimension(3) :: math_sampleFiberOri, fiberInC,fiberInS,axis real(pReal), dimension(2), intent(in) :: alpha,beta - real(pReal), dimension(6) :: rnd - real(pReal), dimension(3,3) :: oRot,fRot,pRot - real(pReal) :: noise, scatter, cos2Scatter, angle - integer(pInt), dimension(2,3), parameter :: ROTMAP = reshape([2_pInt,3_pInt,& - 3_pInt,1_pInt,& - 1_pInt,2_pInt],[2,3]) - integer(pInt) :: i + real(pReal), intent(in) :: FWHM + real(pReal), dimension(3) :: math_sampleFiberOri, & + fInC,& !< fiber axis in crystal coordinate system + fInS,& !< fiber axis in sample coordinate system + u + real(pReal), dimension(3) :: rnd + real(pReal), dimension(:),allocatable :: a !< 2D vector to tilt + integer(pInt), dimension(:),allocatable :: idx !< components of 2D vector + real(pReal), dimension(3,3) :: R !< Rotation matrix (composed of three components) + real(pReal):: angle,c + integer(pInt):: j,& !< index of smallest component + i -! Helming uses different distribution with Bessel functions -! therefore the gauss scatter width has to be scaled differently - scatter = 0.95_pReal * noise - cos2Scatter = cos(2.0_pReal*scatter) + fInC = [sin(alpha(1))*cos(alpha(2)), sin(alpha(1))*sin(alpha(2)), cos(alpha(1))] + fInS = [sin(beta(1))*cos(beta(2)), sin(beta(1))*sin(beta(2)), cos(beta(1))] -! fiber axis in crystal coordinate system - fiberInC = [ sin(alpha(1))*cos(alpha(2)) , & - sin(alpha(1))*sin(alpha(2)), & - cos(alpha(1))] -! fiber axis in sample coordinate system - fiberInS = [ sin(beta(1))*cos(beta(2)), & - sin(beta(1))*sin(beta(2)), & - cos(beta(1))] + R = math_EulerAxisAngleToR(math_crossproduct(fInC,fInS),-acos(dot_product(fInC,fInS))) !< rotation to align fiber axis in crystal and sample system -! ---# rotation matrix from sample to crystal system #--- - angle = -acos(dot_product(fiberInC,fiberInS)) - if(abs(angle) > tol_math_check) then -! rotation axis between sample and crystal system (cross product) - forall(i=1_pInt:3_pInt) axis(i) = fiberInC(ROTMAP(1,i))*fiberInS(ROTMAP(2,i))-fiberInC(ROTMAP(2,i))*fiberInS(ROTMAP(1,i)) - oRot = math_EulerAxisAngleToR(math_crossproduct(fiberInC,fiberInS),angle) - else - oRot = math_I3 - end if + rnd = halton([7_pInt,10_pInt,3_pInt]) + R = math_mul33x33(R,math_EulerAxisAngleToR(fInS,rnd(1)*2.0_pReal*PI)) !< additional rotation (0..360deg) perpendicular to fiber axis -! ---# rotation matrix about fiber axis (random angle) #--- - do - call halton(6_pInt,rnd) - fRot = math_EulerAxisAngleToR(fiberInS,rnd(1)*2.0_pReal*pi) + if (FWHM > 0.1_pReal*INRAD) then + reducedTo2D: do i=1_pInt,3_pInt + if (i /= minloc(abs(fInS),1)) then + a=[a,fInS(i)] + idx=[idx,i] + else + j = i + endif + enddo reducedTo2D + GaussConvolution: do + angle = (rnd(2)-0.5_pReal)*4.0_pReal*FWHM ! rotation by [0, +-2 FWHM] + ! solve cos(angle) = dot_product(fInS,u) under the assumption that their smallest component is the same + c = cos(angle)-fInS(j)**2 + u(idx(2)) = -(2.0_pReal*c*a(2) + sqrt(4*((c*a(2))**2-sum(a**2)*(c**2-a(1)**2*(1-fInS(j)**2)))))/& + (2*sum(a**2)) + u(idx(1)) = sqrt(1-u(idx(2))**2-fInS(j)**2) + u(j) = fInS(j) -! ---# rotation about random axis perpend to fiber #--- -! random axis pependicular to fiber axis - axis(1:2) = rnd(2:3) - if (abs(fiberInS(3)) > tol_math_check) then - axis(3)=-(axis(1)*fiberInS(1)+axis(2)*fiberInS(2))/fiberInS(3) - else if(abs(fiberInS(2)) > tol_math_check) then - axis(3)=axis(2) - axis(2)=-(axis(1)*fiberInS(1)+axis(3)*fiberInS(3))/fiberInS(2) - else if(abs(fiberInS(1)) > tol_math_check) then - axis(3)=axis(1) - axis(1)=-(axis(2)*fiberInS(2)+axis(3)*fiberInS(3))/fiberInS(1) - end if - -! scattered rotation angle - if (noise > 0.0_pReal) then - angle = acos(cos2Scatter+(1.0_pReal-cos2Scatter)*rnd(4)) - if (rnd(5) <= exp(-1.0_pReal*(angle/scatter)**2.0_pReal)) exit - else - angle = 0.0_pReal - exit - end if - enddo - if (rnd(6) <= 0.5) angle = -angle - - pRot = math_EulerAxisAngleToR(axis,angle) - -! ---# apply the three rotations #--- - math_sampleFiberOri = math_RtoEuler(math_mul33x33(pRot,math_mul33x33(fRot,oRot))) + rejectionSampling: if (rnd(3) <= exp(-4.0_pReal*log(2.0_pReal)*(angle/FWHM)**2_pReal)) then + R = math_mul33x33(R,math_EulerAxisAngleToR(math_crossproduct(u,fInS),angle)) ! tilt around direction of smallest component + exit + endif rejectionSampling + rnd = halton([7_pInt,10_pInt,3_pInt]) + enddo GaussConvolution + endif + math_sampleFiberOri = math_RtoEuler(R) end function math_sampleFiberOri @@ -1906,19 +1879,18 @@ real(pReal) function math_sampleGaussVar(meanvalue, stddev, width) if (abs(stddev) < tol_math_check) then math_sampleGaussVar = meanvalue - return + else + myWidth = merge(width,3.0_pReal,present(width)) ! use +-3*sigma as default value for scatter if not given + + do + rnd = halton([6_pInt,2_pInt]) + scatter = myWidth * (2.0_pReal * rnd(1) - 1.0_pReal) + if (rnd(2) <= exp(-0.5_pReal * scatter ** 2.0_pReal)) exit ! test if scattered value is drawn + enddo + + math_sampleGaussVar = scatter * stddev endif - myWidth = merge(width,3.0_pReal,present(width)) ! use +-3*sigma as default value for scatter if not given - - do - call halton(2_pInt, rnd) - scatter = myWidth * (2.0_pReal * rnd(1) - 1.0_pReal) - if (rnd(2) <= exp(-0.5_pReal * scatter ** 2.0_pReal)) exit ! test if scattered value is drawn - enddo - - math_sampleGaussVar = scatter * stddev - end function math_sampleGaussVar @@ -2288,388 +2260,228 @@ pure function math_invariantsSym33(m) end function math_invariantsSym33 -!-------------------------------------------------------------------------------------------------- -!> @brief computes the next element in the Halton sequence. +!------------------------------------------------------------------------------------------------- +!> @brief computes an element of a Halton sequence. !> @author John Burkardt -!-------------------------------------------------------------------------------------------------- -subroutine halton(ndim, r) - - implicit none - integer(pInt), intent(in) :: ndim !< dimension of the element - real(pReal), intent(out), dimension(ndim) :: r !< next element of the current Halton sequence - integer(pInt), dimension(ndim) :: base - integer(pInt) :: seed - integer(pInt), dimension(1) :: value_halton - - call halton_memory ('GET', 'SEED', 1_pInt, value_halton) - seed = value_halton(1) - - call halton_memory ('GET', 'BASE', ndim, base) - - call i_to_halton (seed, base, ndim, r) - - value_halton(1) = 1_pInt - call halton_memory ('INC', 'SEED', 1_pInt, value_halton) - -!-------------------------------------------------------------------------------------------------- - contains - - !------------------------------------------------------------------------------------------------- - !> @brief computes an element of a Halton sequence. - !> @details Only the absolute value of SEED is considered. SEED = 0 is allowed, and returns R = 0. - !> @details Halton Bases should be distinct prime numbers. This routine only checks that each base - !> @details is greater than 1. - !> @details Reference: - !> @details J.H. Halton: On the efficiency of certain quasi-random sequences of points in evaluating - !> @details multi-dimensional integrals, Numerische Mathematik, Volume 2, pages 84-90, 1960. - !> @author John Burkardt - !------------------------------------------------------------------------------------------------- - subroutine i_to_halton (seed, base, ndim, r) - use IO, only: & - IO_error +!> @author Martin Diehl +!> @details Incrementally increasing elements of the Halton sequence for given bases (> 0) +!> @details Reference: +!> @details J.H. Halton: On the efficiency of certain quasi-random sequences of points in evaluating +!> @details multi-dimensional integrals, Numerische Mathematik, Volume 2, pages 84-90, 1960. +!> @details Reference for prime numbers: +!> @details Milton Abramowitz and Irene Stegun: Handbook of Mathematical Functions, +!> @details US Department of Commerce, 1964, pages 870-873. +!> @details Daniel Zwillinger: CRC Standard Mathematical Tables and Formulae, +!> @details 30th Edition, CRC Press, 1996, pages 95-98. +!------------------------------------------------------------------------------------------------- +function halton(bases) - implicit none - integer(pInt), intent(in) :: & - ndim, & !< dimension of the sequence - seed !< index of the desired element - integer(pInt), intent(in), dimension(ndim) :: base !< Halton bases - real(pReal), intent(out), dimension(ndim) :: r !< the SEED-th element of the Halton sequence for the given bases - - real(pReal), dimension(ndim) :: base_inv - integer(pInt), dimension(ndim) :: & - digit, & - seed2 - - seed2 = abs(seed) - r = 0.0_pReal - - if (any (base(1:ndim) <= 1_pInt)) call IO_error(error_ID=405_pInt) - - base_inv(1:ndim) = 1.0_pReal / real (base(1:ndim), pReal) - - do while ( any ( seed2(1:ndim) /= 0_pInt) ) - digit(1:ndim) = mod ( seed2(1:ndim), base(1:ndim)) - r(1:ndim) = r(1:ndim) + real ( digit(1:ndim), pReal) * base_inv(1:ndim) - base_inv(1:ndim) = base_inv(1:ndim) / real ( base(1:ndim), pReal) - seed2(1:ndim) = seed2(1:ndim) / base(1:ndim) - enddo - - end subroutine i_to_halton - - -end subroutine halton - - -!-------------------------------------------------------------------------------------------------- -!> @brief sets or returns quantities associated with the Halton sequence. -!> @details If action_halton is 'SET' and action_halton is 'BASE', then NDIM is input, and -!> @details is the number of entries in value_halton to be put into BASE. -!> @details If action_halton is 'SET', then on input, value_halton contains values to be assigned -!> @details to the internal variable. -!> @details If action_halton is 'GET', then on output, value_halton contains the values of -!> @details the specified internal variable. -!> @details If action_halton is 'INC', then on input, value_halton contains the increment to -!> @details be added to the specified internal variable. -!> @author John Burkardt -!-------------------------------------------------------------------------------------------------- -subroutine halton_memory (action_halton, name_halton, ndim, value_halton) - use IO, only: & - IO_lc - implicit none - character(len = *), intent(in) :: & - action_halton, & !< desired action: GET the value of a particular quantity, SET the value of a particular quantity, INC the value of a particular quantity (only for SEED) - name_halton !< name of the quantity: BASE: Halton base(s), NDIM: spatial dimension, SEED: current Halton seed - integer(pInt), dimension(*), intent(inout) :: value_halton - integer(pInt), allocatable, save, dimension(:) :: base - logical, save :: first_call = .true. - integer(pInt), intent(in) :: ndim !< dimension of the quantity - integer(pInt), save :: ndim_save = 0_pInt, seed = 1_pInt - integer(pInt) :: i + integer(pInt), intent(in), dimension(:):: & + bases !< bases (prime number ID) + real(pReal), dimension(size(bases)) :: & + halton + integer(pInt), save :: & + current = 1_pInt + real(pReal), dimension(size(bases)) :: & + base_inv + integer(pInt), dimension(size(bases)) :: & + base, & + t + integer(pInt), dimension(0:1600), parameter :: & + prime = int([& + 1, & + 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, & + 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, & + 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, & + 127, 131, 137, 139, 149, 151, 157, 163, 167, 173, & + 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, & + 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, & + 283, 293, 307, 311, 313, 317, 331, 337, 347, 349, & + 353, 359, 367, 373, 379, 383, 389, 397, 401, 409, & + 419, 421, 431, 433, 439, 443, 449, 457, 461, 463, & + 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, & + ! 101:200 + 547, 557, 563, 569, 571, 577, 587, 593, 599, 601, & + 607, 613, 617, 619, 631, 641, 643, 647, 653, 659, & + 661, 673, 677, 683, 691, 701, 709, 719, 727, 733, & + 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, & + 811, 821, 823, 827, 829, 839, 853, 857, 859, 863, & + 877, 881, 883, 887, 907, 911, 919, 929, 937, 941, & + 947, 953, 967, 971, 977, 983, 991, 997, 1009, 1013, & + 1019, 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, & + 1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129, 1151, & + 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213, 1217, 1223, & + ! 201:300 + 1229, 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, & + 1297, 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, & + 1381, 1399, 1409, 1423, 1427, 1429, 1433, 1439, 1447, 1451, & + 1453, 1459, 1471, 1481, 1483, 1487, 1489, 1493, 1499, 1511, & + 1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, 1583, & + 1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, & + 1663, 1667, 1669, 1693, 1697, 1699, 1709, 1721, 1723, 1733, & + 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, 1801, 1811, & + 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, 1889, & + 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987, & + ! 301:400 + 1993, 1997, 1999, 2003, 2011, 2017, 2027, 2029, 2039, 2053, & + 2063, 2069, 2081, 2083, 2087, 2089, 2099, 2111, 2113, 2129, & + 2131, 2137, 2141, 2143, 2153, 2161, 2179, 2203, 2207, 2213, & + 2221, 2237, 2239, 2243, 2251, 2267, 2269, 2273, 2281, 2287, & + 2293, 2297, 2309, 2311, 2333, 2339, 2341, 2347, 2351, 2357, & + 2371, 2377, 2381, 2383, 2389, 2393, 2399, 2411, 2417, 2423, & + 2437, 2441, 2447, 2459, 2467, 2473, 2477, 2503, 2521, 2531, & + 2539, 2543, 2549, 2551, 2557, 2579, 2591, 2593, 2609, 2617, & + 2621, 2633, 2647, 2657, 2659, 2663, 2671, 2677, 2683, 2687, & + 2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, 2741, & + ! 401:500 + 2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, & + 2833, 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, & + 2909, 2917, 2927, 2939, 2953, 2957, 2963, 2969, 2971, 2999, & + 3001, 3011, 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, & + 3083, 3089, 3109, 3119, 3121, 3137, 3163, 3167, 3169, 3181, & + 3187, 3191, 3203, 3209, 3217, 3221, 3229, 3251, 3253, 3257, & + 3259, 3271, 3299, 3301, 3307, 3313, 3319, 3323, 3329, 3331, & + 3343, 3347, 3359, 3361, 3371, 3373, 3389, 3391, 3407, 3413, & + 3433, 3449, 3457, 3461, 3463, 3467, 3469, 3491, 3499, 3511, & + 3517, 3527, 3529, 3533, 3539, 3541, 3547, 3557, 3559, 3571, & + ! 501:600 + 3581, 3583, 3593, 3607, 3613, 3617, 3623, 3631, 3637, 3643, & + 3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, 3727, & + 3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, & + 3823, 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, & + 3911, 3917, 3919, 3923, 3929, 3931, 3943, 3947, 3967, 3989, & + 4001, 4003, 4007, 4013, 4019, 4021, 4027, 4049, 4051, 4057, & + 4073, 4079, 4091, 4093, 4099, 4111, 4127, 4129, 4133, 4139, & + 4153, 4157, 4159, 4177, 4201, 4211, 4217, 4219, 4229, 4231, & + 4241, 4243, 4253, 4259, 4261, 4271, 4273, 4283, 4289, 4297, & + 4327, 4337, 4339, 4349, 4357, 4363, 4373, 4391, 4397, 4409, & + ! 601:700 + 4421, 4423, 4441, 4447, 4451, 4457, 4463, 4481, 4483, 4493, & + 4507, 4513, 4517, 4519, 4523, 4547, 4549, 4561, 4567, 4583, & + 4591, 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657, & + 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, 4751, & + 4759, 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, & + 4861, 4871, 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, & + 4943, 4951, 4957, 4967, 4969, 4973, 4987, 4993, 4999, 5003, & + 5009, 5011, 5021, 5023, 5039, 5051, 5059, 5077, 5081, 5087, & + 5099, 5101, 5107, 5113, 5119, 5147, 5153, 5167, 5171, 5179, & + 5189, 5197, 5209, 5227, 5231, 5233, 5237, 5261, 5273, 5279, & + ! 701:800 + 5281, 5297, 5303, 5309, 5323, 5333, 5347, 5351, 5381, 5387, & + 5393, 5399, 5407, 5413, 5417, 5419, 5431, 5437, 5441, 5443, & + 5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519, 5521, & + 5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591, 5623, 5639, & + 5641, 5647, 5651, 5653, 5657, 5659, 5669, 5683, 5689, 5693, & + 5701, 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, 5791, & + 5801, 5807, 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, & + 5861, 5867, 5869, 5879, 5881, 5897, 5903, 5923, 5927, 5939, & + 5953, 5981, 5987, 6007, 6011, 6029, 6037, 6043, 6047, 6053, & + 6067, 6073, 6079, 6089, 6091, 6101, 6113, 6121, 6131, 6133, & + ! 801:900 + 6143, 6151, 6163, 6173, 6197, 6199, 6203, 6211, 6217, 6221, & + 6229, 6247, 6257, 6263, 6269, 6271, 6277, 6287, 6299, 6301, & + 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, 6361, 6367, & + 6373, 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, 6473, & + 6481, 6491, 6521, 6529, 6547, 6551, 6553, 6563, 6569, 6571, & + 6577, 6581, 6599, 6607, 6619, 6637, 6653, 6659, 6661, 6673, & + 6679, 6689, 6691, 6701, 6703, 6709, 6719, 6733, 6737, 6761, & + 6763, 6779, 6781, 6791, 6793, 6803, 6823, 6827, 6829, 6833, & + 6841, 6857, 6863, 6869, 6871, 6883, 6899, 6907, 6911, 6917, & + 6947, 6949, 6959, 6961, 6967, 6971, 6977, 6983, 6991, 6997, & + ! 901:1000 + 7001, 7013, 7019, 7027, 7039, 7043, 7057, 7069, 7079, 7103, & + 7109, 7121, 7127, 7129, 7151, 7159, 7177, 7187, 7193, 7207, & + 7211, 7213, 7219, 7229, 7237, 7243, 7247, 7253, 7283, 7297, & + 7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, 7393, 7411, & + 7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, 7499, & + 7507, 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, & + 7573, 7577, 7583, 7589, 7591, 7603, 7607, 7621, 7639, 7643, & + 7649, 7669, 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, & + 7727, 7741, 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829, & + 7841, 7853, 7867, 7873, 7877, 7879, 7883, 7901, 7907, 7919, & + ! 1001:1100 + 7927, 7933, 7937, 7949, 7951, 7963, 7993, 8009, 8011, 8017, & + 8039, 8053, 8059, 8069, 8081, 8087, 8089, 8093, 8101, 8111, & + 8117, 8123, 8147, 8161, 8167, 8171, 8179, 8191, 8209, 8219, & + 8221, 8231, 8233, 8237, 8243, 8263, 8269, 8273, 8287, 8291, & + 8293, 8297, 8311, 8317, 8329, 8353, 8363, 8369, 8377, 8387, & + 8389, 8419, 8423, 8429, 8431, 8443, 8447, 8461, 8467, 8501, & + 8513, 8521, 8527, 8537, 8539, 8543, 8563, 8573, 8581, 8597, & + 8599, 8609, 8623, 8627, 8629, 8641, 8647, 8663, 8669, 8677, & + 8681, 8689, 8693, 8699, 8707, 8713, 8719, 8731, 8737, 8741, & + 8747, 8753, 8761, 8779, 8783, 8803, 8807, 8819, 8821, 8831, & + ! 1101:1200 + 8837, 8839, 8849, 8861, 8863, 8867, 8887, 8893, 8923, 8929, & + 8933, 8941, 8951, 8963, 8969, 8971, 8999, 9001, 9007, 9011, & + 9013, 9029, 9041, 9043, 9049, 9059, 9067, 9091, 9103, 9109, & + 9127, 9133, 9137, 9151, 9157, 9161, 9173, 9181, 9187, 9199, & + 9203, 9209, 9221, 9227, 9239, 9241, 9257, 9277, 9281, 9283, & + 9293, 9311, 9319, 9323, 9337, 9341, 9343, 9349, 9371, 9377, & + 9391, 9397, 9403, 9413, 9419, 9421, 9431, 9433, 9437, 9439, & + 9461, 9463, 9467, 9473, 9479, 9491, 9497, 9511, 9521, 9533, & + 9539, 9547, 9551, 9587, 9601, 9613, 9619, 9623, 9629, 9631, & + 9643, 9649, 9661, 9677, 9679, 9689, 9697, 9719, 9721, 9733, & + ! 1201:1300 + 9739, 9743, 9749, 9767, 9769, 9781, 9787, 9791, 9803, 9811, & + 9817, 9829, 9833, 9839, 9851, 9857, 9859, 9871, 9883, 9887, & + 9901, 9907, 9923, 9929, 9931, 9941, 9949, 9967, 9973, 10007, & + 10009, 10037, 10039, 10061, 10067, 10069, 10079, 10091, 10093, 10099, & + 10103, 10111, 10133, 10139, 10141, 10151, 10159, 10163, 10169, 10177, & + 10181, 10193, 10211, 10223, 10243, 10247, 10253, 10259, 10267, 10271, & + 10273, 10289, 10301, 10303, 10313, 10321, 10331, 10333, 10337, 10343, & + 10357, 10369, 10391, 10399, 10427, 10429, 10433, 10453, 10457, 10459, & + 10463, 10477, 10487, 10499, 10501, 10513, 10529, 10531, 10559, 10567, & + 10589, 10597, 10601, 10607, 10613, 10627, 10631, 10639, 10651, 10657, & + ! 1301:1400 + 10663, 10667, 10687, 10691, 10709, 10711, 10723, 10729, 10733, 10739, & + 10753, 10771, 10781, 10789, 10799, 10831, 10837, 10847, 10853, 10859, & + 10861, 10867, 10883, 10889, 10891, 10903, 10909, 10937, 10939, 10949, & + 10957, 10973, 10979, 10987, 10993, 11003, 11027, 11047, 11057, 11059, & + 11069, 11071, 11083, 11087, 11093, 11113, 11117, 11119, 11131, 11149, & + 11159, 11161, 11171, 11173, 11177, 11197, 11213, 11239, 11243, 11251, & + 11257, 11261, 11273, 11279, 11287, 11299, 11311, 11317, 11321, 11329, & + 11351, 11353, 11369, 11383, 11393, 11399, 11411, 11423, 11437, 11443, & + 11447, 11467, 11471, 11483, 11489, 11491, 11497, 11503, 11519, 11527, & + 11549, 11551, 11579, 11587, 11593, 11597, 11617, 11621, 11633, 11657, & + ! 1401:1500 + 11677, 11681, 11689, 11699, 11701, 11717, 11719, 11731, 11743, 11777, & + 11779, 11783, 11789, 11801, 11807, 11813, 11821, 11827, 11831, 11833, & + 11839, 11863, 11867, 11887, 11897, 11903, 11909, 11923, 11927, 11933, & + 11939, 11941, 11953, 11959, 11969, 11971, 11981, 11987, 12007, 12011, & + 12037, 12041, 12043, 12049, 12071, 12073, 12097, 12101, 12107, 12109, & + 12113, 12119, 12143, 12149, 12157, 12161, 12163, 12197, 12203, 12211, & + 12227, 12239, 12241, 12251, 12253, 12263, 12269, 12277, 12281, 12289, & + 12301, 12323, 12329, 12343, 12347, 12373, 12377, 12379, 12391, 12401, & + 12409, 12413, 12421, 12433, 12437, 12451, 12457, 12473, 12479, 12487, & + 12491, 12497, 12503, 12511, 12517, 12527, 12539, 12541, 12547, 12553, & + ! 1501:1600 + 12569, 12577, 12583, 12589, 12601, 12611, 12613, 12619, 12637, 12641, & + 12647, 12653, 12659, 12671, 12689, 12697, 12703, 12713, 12721, 12739, & + 12743, 12757, 12763, 12781, 12791, 12799, 12809, 12821, 12823, 12829, & + 12841, 12853, 12889, 12893, 12899, 12907, 12911, 12917, 12919, 12923, & + 12941, 12953, 12959, 12967, 12973, 12979, 12983, 13001, 13003, 13007, & + 13009, 13033, 13037, 13043, 13049, 13063, 13093, 13099, 13103, 13109, & + 13121, 13127, 13147, 13151, 13159, 13163, 13171, 13177, 13183, 13187, & + 13217, 13219, 13229, 13241, 13249, 13259, 13267, 13291, 13297, 13309, & + 13313, 13327, 13331, 13337, 13339, 13367, 13381, 13397, 13399, 13411, & + 13417, 13421, 13441, 13451, 13457, 13463, 13469, 13477, 13487, 13499],pInt) - if (first_call) then - ndim_save = 1_pInt - allocate(base(ndim_save)) - base(1) = 2_pInt - first_call = .false. - endif + current = current + 1_pInt + + base = prime(bases) + base_inv = 1.0_pReal/real(base,pReal) + + halton = 0.0_pReal + t = current + + do while (any( t /= 0_pInt) ) + halton = halton + real(mod(t,base), pReal) * base_inv + base_inv = base_inv / real(base, pReal) + t = t / base + enddo -!-------------------------------------------------------------------------------------------------- -! Set - actionHalton: if(IO_lc(action_halton(1:1)) == 's') then - - nameSet: if(IO_lc(name_halton(1:1)) == 'b') then - if(ndim_save /= ndim) ndim_save = ndim - base = value_halton(1:ndim) - elseif(IO_lc(name_halton(1:1)) == 'n') then nameSet - if(ndim_save /= value_halton(1)) then - ndim_save = value_halton(1) - base = [(prime(i),i=1_pInt,ndim_save)] - else - ndim_save = value_halton(1) - endif - elseif(IO_lc(name_halton(1:1)) == 's') then nameSet - seed = value_halton(1) - endif nameSet - -!-------------------------------------------------------------------------------------------------- -! Get - elseif(IO_lc(action_halton(1:1)) == 'g') then actionHalton - nameGet: if(IO_lc(name_halton(1:1)) == 'b') then - if(ndim /= ndim_save) then - ndim_save = ndim - base = [(prime(i),i=1_pInt,ndim_save)] - endif - value_halton(1:ndim_save) = base(1:ndim_save) - elseif(IO_lc(name_halton(1:1)) == 'n') then nameGet - value_halton(1) = ndim_save - elseif(IO_lc(name_halton(1:1)) == 's') then nameGet - value_halton(1) = seed - endif nameGet - -!-------------------------------------------------------------------------------------------------- -! Increment - elseif(IO_lc(action_halton(1:1)) == 'i') then actionHalton - if(IO_lc(name_halton(1:1)) == 's') seed = seed + value_halton(1) - endif actionHalton - -!-------------------------------------------------------------------------------------------------- - contains - - !-------------------------------------------------------------------------------------------------- - !> @brief returns any of the first 1500 prime numbers. - !> @details n = 0 is legal, returning PRIME = 1. - !> @details Reference: - !> @details Milton Abramowitz and Irene Stegun: Handbook of Mathematical Functions, - !> @details US Department of Commerce, 1964, pages 870-873. - !> @details Daniel Zwillinger: CRC Standard Mathematical Tables and Formulae, - !> @details 30th Edition, CRC Press, 1996, pages 95-98. - !> @author John Burkardt - !-------------------------------------------------------------------------------------------------- - integer(pInt) function prime(n) - use IO, only: & - IO_error - - implicit none - integer(pInt), intent(in) :: n !< index of the desired prime number - integer(pInt), dimension(0:1500), parameter :: & - npvec = int([& - 1, & - 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, & - 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, & - 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, & - 127, 131, 137, 139, 149, 151, 157, 163, 167, 173, & - 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, & - 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, & - 283, 293, 307, 311, 313, 317, 331, 337, 347, 349, & - 353, 359, 367, 373, 379, 383, 389, 397, 401, 409, & - 419, 421, 431, 433, 439, 443, 449, 457, 461, 463, & - 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, & - ! 101:200 - 547, 557, 563, 569, 571, 577, 587, 593, 599, 601, & - 607, 613, 617, 619, 631, 641, 643, 647, 653, 659, & - 661, 673, 677, 683, 691, 701, 709, 719, 727, 733, & - 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, & - 811, 821, 823, 827, 829, 839, 853, 857, 859, 863, & - 877, 881, 883, 887, 907, 911, 919, 929, 937, 941, & - 947, 953, 967, 971, 977, 983, 991, 997, 1009, 1013, & - 1019, 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, & - 1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129, 1151, & - 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213, 1217, 1223, & - ! 201:300 - 1229, 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, & - 1297, 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, & - 1381, 1399, 1409, 1423, 1427, 1429, 1433, 1439, 1447, 1451, & - 1453, 1459, 1471, 1481, 1483, 1487, 1489, 1493, 1499, 1511, & - 1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, 1583, & - 1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, & - 1663, 1667, 1669, 1693, 1697, 1699, 1709, 1721, 1723, 1733, & - 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, 1801, 1811, & - 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, 1889, & - 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987, & - ! 301:400 - 1993, 1997, 1999, 2003, 2011, 2017, 2027, 2029, 2039, 2053, & - 2063, 2069, 2081, 2083, 2087, 2089, 2099, 2111, 2113, 2129, & - 2131, 2137, 2141, 2143, 2153, 2161, 2179, 2203, 2207, 2213, & - 2221, 2237, 2239, 2243, 2251, 2267, 2269, 2273, 2281, 2287, & - 2293, 2297, 2309, 2311, 2333, 2339, 2341, 2347, 2351, 2357, & - 2371, 2377, 2381, 2383, 2389, 2393, 2399, 2411, 2417, 2423, & - 2437, 2441, 2447, 2459, 2467, 2473, 2477, 2503, 2521, 2531, & - 2539, 2543, 2549, 2551, 2557, 2579, 2591, 2593, 2609, 2617, & - 2621, 2633, 2647, 2657, 2659, 2663, 2671, 2677, 2683, 2687, & - 2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, 2741, & - ! 401:500 - 2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, & - 2833, 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, & - 2909, 2917, 2927, 2939, 2953, 2957, 2963, 2969, 2971, 2999, & - 3001, 3011, 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, & - 3083, 3089, 3109, 3119, 3121, 3137, 3163, 3167, 3169, 3181, & - 3187, 3191, 3203, 3209, 3217, 3221, 3229, 3251, 3253, 3257, & - 3259, 3271, 3299, 3301, 3307, 3313, 3319, 3323, 3329, 3331, & - 3343, 3347, 3359, 3361, 3371, 3373, 3389, 3391, 3407, 3413, & - 3433, 3449, 3457, 3461, 3463, 3467, 3469, 3491, 3499, 3511, & - 3517, 3527, 3529, 3533, 3539, 3541, 3547, 3557, 3559, 3571, & - ! 501:600 - 3581, 3583, 3593, 3607, 3613, 3617, 3623, 3631, 3637, 3643, & - 3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, 3727, & - 3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, & - 3823, 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, & - 3911, 3917, 3919, 3923, 3929, 3931, 3943, 3947, 3967, 3989, & - 4001, 4003, 4007, 4013, 4019, 4021, 4027, 4049, 4051, 4057, & - 4073, 4079, 4091, 4093, 4099, 4111, 4127, 4129, 4133, 4139, & - 4153, 4157, 4159, 4177, 4201, 4211, 4217, 4219, 4229, 4231, & - 4241, 4243, 4253, 4259, 4261, 4271, 4273, 4283, 4289, 4297, & - 4327, 4337, 4339, 4349, 4357, 4363, 4373, 4391, 4397, 4409, & - ! 601:700 - 4421, 4423, 4441, 4447, 4451, 4457, 4463, 4481, 4483, 4493, & - 4507, 4513, 4517, 4519, 4523, 4547, 4549, 4561, 4567, 4583, & - 4591, 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657, & - 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, 4751, & - 4759, 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, & - 4861, 4871, 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, & - 4943, 4951, 4957, 4967, 4969, 4973, 4987, 4993, 4999, 5003, & - 5009, 5011, 5021, 5023, 5039, 5051, 5059, 5077, 5081, 5087, & - 5099, 5101, 5107, 5113, 5119, 5147, 5153, 5167, 5171, 5179, & - 5189, 5197, 5209, 5227, 5231, 5233, 5237, 5261, 5273, 5279, & - ! 701:800 - 5281, 5297, 5303, 5309, 5323, 5333, 5347, 5351, 5381, 5387, & - 5393, 5399, 5407, 5413, 5417, 5419, 5431, 5437, 5441, 5443, & - 5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519, 5521, & - 5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591, 5623, 5639, & - 5641, 5647, 5651, 5653, 5657, 5659, 5669, 5683, 5689, 5693, & - 5701, 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, 5791, & - 5801, 5807, 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, & - 5861, 5867, 5869, 5879, 5881, 5897, 5903, 5923, 5927, 5939, & - 5953, 5981, 5987, 6007, 6011, 6029, 6037, 6043, 6047, 6053, & - 6067, 6073, 6079, 6089, 6091, 6101, 6113, 6121, 6131, 6133, & - ! 801:900 - 6143, 6151, 6163, 6173, 6197, 6199, 6203, 6211, 6217, 6221, & - 6229, 6247, 6257, 6263, 6269, 6271, 6277, 6287, 6299, 6301, & - 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, 6361, 6367, & - 6373, 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, 6473, & - 6481, 6491, 6521, 6529, 6547, 6551, 6553, 6563, 6569, 6571, & - 6577, 6581, 6599, 6607, 6619, 6637, 6653, 6659, 6661, 6673, & - 6679, 6689, 6691, 6701, 6703, 6709, 6719, 6733, 6737, 6761, & - 6763, 6779, 6781, 6791, 6793, 6803, 6823, 6827, 6829, 6833, & - 6841, 6857, 6863, 6869, 6871, 6883, 6899, 6907, 6911, 6917, & - 6947, 6949, 6959, 6961, 6967, 6971, 6977, 6983, 6991, 6997, & - ! 901:1000 - 7001, 7013, 7019, 7027, 7039, 7043, 7057, 7069, 7079, 7103, & - 7109, 7121, 7127, 7129, 7151, 7159, 7177, 7187, 7193, 7207, & - 7211, 7213, 7219, 7229, 7237, 7243, 7247, 7253, 7283, 7297, & - 7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, 7393, 7411, & - 7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, 7499, & - 7507, 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, & - 7573, 7577, 7583, 7589, 7591, 7603, 7607, 7621, 7639, 7643, & - 7649, 7669, 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, & - 7727, 7741, 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829, & - 7841, 7853, 7867, 7873, 7877, 7879, 7883, 7901, 7907, 7919, & - ! 1001:1100 - 7927, 7933, 7937, 7949, 7951, 7963, 7993, 8009, 8011, 8017, & - 8039, 8053, 8059, 8069, 8081, 8087, 8089, 8093, 8101, 8111, & - 8117, 8123, 8147, 8161, 8167, 8171, 8179, 8191, 8209, 8219, & - 8221, 8231, 8233, 8237, 8243, 8263, 8269, 8273, 8287, 8291, & - 8293, 8297, 8311, 8317, 8329, 8353, 8363, 8369, 8377, 8387, & - 8389, 8419, 8423, 8429, 8431, 8443, 8447, 8461, 8467, 8501, & - 8513, 8521, 8527, 8537, 8539, 8543, 8563, 8573, 8581, 8597, & - 8599, 8609, 8623, 8627, 8629, 8641, 8647, 8663, 8669, 8677, & - 8681, 8689, 8693, 8699, 8707, 8713, 8719, 8731, 8737, 8741, & - 8747, 8753, 8761, 8779, 8783, 8803, 8807, 8819, 8821, 8831, & - ! 1101:1200 - 8837, 8839, 8849, 8861, 8863, 8867, 8887, 8893, 8923, 8929, & - 8933, 8941, 8951, 8963, 8969, 8971, 8999, 9001, 9007, 9011, & - 9013, 9029, 9041, 9043, 9049, 9059, 9067, 9091, 9103, 9109, & - 9127, 9133, 9137, 9151, 9157, 9161, 9173, 9181, 9187, 9199, & - 9203, 9209, 9221, 9227, 9239, 9241, 9257, 9277, 9281, 9283, & - 9293, 9311, 9319, 9323, 9337, 9341, 9343, 9349, 9371, 9377, & - 9391, 9397, 9403, 9413, 9419, 9421, 9431, 9433, 9437, 9439, & - 9461, 9463, 9467, 9473, 9479, 9491, 9497, 9511, 9521, 9533, & - 9539, 9547, 9551, 9587, 9601, 9613, 9619, 9623, 9629, 9631, & - 9643, 9649, 9661, 9677, 9679, 9689, 9697, 9719, 9721, 9733, & - ! 1201:1300 - 9739, 9743, 9749, 9767, 9769, 9781, 9787, 9791, 9803, 9811, & - 9817, 9829, 9833, 9839, 9851, 9857, 9859, 9871, 9883, 9887, & - 9901, 9907, 9923, 9929, 9931, 9941, 9949, 9967, 9973, 10007, & - 10009, 10037, 10039, 10061, 10067, 10069, 10079, 10091, 10093, 10099, & - 10103, 10111, 10133, 10139, 10141, 10151, 10159, 10163, 10169, 10177, & - 10181, 10193, 10211, 10223, 10243, 10247, 10253, 10259, 10267, 10271, & - 10273, 10289, 10301, 10303, 10313, 10321, 10331, 10333, 10337, 10343, & - 10357, 10369, 10391, 10399, 10427, 10429, 10433, 10453, 10457, 10459, & - 10463, 10477, 10487, 10499, 10501, 10513, 10529, 10531, 10559, 10567, & - 10589, 10597, 10601, 10607, 10613, 10627, 10631, 10639, 10651, 10657, & - ! 1301:1400 - 10663, 10667, 10687, 10691, 10709, 10711, 10723, 10729, 10733, 10739, & - 10753, 10771, 10781, 10789, 10799, 10831, 10837, 10847, 10853, 10859, & - 10861, 10867, 10883, 10889, 10891, 10903, 10909, 19037, 10939, 10949, & - 10957, 10973, 10979, 10987, 10993, 11003, 11027, 11047, 11057, 11059, & - 11069, 11071, 11083, 11087, 11093, 11113, 11117, 11119, 11131, 11149, & - 11159, 11161, 11171, 11173, 11177, 11197, 11213, 11239, 11243, 11251, & - 11257, 11261, 11273, 11279, 11287, 11299, 11311, 11317, 11321, 11329, & - 11351, 11353, 11369, 11383, 11393, 11399, 11411, 11423, 11437, 11443, & - 11447, 11467, 11471, 11483, 11489, 11491, 11497, 11503, 11519, 11527, & - 11549, 11551, 11579, 11587, 11593, 11597, 11617, 11621, 11633, 11657, & - ! 1401:1500 - 11677, 11681, 11689, 11699, 11701, 11717, 11719, 11731, 11743, 11777, & - 11779, 11783, 11789, 11801, 11807, 11813, 11821, 11827, 11831, 11833, & - 11839, 11863, 11867, 11887, 11897, 11903, 11909, 11923, 11927, 11933, & - 11939, 11941, 11953, 11959, 11969, 11971, 11981, 11987, 12007, 12011, & - 12037, 12041, 12043, 12049, 12071, 12073, 12097, 12101, 12107, 12109, & - 12113, 12119, 12143, 12149, 12157, 12161, 12163, 12197, 12203, 12211, & - 12227, 12239, 12241, 12251, 12253, 12263, 12269, 12277, 12281, 12289, & - 12301, 12323, 12329, 12343, 12347, 12373, 12377, 12379, 12391, 12401, & - 12409, 12413, 12421, 12433, 12437, 12451, 12457, 12473, 12479, 12487, & - 12491, 12497, 12503, 12511, 12517, 12527, 12539, 12541, 12547, 12553],pInt) - - if (n < size(npvec)) then - prime = npvec(n) - else - call IO_error(error_ID=406_pInt) - end if - - end function prime - -end subroutine halton_memory - - -!-------------------------------------------------------------------------------------------------- -!> @brief sets the dimension for a Halton sequence -!> @author John Burkardt -!-------------------------------------------------------------------------------------------------- -subroutine halton_ndim_set(ndim) - - implicit none - integer(pInt), intent(in) :: ndim !< dimension of the Halton vectors - integer(pInt) :: value_halton(1) - - value_halton(1) = ndim - call halton_memory ('SET', 'NDIM', 1_pInt, value_halton) - -end subroutine halton_ndim_set - - -!-------------------------------------------------------------------------------------------------- -!> @brief sets the seed for the Halton sequence. -!> @details Calling HALTON repeatedly returns the elements of the Halton sequence in order, -!> @details starting with element number 1. -!> @details An internal counter, called SEED, keeps track of the next element to return. Each time -!> @details is computed, and then SEED is incremented by 1. -!> @details To restart the Halton sequence, it is only necessary to reset SEED to 1. It might also -!> @details be desirable to reset SEED to some other value. This routine allows the user to specify -!> @details any value of SEED. -!> @details The default value of SEED is 1, which restarts the Halton sequence. -!> @author John Burkardt -!-------------------------------------------------------------------------------------------------- -subroutine halton_seed_set(seed) - implicit none - - integer(pInt), parameter :: NDIM = 1_pInt - integer(pInt), intent(in) :: seed !< seed for the Halton sequence. - integer(pInt) :: value_halton(ndim) - - value_halton(1) = seed - call halton_memory ('SET', 'SEED', NDIM, value_halton) - -end subroutine halton_seed_set +end function halton !-------------------------------------------------------------------------------------------------- @@ -2823,5 +2635,136 @@ real(pReal) pure function math_limit(a, left, right) math_limit = merge (IEEE_value(1.0_pReal,IEEE_quiet_NaN),math_limit, left>right) end function math_limit + + +!-------------------------------------------------------------------------------------------------- +!> @brief Modified Bessel I function of order 0 +!> @author John Burkardt +!> @details original version available on https://people.sc.fsu.edu/~jburkardt/f_src/toms715/toms715.html +!-------------------------------------------------------------------------------------------------- +real(pReal) function bessel_i0 (x) + use, intrinsic :: IEEE_ARITHMETIC + + implicit none + real(pReal), intent(in) :: x + integer(pInt) :: i + real(pReal) :: sump_p, sump_q, xAbs, xx + real(pReal), parameter, dimension(15) :: p_small = real( & + [-5.2487866627945699800e-18, -1.5982226675653184646e-14, -2.6843448573468483278e-11, & + -3.0517226450451067446e-08, -2.5172644670688975051e-05, -1.5453977791786851041e-02, & + -7.0935347449210549190e+00, -2.4125195876041896775e+03, -5.9545626019847898221e+05, & + -1.0313066708737980747e+08, -1.1912746104985237192e+10, -8.4925101247114157499e+11, & + -3.2940087627407749166e+13, -5.5050369673018427753e+14, -2.2335582639474375249e+15], pReal) + real(pReal), parameter, dimension(5) :: q_small = real( & + [-3.7277560179962773046e+03, 6.5158506418655165707e+06, -6.5626560740833869295e+09, & + 3.7604188704092954661e+12, -9.7087946179594019126e+14], pReal) + real(pReal), parameter, dimension(8) :: p_large = real( & + [-3.9843750000000000000e-01, 2.9205384596336793945e+00, -2.4708469169133954315e+00, & + 4.7914889422856814203e-01, -3.7384991926068969150e-03, -2.6801520353328635310e-03, & + 9.9168777670983678974e-05, -2.1877128189032726730e-06], pReal) + real(pReal), parameter, dimension(7) :: q_large = real( & + [-3.1446690275135491500e+01, 8.5539563258012929600e+01, -6.0228002066743340583e+01, & + 1.3982595353892851542e+01, -1.1151759188741312645e+00, 3.2547697594819615062e-02, & + -5.5194330231005480228e-04], pReal) + + + xAbs = abs(x) + + argRange: if (xAbs < 5.55e-17_pReal) then + bessel_i0 = 1.0_pReal + else if (xAbs < 15.0_pReal) then argRange + xx = xAbs**2.0_pReal + sump_p = p_small(1) + do i = 2, 15 + sump_p = sump_p * xx + p_small(i) + end do + xx = xx - 225.0_pReal + sump_q = ((((xx+q_small(1))*xx+q_small(2))*xx+q_small(3))*xx+q_small(4))*xx+q_small(5) + bessel_i0 = sump_p / sump_q + else if (xAbs <= 713.986_pReal) then argRange + xx = 1.0_pReal / xAbs - 2.0_pReal/30.0_pReal + sump_p = ((((((p_large(1)*xx+p_large(2))*xx+p_large(3))*xx+p_large(4))*xx+ & + p_large(5))*xx+p_large(6))*xx+p_large(7))*xx+p_large(8) + sump_q = ((((((xx+q_large(1))*xx+q_large(2))*xx+q_large(3))*xx+ & + q_large(4))*xx+q_large(5))*xx+q_large(6))*xx+q_large(7) + bessel_i0 = sump_p / sump_q + + avoidOverflow: if (xAbs > 698.986_pReal) then + bessel_i0 = ((bessel_i0*exp(xAbs-40.0_pReal)-p_large(1)*exp(xAbs-40.0_pReal))/sqrt(xAbs))*exp(40.0) + else avoidOverflow + bessel_i0 = ((bessel_i0*exp(xAbs)-p_large(1)*exp(xAbs))/sqrt(xAbs)) + endif avoidOverflow + + else argRange + bessel_i0 = IEEE_value(bessel_i0,IEEE_positive_inf) + end if argRange + +end function bessel_i0 + + +!-------------------------------------------------------------------------------------------------- +!> @brief Modified Bessel I function of order 1 +!> @author John Burkardt +!> @details original version available on https://people.sc.fsu.edu/~jburkardt/f_src/toms715/toms715.html +!-------------------------------------------------------------------------------------------------- +real(pReal) function bessel_i1 (x) + use, intrinsic :: IEEE_ARITHMETIC + + implicit none + real(pReal), intent(in) :: x + integer(pInt) :: i + real(pReal) :: sump_p, sump_q, xAbs, xx + real(pReal), dimension(15), parameter :: p_small = real( & + [-1.9705291802535139930e-19, -6.5245515583151902910e-16, -1.1928788903603238754e-12, & + -1.4831904935994647675e-09, -1.3466829827635152875e-06, -9.1746443287817501309e-04, & + -4.7207090827310162436e-01, -1.8225946631657315931e+02, -5.1894091982308017540e+04, & + -1.0588550724769347106e+07, -1.4828267606612366099e+09, -1.3357437682275493024e+11, & + -6.9876779648010090070e+12, -1.7732037840791591320e+14, -1.4577180278143463643e+15], pReal) + real(pReal), dimension(5), parameter :: q_small = real( & + [-4.0076864679904189921e+03, 7.4810580356655069138e+06, -8.0059518998619764991e+09, & + 4.8544714258273622913e+12, -1.3218168307321442305e+15], pReal) + real(pReal), dimension(8), parameter :: p_large = real( & + [-6.0437159056137600000e-02, 4.5748122901933459000e-01, -4.2843766903304806403e-01, & + 9.7356000150886612134e-02, -3.2457723974465568321e-03, -3.6395264712121795296e-04, & + 1.6258661867440836395e-05, -3.6347578404608223492e-07], pReal) + real(pReal), dimension(6), parameter :: q_large = real( & + [-3.8806586721556593450e+00, 3.2593714889036996297e+00, -8.5017476463217924408e-01, & + 7.4212010813186530069e-02, -2.2835624489492512649e-03, 3.7510433111922824643e-05], pReal) + real(pReal), parameter :: pbar = 3.98437500e-01 + + + xAbs = abs(x) + + argRange: if (xAbs < 5.55e-17_pReal) then + bessel_i1 = 0.5_pReal * xAbs + else if (xAbs < 15.0_pReal) then argRange + xx = xAbs**2.0_pReal + sump_p = p_small(1) + do i = 2, 15 + sump_p = sump_p * xx + p_small(i) + end do + xx = xx - 225.0_pReal + sump_q = ((((xx+q_small(1))*xx+q_small(2))*xx+q_small(3))*xx+q_small(4)) * xx + q_small(5) + bessel_i1 = (sump_p / sump_q) * xAbs + else if (xAbs <= 713.986_pReal) then argRange + xx = 1.0_pReal / xAbs - 2.0_pReal/30.0_pReal + sump_p = ((((((p_large(1)*xx+p_large(2))*xx+p_large(3))*xx+p_large(4))*xx+& + p_large(5))*xx+p_large(6))*xx+p_large(7))*xx+p_large(8) + sump_q = (((((xx+q_large(1))*xx+q_large(2))*xx+q_large(3))*xx+ q_large(4))*xx+q_large(5))*xx+q_large(6) + bessel_i1 = sump_p / sump_q + + avoidOverflow: if (xAbs > 698.986_pReal) then + bessel_i1 = ((bessel_i1 * exp(xAbs-40.0_pReal) + pbar * exp(xAbs-40.0_pReal)) / sqrt(xAbs)) * exp(40.0_pReal) + else avoidOverflow + bessel_i1 = ((bessel_i1 * exp(xAbs) + pbar * exp(xAbs)) / sqrt(xAbs)) + endif avoidOverflow + + else argRange + bessel_i1 = IEEE_value(bessel_i1,IEEE_positive_inf) + end if argRange + + if (x < 0.0_pReal) bessel_i1 = -bessel_i1 + +end function bessel_i1 end module math diff --git a/src/mesh.f90 b/src/mesh.f90 index 74bb55a3b..d5930490a 100644 --- a/src/mesh.f90 +++ b/src/mesh.f90 @@ -118,11 +118,6 @@ module mesh logical, private :: noPart !< for cases where the ABAQUS input file does not use part/assembly information #endif -#ifdef Spectral -#include - include 'fftw3-mpi.f03' -#endif - ! These definitions should actually reside in the FE-solver specific part (different for MARC/ABAQUS) ! Hence, I suggest to prefix with "FE_" @@ -481,6 +476,10 @@ subroutine mesh_init(ip,el) use, intrinsic :: iso_fortran_env, only: & compiler_version, & compiler_options +#endif +#ifdef Spectral +#include + use PETScsys #endif use DAMASK_interface use IO, only: & @@ -516,6 +515,7 @@ subroutine mesh_init(ip,el) implicit none #ifdef Spectral + include 'fftw3-mpi.f03' integer(C_INTPTR_T) :: devNull, local_K, local_K_offset integer :: ierr, worldsize #endif @@ -524,8 +524,6 @@ subroutine mesh_init(ip,el) integer(pInt) :: j logical :: myDebug - external :: MPI_comm_size - write(6,'(/,a)') ' <<<+- mesh init -+>>>' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" diff --git a/src/numerics.f90 b/src/numerics.f90 index c854d9d2b..27b04cd67 100644 --- a/src/numerics.f90 +++ b/src/numerics.f90 @@ -10,9 +10,6 @@ module numerics implicit none private -#ifdef PETSc -#include -#endif character(len=64), parameter, private :: & numerics_CONFIGFILE = 'numerics.config' !< name of configuration file @@ -111,7 +108,7 @@ module numerics character(len=64), private :: & fftw_plan_mode = 'FFTW_PATIENT' !< reads the planing-rigor flag, see manual on www.fftw.org, Default FFTW_PATIENT: use patient planner flag character(len=64), protected, public :: & - spectral_solver = 'basicpetsc' , & !< spectral solution method + spectral_solver = 'basic', & !< spectral solution method spectral_derivative = 'continuous' !< spectral spatial derivative method character(len=1024), protected, public :: & petsc_defaultOptions = '-mech_snes_type ngmres & @@ -216,6 +213,10 @@ subroutine numerics_init IO_warning, & IO_timeStamp, & IO_EOF +#ifdef PETSc +#include + use petscsys +#endif #if defined(Spectral) || defined(FEM) !$ use OMP_LIB, only: omp_set_num_threads ! Use the standard conforming module file for omp if using the spectral solver implicit none @@ -232,9 +233,7 @@ subroutine numerics_init line !$ character(len=6) DAMASK_NumThreadsString ! environment variable DAMASK_NUM_THREADS external :: & - MPI_Comm_rank, & - MPI_Comm_size, & - MPI_Abort + PETScErrorF ! is called in the CHKERRQ macro #ifdef PETSc call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 4679d654d..ad62ed398 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -53,7 +53,7 @@ module plastic_isotropic dilatation = .false. end type - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) + type(tParameters), dimension(:), allocatable, target, private :: param !< containers of constitutive parameters (len Ninstance) type, private :: tIsotropicState !< internal state aliases real(pReal), pointer, dimension(:) :: & ! scalars along NipcMyInstance @@ -61,20 +61,10 @@ module plastic_isotropic accumulatedShear end type - type, private :: tIsotropicAbsTol !< internal alias for abs tolerance in state - real(pReal), pointer :: & ! scalars along NipcMyInstance - flowstress, & - accumulatedShear - end type - type(tIsotropicState), allocatable, dimension(:), private :: & !< state aliases per instance state, & - state0, & dotState - type(tIsotropicAbsTol), allocatable, dimension(:), private :: & !< state aliases per instance - stateAbsTol - public :: & plastic_isotropic_init, & plastic_isotropic_LpAndItsTangent, & @@ -130,6 +120,7 @@ subroutine plastic_isotropic_init(fileUnit) implicit none integer(pInt), intent(in) :: fileUnit + type(tParameters), pointer :: p integer(pInt), allocatable, dimension(:) :: chunkPos integer(pInt) :: & @@ -150,8 +141,6 @@ subroutine plastic_isotropic_init(fileUnit) integer(pInt) :: NipcMyPhase write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_ISOTROPIC_label//' init -+>>>' - write(6,'(/,a)') ' Ma et al., Computational Materials Science, 109:323–329, 2015' - write(6,'(/,a)') ' https://doi.org/10.1016/j.commatsci.2015.07.041' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" @@ -184,14 +173,11 @@ subroutine plastic_isotropic_init(fileUnit) endif if (IO_getTag(line,'[',']') /= '') then ! next section phase = phase + 1_pInt ! advance section counter - if (phase_plasticity(phase) == PLASTICITY_ISOTROPIC_ID) then - instance = phase_plasticityInstance(phase) ! count instances of my constitutive law - allocate(param(instance)%outputID(phase_Noutput(phase))) ! allocate space for IDs of every requested output - endif cycle ! skip to next line endif if (phase > 0_pInt) then; if (phase_plasticity(phase) == PLASTICITY_ISOTROPIC_ID) then ! one of my phases. Do not short-circuit here (.and. between if-statements), it's not safe in Fortran instance = phase_plasticityInstance(phase) ! which instance of my plasticity is present phase + p => param(instance) ! shorthand pointer to parameter object of my constitutive law chunkPos = IO_stringPos(line) tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key @@ -201,58 +187,58 @@ subroutine plastic_isotropic_init(fileUnit) select case(outputtag) case ('flowstress') plastic_isotropic_Noutput(instance) = plastic_isotropic_Noutput(instance) + 1_pInt - param(instance)%outputID (plastic_isotropic_Noutput(instance)) = flowstress_ID plastic_isotropic_output(plastic_isotropic_Noutput(instance),instance) = outputtag + p%outputID = [p%outputID,flowstress_ID] case ('strainrate') plastic_isotropic_Noutput(instance) = plastic_isotropic_Noutput(instance) + 1_pInt - param(instance)%outputID (plastic_isotropic_Noutput(instance)) = strainrate_ID plastic_isotropic_output(plastic_isotropic_Noutput(instance),instance) = outputtag + p%outputID = [p%outputID,strainrate_ID] end select case ('/dilatation/') - param(instance)%dilatation = .true. + p%dilatation = .true. case ('tau0') - param(instance)%tau0 = IO_floatValue(line,chunkPos,2_pInt) + p%tau0 = IO_floatValue(line,chunkPos,2_pInt) case ('gdot0') - param(instance)%gdot0 = IO_floatValue(line,chunkPos,2_pInt) + p%gdot0 = IO_floatValue(line,chunkPos,2_pInt) case ('n') - param(instance)%n = IO_floatValue(line,chunkPos,2_pInt) + p%n = IO_floatValue(line,chunkPos,2_pInt) case ('h0') - param(instance)%h0 = IO_floatValue(line,chunkPos,2_pInt) + p%h0 = IO_floatValue(line,chunkPos,2_pInt) case ('h0_slope','slopelnrate') - param(instance)%h0_slopeLnRate = IO_floatValue(line,chunkPos,2_pInt) + p%h0_slopeLnRate = IO_floatValue(line,chunkPos,2_pInt) case ('tausat') - param(instance)%tausat = IO_floatValue(line,chunkPos,2_pInt) + p%tausat = IO_floatValue(line,chunkPos,2_pInt) case ('tausat_sinhfita') - param(instance)%tausat_SinhFitA = IO_floatValue(line,chunkPos,2_pInt) + p%tausat_SinhFitA = IO_floatValue(line,chunkPos,2_pInt) case ('tausat_sinhfitb') - param(instance)%tausat_SinhFitB = IO_floatValue(line,chunkPos,2_pInt) + p%tausat_SinhFitB = IO_floatValue(line,chunkPos,2_pInt) case ('tausat_sinhfitc') - param(instance)%tausat_SinhFitC = IO_floatValue(line,chunkPos,2_pInt) + p%tausat_SinhFitC = IO_floatValue(line,chunkPos,2_pInt) case ('tausat_sinhfitd') - param(instance)%tausat_SinhFitD = IO_floatValue(line,chunkPos,2_pInt) + p%tausat_SinhFitD = IO_floatValue(line,chunkPos,2_pInt) case ('a', 'w0') - param(instance)%a = IO_floatValue(line,chunkPos,2_pInt) + p%a = IO_floatValue(line,chunkPos,2_pInt) case ('taylorfactor') - param(instance)%fTaylor = IO_floatValue(line,chunkPos,2_pInt) + p%fTaylor = IO_floatValue(line,chunkPos,2_pInt) case ('atol_flowstress') - param(instance)%aTolFlowstress = IO_floatValue(line,chunkPos,2_pInt) + p%aTolFlowstress = IO_floatValue(line,chunkPos,2_pInt) case ('atol_shear') - param(instance)%aTolShear = IO_floatValue(line,chunkPos,2_pInt) + p%aTolShear = IO_floatValue(line,chunkPos,2_pInt) case default @@ -261,25 +247,24 @@ subroutine plastic_isotropic_init(fileUnit) enddo parsingFile allocate(state(maxNinstance)) ! internal state aliases - allocate(state0(maxNinstance)) allocate(dotState(maxNinstance)) - allocate(stateAbsTol(maxNinstance)) initializeInstances: do phase = 1_pInt, size(phase_plasticity) ! loop over every plasticity myPhase: if (phase_plasticity(phase) == PLASTICITY_isotropic_ID) then ! isolate instances of own constitutive description NipcMyPhase = count(material_phase == phase) ! number of own material points (including point components ipc) instance = phase_plasticityInstance(phase) + p => param(instance) extmsg = '' !-------------------------------------------------------------------------------------------------- ! sanity checks - if (param(instance)%aTolShear <= 0.0_pReal) param(instance)%aTolShear = 1.0e-6_pReal ! default absolute tolerance 1e-6 - if (param(instance)%tau0 < 0.0_pReal) extmsg = trim(extmsg)//' tau0' - if (param(instance)%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' - if (param(instance)%n <= 0.0_pReal) extmsg = trim(extmsg)//' n' - if (param(instance)%tausat <= 0.0_pReal) extmsg = trim(extmsg)//' tausat' - if (param(instance)%a <= 0.0_pReal) extmsg = trim(extmsg)//' a' - if (param(instance)%fTaylor <= 0.0_pReal) extmsg = trim(extmsg)//' taylorfactor' - if (param(instance)%aTolFlowstress <= 0.0_pReal) extmsg = trim(extmsg)//' atol_flowstress' + if (p%aTolShear <= 0.0_pReal) p%aTolShear = 1.0e-6_pReal ! default absolute tolerance 1e-6 + if (p%tau0 < 0.0_pReal) extmsg = trim(extmsg)//' tau0' + if (p%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' + if (p%n <= 0.0_pReal) extmsg = trim(extmsg)//' n' + if (p%tausat <= 0.0_pReal) extmsg = trim(extmsg)//' tausat' + if (p%a <= 0.0_pReal) extmsg = trim(extmsg)//' a' + if (p%fTaylor <= 0.0_pReal) extmsg = trim(extmsg)//' taylorfactor' + if (p%aTolFlowstress <= 0.0_pReal) extmsg = trim(extmsg)//' atol_flowstress' if (extmsg /= '') then extmsg = trim(extmsg)//' ('//PLASTICITY_ISOTROPIC_label//')' ! prepare error message identifier call IO_error(211_pInt,ip=instance,ext_msg=extmsg) @@ -287,7 +272,7 @@ subroutine plastic_isotropic_init(fileUnit) !-------------------------------------------------------------------------------------------------- ! Determine size of postResults array outputsLoop: do o = 1_pInt,plastic_isotropic_Noutput(instance) - select case(param(instance)%outputID(o)) + select case(p%outputID(o)) case(flowstress_ID,strainrate_ID) mySize = 1_pInt case default @@ -302,7 +287,7 @@ subroutine plastic_isotropic_init(fileUnit) !-------------------------------------------------------------------------------------------------- ! allocate state arrays - sizeDotState = 2_pInt ! flowstress, accumulated_shear + sizeDotState = size(["flowstress ","accumulated_shear"]) sizeDeltaState = 0_pInt ! no sudden jumps in state sizeState = sizeDotState + sizeDeltaState plasticState(phase)%sizeState = sizeState @@ -331,31 +316,20 @@ subroutine plastic_isotropic_init(fileUnit) allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NipcMyPhase),source=0.0_pReal) !-------------------------------------------------------------------------------------------------- -! globally required state aliases - plasticState(phase)%slipRate => plasticState(phase)%dotState(2:2,1:NipcMyPhase) - plasticState(phase)%accumulatedSlip => plasticState(phase)%state (2:2,1:NipcMyPhase) +! locally defined state aliases and initialization of state0 and aTolState -!-------------------------------------------------------------------------------------------------- -! locally defined state aliases state(instance)%flowstress => plasticState(phase)%state (1,1:NipcMyPhase) - state0(instance)%flowstress => plasticState(phase)%state0 (1,1:NipcMyPhase) dotState(instance)%flowstress => plasticState(phase)%dotState (1,1:NipcMyPhase) - stateAbsTol(instance)%flowstress => plasticState(phase)%aTolState(1) + plasticState(phase)%state0(1,1:NipcMyPhase) = p%tau0 + plasticState(phase)%aTolState(1) = p%aTolFlowstress state(instance)%accumulatedShear => plasticState(phase)%state (2,1:NipcMyPhase) - state0(instance)%accumulatedShear => plasticState(phase)%state0 (2,1:NipcMyPhase) dotState(instance)%accumulatedShear => plasticState(phase)%dotState (2,1:NipcMyPhase) - stateAbsTol(instance)%accumulatedShear => plasticState(phase)%aTolState(2) - -!-------------------------------------------------------------------------------------------------- -! init state - state0(instance)%flowstress = param(instance)%tau0 - state0(instance)%accumulatedShear = 0.0_pReal - -!-------------------------------------------------------------------------------------------------- -! init absolute state tolerances - stateAbsTol(instance)%flowstress = param(instance)%aTolFlowstress - stateAbsTol(instance)%accumulatedShear = param(instance)%aTolShear + plasticState(phase)%state0 (2,1:NipcMyPhase) = 0.0_pReal + plasticState(phase)%aTolState(2) = p%aTolShear + ! global alias + plasticState(phase)%slipRate => plasticState(phase)%dotState(2:2,1:NipcMyPhase) + plasticState(phase)%accumulatedSlip => plasticState(phase)%state (2:2,1:NipcMyPhase) endif myPhase enddo initializeInstances @@ -400,6 +374,8 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) ip, & !< integration point el !< element + type(tParameters), pointer :: p + real(pReal), dimension(3,3) :: & Tstar_dev_33 !< deviatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor real(pReal), dimension(3,3,3,3) :: & @@ -414,7 +390,8 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - + p => param(instance) + Tstar_dev_33 = math_deviatoric33(math_Mandel6to33(Tstar_v)) ! deviatoric part of 2nd Piola-Kirchhoff stress squarenorm_Tstar_dev = math_mul33xx33(Tstar_dev_33,Tstar_dev_33) norm_Tstar_dev = sqrt(squarenorm_Tstar_dev) @@ -423,11 +400,11 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) Lp = 0.0_pReal dLp_dTstar99 = 0.0_pReal else - gamma_dot = param(instance)%gdot0 & - * ( sqrt(1.5_pReal) * norm_Tstar_dev / param(instance)%fTaylor / state(instance)%flowstress(of) ) & - **param(instance)%n + gamma_dot = p%gdot0 & + * ( sqrt(1.5_pReal) * norm_Tstar_dev / p%fTaylor / state(instance)%flowstress(of) ) & + **p%n - Lp = Tstar_dev_33/norm_Tstar_dev * gamma_dot/param(instance)%fTaylor + Lp = Tstar_dev_33/norm_Tstar_dev * gamma_dot/p%fTaylor if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & @@ -441,13 +418,13 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) !-------------------------------------------------------------------------------------------------- ! Calculation of the tangent of Lp forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLp_dTstar_3333(k,l,m,n) = (param(instance)%n-1.0_pReal) * & + dLp_dTstar_3333(k,l,m,n) = (p%n-1.0_pReal) * & Tstar_dev_33(k,l)*Tstar_dev_33(m,n) / squarenorm_Tstar_dev forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt) & dLp_dTstar_3333(k,l,k,l) = dLp_dTstar_3333(k,l,k,l) + 1.0_pReal forall (k=1_pInt:3_pInt,m=1_pInt:3_pInt) & dLp_dTstar_3333(k,k,m,m) = dLp_dTstar_3333(k,k,m,m) - 1.0_pReal/3.0_pReal - dLp_dTstar99 = math_Plain3333to99(gamma_dot / param(instance)%fTaylor * & + dLp_dTstar99 = math_Plain3333to99(gamma_dot / p%fTaylor * & dLp_dTstar_3333 / norm_Tstar_dev) end if end subroutine plastic_isotropic_LpAndItsTangent @@ -479,9 +456,11 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar_3333,Tstar_v,ipc,ip,e ip, & !< integration point el !< element + type(tParameters), pointer :: p + real(pReal), dimension(3,3) :: & Tstar_sph_33 !< sphiatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor -real(pReal) :: & + real(pReal) :: & gamma_dot, & !< strainrate norm_Tstar_sph, & !< euclidean norm of Tstar_sph squarenorm_Tstar_sph !< square of the euclidean norm of Tstar_sph @@ -491,34 +470,34 @@ real(pReal) :: & of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - + p => param(instance) + Tstar_sph_33 = math_spherical33(math_Mandel6to33(Tstar_v)) ! spherical part of 2nd Piola-Kirchhoff stress squarenorm_Tstar_sph = math_mul33xx33(Tstar_sph_33,Tstar_sph_33) norm_Tstar_sph = sqrt(squarenorm_Tstar_sph) - if (param(instance)%dilatation .and. norm_Tstar_sph > 0.0_pReal) then ! Tstar == 0 or J2 plascitiy --> both Li and dLi_dTstar are zero - gamma_dot = param(instance)%gdot0 & - * (sqrt(1.5_pReal) * norm_Tstar_sph / param(instance)%fTaylor / state(instance)%flowstress(of) ) & - **param(instance)%n + if (p%dilatation .and. norm_Tstar_sph > 0.0_pReal) then ! Tstar == 0 or J2 plascitiy --> both Li and dLi_dTstar are zero + gamma_dot = p%gdot0 & + * (sqrt(1.5_pReal) * norm_Tstar_sph / p%fTaylor / state(instance)%flowstress(of) ) & + **p%n - Li = Tstar_sph_33/norm_Tstar_sph * gamma_dot/param(instance)%fTaylor + Li = Tstar_sph_33/norm_Tstar_sph * gamma_dot/p%fTaylor !-------------------------------------------------------------------------------------------------- ! Calculation of the tangent of Li forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & - dLi_dTstar_3333(k,l,m,n) = (param(instance)%n-1.0_pReal) * & + dLi_dTstar_3333(k,l,m,n) = (p%n-1.0_pReal) * & Tstar_sph_33(k,l)*Tstar_sph_33(m,n) / squarenorm_Tstar_sph forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt) & dLi_dTstar_3333(k,l,k,l) = dLi_dTstar_3333(k,l,k,l) + 1.0_pReal - dLi_dTstar_3333 = gamma_dot / param(instance)%fTaylor * & + dLi_dTstar_3333 = gamma_dot / p%fTaylor * & dLi_dTstar_3333 / norm_Tstar_sph else Li = 0.0_pReal dLi_dTstar_3333 = 0.0_pReal endif - -end subroutine plastic_isotropic_LiAndItsTangent + end subroutine plastic_isotropic_LiAndItsTangent !-------------------------------------------------------------------------------------------------- @@ -541,6 +520,7 @@ subroutine plastic_isotropic_dotState(Tstar_v,ipc,ip,el) ipc, & !< component-ID of integration point ip, & !< integration point el !< element + type(tParameters), pointer :: p real(pReal), dimension(6) :: & Tstar_dev_v !< deviatoric 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal) :: & @@ -554,10 +534,11 @@ subroutine plastic_isotropic_dotState(Tstar_v,ipc,ip,el) of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember instance = phase_plasticityInstance(material_phase(ipc,ip,el)) - + p => param(instance) + !-------------------------------------------------------------------------------------------------- ! norm of (deviatoric) 2nd Piola-Kirchhoff stress - if (param(instance)%dilatation) then + if (p%dilatation) then norm_Tstar_v = sqrt(math_mul6x6(Tstar_v,Tstar_v)) else Tstar_dev_v(1:3) = Tstar_v(1:3) - sum(Tstar_v(1:3))/3.0_pReal @@ -566,26 +547,26 @@ subroutine plastic_isotropic_dotState(Tstar_v,ipc,ip,el) end if !-------------------------------------------------------------------------------------------------- ! strain rate - gamma_dot = param(instance)%gdot0 * ( sqrt(1.5_pReal) * norm_Tstar_v & + gamma_dot = p%gdot0 * ( sqrt(1.5_pReal) * norm_Tstar_v & / &!----------------------------------------------------------------------------------- - (param(instance)%fTaylor*state(instance)%flowstress(of) ))**param(instance)%n + (p%fTaylor*state(instance)%flowstress(of) ))**p%n !-------------------------------------------------------------------------------------------------- ! hardening coefficient if (abs(gamma_dot) > 1e-12_pReal) then - if (dEq0(param(instance)%tausat_SinhFitA)) then - saturation = param(instance)%tausat + if (dEq0(p%tausat_SinhFitA)) then + saturation = p%tausat else - saturation = param(instance)%tausat & - + asinh( (gamma_dot / param(instance)%tausat_SinhFitA& - )**(1.0_pReal / param(instance)%tausat_SinhFitD)& - )**(1.0_pReal / param(instance)%tausat_SinhFitC) & - / ( param(instance)%tausat_SinhFitB & - * (gamma_dot / param(instance)%gdot0)**(1.0_pReal / param(instance)%n) & + saturation = p%tausat & + + asinh( (gamma_dot / p%tausat_SinhFitA& + )**(1.0_pReal / p%tausat_SinhFitD)& + )**(1.0_pReal / p%tausat_SinhFitC) & + / ( p%tausat_SinhFitB & + * (gamma_dot / p%gdot0)**(1.0_pReal / p%n) & ) endif - hardening = ( param(instance)%h0 + param(instance)%h0_slopeLnRate * log(gamma_dot) ) & - * abs( 1.0_pReal - state(instance)%flowstress(of)/saturation )**param(instance)%a & + hardening = ( p%h0 + p%h0_slopeLnRate * log(gamma_dot) ) & + * abs( 1.0_pReal - state(instance)%flowstress(of)/saturation )**p%a & * sign(1.0_pReal, 1.0_pReal - state(instance)%flowstress(of)/saturation) else hardening = 0.0_pReal @@ -614,6 +595,9 @@ function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) ipc, & !< component-ID of integration point ip, & !< integration point el !< element + + type(tParameters), pointer :: p + real(pReal), dimension(plastic_isotropic_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & plastic_isotropic_postResults @@ -629,10 +613,11 @@ function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + p => param(instance) !-------------------------------------------------------------------------------------------------- ! norm of (deviatoric) 2nd Piola-Kirchhoff stress - if (param(instance)%dilatation) then + if (p%dilatation) then norm_Tstar_v = sqrt(math_mul6x6(Tstar_v,Tstar_v)) else Tstar_dev_v(1:3) = Tstar_v(1:3) - sum(Tstar_v(1:3))/3.0_pReal @@ -644,15 +629,15 @@ function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) plastic_isotropic_postResults = 0.0_pReal outputsLoop: do o = 1_pInt,plastic_isotropic_Noutput(instance) - select case(param(instance)%outputID(o)) + select case(p%outputID(o)) case (flowstress_ID) plastic_isotropic_postResults(c+1_pInt) = state(instance)%flowstress(of) c = c + 1_pInt case (strainrate_ID) plastic_isotropic_postResults(c+1_pInt) = & - param(instance)%gdot0 * ( sqrt(1.5_pReal) * norm_Tstar_v & + p%gdot0 * ( sqrt(1.5_pReal) * norm_Tstar_v & / &!---------------------------------------------------------------------------------- - (param(instance)%fTaylor * state(instance)%flowstress(of)) ) ** param(instance)%n + (p%fTaylor * state(instance)%flowstress(of)) ) ** p%n c = c + 1_pInt end select enddo outputsLoop diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 new file mode 100644 index 000000000..c33a14db6 --- /dev/null +++ b/src/plastic_kinematichardening.f90 @@ -0,0 +1,969 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Philip Eisenlohr, Michigan State University +!> @author Zhuowen Zhao, Michigan State University +!> @brief Introducing Voce-type kinematic hardening rule into crystal plasticity +!! formulation using a power law fitting +!-------------------------------------------------------------------------------------------------- +module plastic_kinehardening + use prec, only: & + pReal,& + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_kinehardening_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + plastic_kinehardening_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + plastic_kinehardening_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + plastic_kinehardening_Noutput !< number of outputs per instance + + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_kinehardening_totalNslip !< no. of slip system used in simulation + + + integer(pInt), dimension(:,:), allocatable, private :: & + plastic_kinehardening_Nslip !< active number of slip systems per family (input parameter, per family) + + + enum, bind(c) + enumerator :: undefined_ID, & + crss_ID, & !< critical resolved stress + crss_back_ID, & !< critical resolved back stress + sense_ID, & !< sense of acting shear stress (-1 or +1) + chi0_ID, & !< backstress at last switch of stress sense (positive?) + gamma0_ID, & !< accumulated shear at last switch of stress sense (at current switch?) + accshear_ID, & + sumGamma_ID, & + shearrate_ID, & + resolvedstress_ID + + end enum + + + type, private :: tParameters !< container type for internal constitutive parameters + integer(kind(undefined_ID)), dimension(:), allocatable, private :: & + outputID !< ID of each post result output + + real(pReal) :: & + gdot0, & !< reference shear strain rate for slip (input parameter) + n_slip, & !< stress exponent for slip (input parameter) + aTolResistance, & + aTolShear + + + real(pReal), dimension(:), allocatable, private :: & + crss0, & !< initial critical shear stress for slip (input parameter, per family) + theta0, & !< initial hardening rate of forward stress for each slip + theta1, & !< asymptotic hardening rate of forward stress for each slip > + theta0_b, & !< initial hardening rate of back stress for each slip > + theta1_b, & !< asymptotic hardening rate of back stress for each slip > + tau1, & + tau1_b, & + interaction_slipslip, & !< latent hardening matrix + nonSchmidCoeff + + real(pReal), dimension(:,:), allocatable, private :: & + hardeningMatrix_SlipSlip + end type + + type, private :: tKinehardeningState + real(pReal), pointer, dimension(:,:) :: & !< vectors along NipcMyInstance + crss, & !< critical resolved stress + crss_back, & !< critical resolved back stress + sense, & !< sense of acting shear stress (-1 or +1) + chi0, & !< backstress at last switch of stress sense + gamma0, & !< accumulated shear at last switch of stress sense + accshear !< accumulated (absolute) shear + + real(pReal), pointer, dimension(:) :: & !< scalars along NipcMyInstance + sumGamma !< accumulated shear across all systems + end type + + type(tParameters), dimension(:), allocatable, private :: & + param !< containers of constitutive parameters (len Ninstance) + + type(tKinehardeningState), allocatable, dimension(:), private :: & + dotState, & + deltaState, & + state, & + state0 + + + public :: & + plastic_kinehardening_init, & + plastic_kinehardening_LpAndItsTangent, & + plastic_kinehardening_dotState, & + plastic_kinehardening_deltaState, & + plastic_kinehardening_postResults + private :: & + plastic_kinehardening_shearRates + + +contains + + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine plastic_kinehardening_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + dEq0 + use debug, only: & + debug_level, & + debug_constitutive,& + debug_levelBasic + use math, only: & + math_Mandel3333to66, & + math_Voigt66to3333, & + math_expand + 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 + use material, only: & + PLASTICITY_kinehardening_label, & + PLASTICITY_kinehardening_ID, & + phase_plasticity, & + phase_plasticityInstance, & + phase_Noutput, & + material_phase, & + plasticState, & + MATERIAL_partPhase + use lattice + use numerics,only: & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: & + o, j, k, f, & + output_ID, & + phase, & + instance, & + maxNinstance, & + NipcMyPhase, & + Nchunks_SlipSlip = 0_pInt, Nchunks_SlipFamilies = 0_pInt, & + Nchunks_nonSchmid = 0_pInt, & + offset_slip, index_myFamily, index_otherFamily, & + startIndex, endIndex, & + mySize, nSlip, nSlipFamilies, & + sizeDotState, & + sizeState, & + sizeDeltaState + + real(pReal), dimension(:), allocatable :: tempPerSlip + + character(len=65536) :: & + tag = '', & + line = '', & + extmsg = '' + character(len=64) :: & + outputtag = '' + + write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_KINEHARDENING_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + + maxNinstance = int(count(phase_plasticity == PLASTICITY_KINEHARDENING_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a,1x,i5,/)') '# instances:',maxNinstance + + allocate(plastic_kinehardening_sizePostResults(maxNinstance), source=0_pInt) + allocate(plastic_kinehardening_sizePostResult(maxval(phase_Noutput),maxNinstance), & + source=0_pInt) + allocate(plastic_kinehardening_output(maxval(phase_Noutput),maxNinstance)) + plastic_kinehardening_output = '' + allocate(plastic_kinehardening_Noutput(maxNinstance), source=0_pInt) + allocate(plastic_kinehardening_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) + allocate(plastic_kinehardening_totalNslip(maxNinstance), source=0_pInt) + allocate(param(maxNinstance)) ! one container of parameters per instance + + 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 + phase = phase + 1_pInt ! advance phase section counter + if (phase_plasticity(phase) == PLASTICITY_KINEHARDENING_ID) then + instance = phase_plasticityInstance(phase) ! count instances of my constitutive law + Nchunks_SlipFamilies = count(lattice_NslipSystem(:,phase) > 0_pInt) ! maximum number of slip families according to lattice type of current phase + Nchunks_SlipSlip = maxval(lattice_interactionSlipSlip(:,:,phase)) + Nchunks_nonSchmid = lattice_NnonSchmid(phase) + allocate(param(instance)%outputID(phase_Noutput(phase)), source=undefined_ID) ! allocate space for IDs of every requested output + allocate(param(instance)%crss0 (Nchunks_SlipFamilies), source=0.0_pReal) + allocate(param(instance)%tau1 (Nchunks_SlipFamilies), source=0.0_pReal) + allocate(param(instance)%tau1_b (Nchunks_SlipFamilies), source=0.0_pReal) + allocate(param(instance)%theta0 (Nchunks_SlipFamilies), source=0.0_pReal) + allocate(param(instance)%theta1 (Nchunks_SlipFamilies), source=0.0_pReal) + allocate(param(instance)%theta0_b(Nchunks_SlipFamilies), source=0.0_pReal) + allocate(param(instance)%theta1_b(Nchunks_SlipFamilies), source=0.0_pReal) + allocate(param(instance)%interaction_slipslip(Nchunks_SlipSlip), source=0.0_pReal) + allocate(param(instance)%nonSchmidCoeff(Nchunks_nonSchmid), source=0.0_pReal) + if(allocated(tempPerSlip)) deallocate(tempPerSlip) + allocate(tempPerSlip(Nchunks_SlipFamilies)) + endif + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (phase_plasticity(phase) == PLASTICITY_KINEHARDENING_ID) then ! one of my phases. Do not short-circuit here (.and. between if-statements), it's not safe in Fortran + instance = phase_plasticityInstance(phase) ! which instance of my plasticity is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + outputtag = IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + output_ID = undefined_ID + select case(outputtag) + case ('resistance') + output_ID = crss_ID + case ('backstress') + output_ID = crss_back_ID + case ('sense') + output_ID = sense_ID + case ('chi0') + output_ID = chi0_ID + case ('gamma0') + output_ID = gamma0_ID + case ('accumulatedshear') + output_ID = accshear_ID + case ('totalshear') + output_ID = sumGamma_ID + case ('shearrate') + output_ID = shearrate_ID + case ('resolvedstress') + output_ID = resolvedstress_ID + end select + + if (output_ID /= undefined_ID) then + plastic_kinehardening_Noutput(instance) = plastic_kinehardening_Noutput(instance) + 1_pInt + plastic_kinehardening_output(plastic_kinehardening_Noutput(instance),instance) = outputtag + param(instance)%outputID (plastic_kinehardening_Noutput(instance)) = output_ID + endif +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of slip families + case ('nslip') + if (chunkPos(1) < Nchunks_SlipFamilies + 1_pInt) & + call IO_warning(50_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_KINEHARDENING_label//')') + if (chunkPos(1) > Nchunks_SlipFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_KINEHARDENING_label//')') + Nchunks_SlipFamilies = chunkPos(1) - 1_pInt ! user specified number of (possibly) active slip families (e.g. 6 0 6 --> 3) + do j = 1_pInt, Nchunks_SlipFamilies + plastic_kinehardening_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + + case ('crss0','tau1','tau1_b','theta0','theta1','theta0_b','theta1_b') + tempPerSlip = 0.0_pReal + do j = 1_pInt, Nchunks_SlipFamilies + if (plastic_kinehardening_Nslip(j,instance) > 0_pInt) & + tempPerSlip(j) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + select case(tag) + case ('crss0') + param(instance)%crss0(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('tau1') + param(instance)%tau1(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('tau1_b') + param(instance)%tau1_b(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('theta0') + param(instance)%theta0(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('theta1') + param(instance)%theta1(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('theta0_b') + param(instance)%theta0_b(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('theta1_b') + param(instance)%theta1_b(1:Nchunks_SlipFamilies) = tempPerSlip(1:Nchunks_SlipFamilies) + end select + +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of interactions + case ('interaction_slipslip') + if (chunkPos(1) < 1_pInt + Nchunks_SlipSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_KINEHARDENING_label//')') + do j = 1_pInt, Nchunks_SlipSlip + param(instance)%interaction_slipslip(j) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('nonschmidcoeff') + if (chunkPos(1) < 1_pInt + Nchunks_nonSchmid) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_KINEHARDENING_label//')') + do j = 1_pInt,Nchunks_nonSchmid + param(instance)%nonSchmidCoeff(j) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo +!-------------------------------------------------------------------------------------------------- + case ('gdot0') + param(instance)%gdot0 = IO_floatValue(line,chunkPos,2_pInt) + + case ('n_slip') + param(instance)%n_slip = IO_floatValue(line,chunkPos,2_pInt) + + case ('atol_resistance') + param(instance)%aTolResistance = IO_floatValue(line,chunkPos,2_pInt) + + case ('atol_shear') + param(instance)%aTolShear = IO_floatValue(line,chunkPos,2_pInt) + + case default + + end select + endif; endif + enddo parsingFile + +!-------------------------------------------------------------------------------------------------- +! allocation of variables whose size depends on the total number of active slip systems + allocate(state(maxNinstance)) + allocate(state0(maxNinstance)) + allocate(dotState(maxNinstance)) + allocate(deltaState(maxNinstance)) + + + initializeInstances: do phase = 1_pInt, size(phase_plasticity) ! loop through all phases in material.config + myPhase2: if (phase_plasticity(phase) == PLASTICITY_KINEHARDENING_ID) then ! only consider my phase + NipcMyPhase = count(material_phase == phase) ! number of IPCs containing my phase + instance = phase_plasticityInstance(phase) ! which instance of my phase + plastic_kinehardening_Nslip(1:lattice_maxNslipFamily,instance) = & + min(lattice_NslipSystem(1:lattice_maxNslipFamily,phase),& ! limit active slip systems per family to min of available and requested + plastic_kinehardening_Nslip(1:lattice_maxNslipFamily,instance)) + + plastic_kinehardening_totalNslip(instance) = sum(plastic_kinehardening_Nslip(:,instance)) ! how many slip systems altogether + nSlipFamilies = count(plastic_kinehardening_Nslip(:,instance) > 0_pInt) + nSlip = plastic_kinehardening_totalNslip(instance) ! total number of active slip systems + +!-------------------------------------------------------------------------------------------------- +! sanity checks + + if (any(plastic_kinehardening_Nslip(1:nSlipFamilies,instance) > 0_pInt & + .and. param(instance)%crss0(1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' crss0' + if (any(plastic_kinehardening_Nslip(1:nSlipFamilies,instance) > 0_pInt & + .and. param(instance)%tau1(1:nSlipFamilies) <= 0.0_pReal)) extmsg = trim(extmsg)//' tau1' + if (any(plastic_kinehardening_Nslip(1:nSlipFamilies,instance) > 0_pInt & + .and. param(instance)%tau1_b(1:nSlipFamilies) < 0.0_pReal)) extmsg = trim(extmsg)//' tau1_b' + if (param(instance)%gdot0 <= 0.0_pReal) extmsg = trim(extmsg)//' gdot0' + if (param(instance)%n_slip <= 0.0_pReal) extmsg = trim(extmsg)//' n_slip' + if (param(instance)%aTolResistance <= 0.0_pReal) param(instance)%aTolResistance = 1.0_pReal ! default absolute tolerance 1 Pa + if (param(instance)%aTolShear <= 0.0_pReal) param(instance)%aTolShear = 1.0e-6_pReal ! default absolute tolerance 1e-6 + if (extmsg /= '') then + extmsg = trim(extmsg)//' ('//PLASTICITY_KINEHARDENING_label//')' ! prepare error message identifier + call IO_error(211_pInt,ip=instance,ext_msg=extmsg) + endif + + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + + outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) + select case(param(instance)%outputID(o)) + case(crss_ID, & !< critical resolved stress + crss_back_ID, & !< critical resolved back stress + sense_ID, & !< sense of acting shear stress (-1 or +1) + chi0_ID, & !< backstress at last switch of stress sense + gamma0_ID, & !< accumulated shear at last switch of stress sense + accshear_ID, & + shearrate_ID, & + resolvedstress_ID) + mySize = nSlip + case(sumGamma_ID) + mySize = 1_pInt + case default + end select + + outputFound: if (mySize > 0_pInt) then + plastic_kinehardening_sizePostResult(o,instance) = mySize + plastic_kinehardening_sizePostResults(instance) = plastic_kinehardening_sizePostResults(instance) + mySize + endif outputFound + enddo outputsLoop +!-------------------------------------------------------------------------------------------------- +! allocate state arrays + sizeDotState = nSlip & !< crss + + nSlip & !< crss_back + + nSlip & !< accumulated (absolute) shear + + 1_pInt !< sum(gamma) + + sizeDeltaState = nSlip & !< sense of acting shear stress (-1 or +1) + + nSlip & !< backstress at last switch of stress sense + + nSlip !< accumulated shear at last switch of stress sense + + sizeState = sizeDotState + sizeDeltaState + plasticState(phase)%sizeState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%offsetDeltaState = sizeDotState + plasticState(phase)%sizePostResults = plastic_kinehardening_sizePostResults(instance) + plasticState(phase)%nSlip = nSlip + + allocate(plasticState(phase)%state0 ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%partionedState0 ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%subState0 ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%state ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%aTolState (sizeDotState), source=0.0_pReal) + allocate(plasticState(phase)%dotState (sizeDotState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%deltaState (sizeDeltaState,NipcMyPhase), source=0.0_pReal) ! allocate space for deltaState + if (any(numerics_integrator == 1_pInt)) then + allocate(plasticState(phase)%previousDotState (sizeDotState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%previousDotState2(sizeDotState,NipcMyPhase),source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(plasticState(phase)%RK4dotState (sizeDotState,NipcMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NipcMyPhase), source=0.0_pReal) + + offset_slip = plasticState(phase)%nSlip+plasticState(phase)%nTwin+2_pInt + plasticState(phase)%slipRate => & + plasticState(phase)%dotState(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) + plasticState(phase)%accumulatedSlip => & + plasticState(phase)%state(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) + + allocate(param(instance)%hardeningMatrix_SlipSlip(nSlip,nSlip), source=0.0_pReal) + do f = 1_pInt,lattice_maxNslipFamily ! >>> interaction slip -- X + index_myFamily = sum(plastic_kinehardening_Nslip(1:f-1_pInt,instance)) + do j = 1_pInt,plastic_kinehardening_Nslip(f,instance) ! loop over (active) systems in my family (slip) + do o = 1_pInt,lattice_maxNslipFamily + index_otherFamily = sum(plastic_kinehardening_Nslip(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_kinehardening_Nslip(o,instance) ! loop over (active) systems in other family (slip) + param(instance)%hardeningMatrix_SlipSlip(index_myFamily+j,index_otherFamily+k) = & + param(instance)%interaction_SlipSlip(lattice_interactionSlipSlip( & + sum(lattice_NslipSystem(1:f-1,phase))+j, & + sum(lattice_NslipSystem(1:o-1,phase))+k, & + phase)) + enddo; enddo + enddo; enddo + +!---------------------------------------------------------------------------------------------- +!locally define dotState alias + + endindex = 0_pInt + o = endIndex ! offset of dotstate index relative to state index + + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + state (instance)%crss => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) + state0 (instance)%crss => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) + dotState(instance)%crss => plasticState(phase)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) + + state0(instance)%crss = spread(math_expand(param(instance)%crss0,& + plastic_kinehardening_Nslip(:,instance)), & + 2, NipcMyPhase) + plasticState(phase)%aTolState(startIndex-o:endIndex-o) = param(instance)%aTolResistance + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + state (instance)%crss_back => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) + state0 (instance)%crss_back => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) + dotState(instance)%crss_back => plasticState(phase)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) + + state0(instance)%crss_back = 0.0_pReal + plasticState(phase)%aTolState(startIndex-o:endIndex-o) = param(instance)%aTolResistance + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + state (instance)%accshear => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) + state0 (instance)%accshear => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) + dotState(instance)%accshear => plasticState(phase)%dotState (startIndex-o:endIndex-o,1:NipcMyPhase) + + state0(instance)%accshear = 0.0_pReal + plasticState(phase)%aTolState(startIndex-o:endIndex-o) = param(instance)%aTolShear + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + 1_pInt + state (instance)%sumGamma => plasticState(phase)%state (startIndex ,1:NipcMyPhase) + state0 (instance)%sumGamma => plasticState(phase)%state0 (startIndex ,1:NipcMyPhase) + dotState(instance)%sumGamma => plasticState(phase)%dotState (startIndex-o ,1:NipcMyPhase) + + state0(instance)%sumGamma = 0.0_pReal + plasticState(phase)%aTolState(startIndex-o:endIndex-o) = param(instance)%aTolShear + +!---------------------------------------------------------------------------------------------- +!locally define deltaState alias + o = endIndex + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + state (instance)%sense => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) + state0 (instance)%sense => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) + deltaState(instance)%sense => plasticState(phase)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) + + state0(instance)%sense = 0.0_pReal + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + state (instance)%chi0 => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) + state0 (instance)%chi0 => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) + deltaState(instance)%chi0 => plasticState(phase)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) + + state0(instance)%chi0 = 0.0_pReal + +! ............................................. + startIndex = endIndex + 1_pInt + endIndex = endIndex + nSlip + state (instance)%gamma0 => plasticState(phase)%state (startIndex :endIndex ,1:NipcMyPhase) + state0 (instance)%gamma0 => plasticState(phase)%state0 (startIndex :endIndex ,1:NipcMyPhase) + deltaState(instance)%gamma0 => plasticState(phase)%deltaState(startIndex-o:endIndex-o,1:NipcMyPhase) + + state0(instance)%gamma0 = 0.0_pReal + + endif myPhase2 + enddo initializeInstances + +end subroutine plastic_kinehardening_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculation of shear rates (\dot \gamma) +!-------------------------------------------------------------------------------------------------- +subroutine plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & + Tstar_v,ph,instance,of) + + use lattice, only: & + lattice_NslipSystem, & + lattice_Sslip_v, & + lattice_maxNslipFamily, & + lattice_NnonSchmid + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ph, & !< phase ID + instance, & !< instance of that phase + of !< index of phaseMember + real(pReal), dimension(plastic_kinehardening_totalNslip(instance)), intent(out) :: & + gdot_pos, & !< shear rates from positive line segments + gdot_neg, & !< shear rates from negative line segments + tau_pos, & !< shear stress on positive line segments + tau_neg !< shear stress on negative line segments + + integer(pInt) :: & + index_myFamily, & + f,i,j,k + + + j = 0_pInt + slipFamilies: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) + j = j + 1_pInt + tau_pos(j) = dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + tau_neg(j) = tau_pos(j) + nonSchmidSystems: do k = 1,lattice_NnonSchmid(ph) + tau_pos(j) = tau_pos(j) + param(instance)%nonSchmidCoeff(k)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+0,index_myFamily+i,ph)) + tau_neg(j) = tau_neg(j) + param(instance)%nonSchmidCoeff(k)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + enddo nonSchmidSystems + enddo slipSystems + enddo slipFamilies + + gdot_pos = 0.5_pReal * param(instance)%gdot0 * & + (abs(tau_pos-state(instance)%crss_back(:,of))/ & + state(instance)%crss(:,of))**param(instance)%n_slip & + *sign(1.0_pReal,tau_pos-state(instance)%crss_back(:,of)) + gdot_neg = 0.5_pReal * param(instance)%gdot0 * & + (abs(tau_neg-state(instance)%crss_back(:,of))/ & + state(instance)%crss(:,of))**param(instance)%n_slip & + *sign(1.0_pReal,tau_neg-state(instance)%crss_back(:,of)) + + +end subroutine plastic_kinehardening_shearRates + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates plastic velocity gradient and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dTstar99, & + Tstar_v,ipc,ip,el) + use prec, only: & + dNeq0 + use debug, only: & + debug_level, & + debug_constitutive, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g + use math, only: & + math_Plain3333to99, & + math_Mandel6to33, & + math_transpose33 + use lattice, only: & + lattice_Sslip, & !< schmid matrix + lattice_Sslip_v, & + lattice_maxNslipFamily, & + lattice_NslipSystem, & + lattice_NnonSchmid + use material, only: & + phaseAt, phasememberAt, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(3,3), intent(out) :: & + Lp !< plastic velocity gradient + real(pReal), dimension(9,9), intent(out) :: & + dLp_dTstar99 !< derivative of Lp with respect to 2nd Piola Kirchhoff stress + + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + + integer(pInt) :: & + instance, & + index_myFamily, & + f,i,j,k,l,m,n, & + of, & + ph + + real(pReal), dimension(plastic_kinehardening_totalNslip(phase_plasticityInstance(phaseAt(ipc,ip,el)))) :: & + gdot_pos,gdot_neg, & + tau_pos,tau_neg + real(pReal) :: & + dgdot_dtau_pos,dgdot_dtau_neg + real(pReal), dimension(3,3,3,3) :: & + dLp_dTstar3333 !< derivative of Lp with respect to Tstar as 4th order tensor + real(pReal), dimension(3,3,2) :: & + nonSchmid_tensor + + ph = phaseAt(ipc,ip,el) !< figures phase for each material point + of = phasememberAt(ipc,ip,el) !< index of the positions of each constituent of material point, phasememberAt is a function in material that helps figure them out + instance = phase_plasticityInstance(ph) + + Lp = 0.0_pReal + dLp_dTstar3333 = 0.0_pReal + dLp_dTstar99 = 0.0_pReal + + call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & + Tstar_v,ph,instance,of) + + + j = 0_pInt ! reading and marking the starting index for each slip family + slipFamilies: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) + j = j + 1_pInt + + ! build nonSchmid tensor + nonSchmid_tensor(1:3,1:3,1) = lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) + nonSchmid_tensor(1:3,1:3,2) = nonSchmid_tensor(1:3,1:3,1) + do k = 1,lattice_NnonSchmid(ph) + nonSchmid_tensor(1:3,1:3,1) = & + nonSchmid_tensor(1:3,1:3,1) + param(instance)%nonSchmidCoeff(k) * & + lattice_Sslip(1:3,1:3,2*k,index_myFamily+i,ph) + nonSchmid_tensor(1:3,1:3,2) = & + nonSchmid_tensor(1:3,1:3,2) + param(instance)%nonSchmidCoeff(k) * & + lattice_Sslip(1:3,1:3,2*k+1,index_myFamily+i,ph) + enddo + + Lp = Lp + (gdot_pos(j)+gdot_neg(j))*lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) ! sum of all gdot*SchmidTensor gives Lp + + ! Calculation of the tangent of Lp ! sensitivity of Lp + if (dNeq0(gdot_pos(j))) then + dgdot_dtau_pos = gdot_pos(j)*param(instance)%n_slip/(tau_pos(j)-state(instance)%crss_back(j,of)) + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = & + dLp_dTstar3333(k,l,m,n) + dgdot_dtau_pos*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & + nonSchmid_tensor(m,n,1) + endif + + if (dNeq0(gdot_neg(j))) then + dgdot_dtau_neg = gdot_neg(j)*param(instance)%n_slip/(tau_neg(j)-state(instance)%crss_back(j,of)) + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = & + dLp_dTstar3333(k,l,m,n) + dgdot_dtau_neg*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & + nonSchmid_tensor(m,n,2) + endif + enddo slipSystems + enddo slipFamilies + + dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) + +end subroutine plastic_kinehardening_LpAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates (instantaneous) incremental change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_kinehardening_deltaState(Tstar_v,ipc,ip,el) + use prec, only: & + dNeq, & + dEq0 + use debug, only: & + debug_level, & + debug_constitutive, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g + use material, only: & + phaseAt, & + phasememberAt, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(6), intent(in):: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(6) :: & + Tstar_dev_v !< deviatoric 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), dimension(plastic_kinehardening_totalNslip(phase_plasticityInstance(phaseAt(ipc,ip,el)))) :: & + gdot_pos,gdot_neg, & + tau_pos,tau_neg, & + sense + integer(pInt) :: & + ph, & + instance, & !< instance of my instance (unique number of my constitutive model) + of, & + j !< shortcut notation for offset position in state array + + ph = phaseAt(ipc,ip,el) + of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember + instance = phase_plasticityInstance(ph) + + call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & + Tstar_v,ph,instance,of) + sense = merge(state(instance)%sense(:,of), & ! keep existing... + sign(1.0_pReal,gdot_pos+gdot_neg), & ! ...or have a defined + dEq0(gdot_pos+gdot_neg,1e-10_pReal)) ! current sense of shear direction + +#ifdef DEBUG + if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then + write(6,'(a)') '======= kinehardening delta state =======' + endif +#endif + +!-------------------------------------------------------------------------------------------------- +! switch in sense of shear? + do j = 1,plastic_kinehardening_totalNslip(instance) +#ifdef DEBUG + if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then + write(6,'(i2,1x,f7.4,1x,f7.4)') j,sense(j),state(instance)%sense(j,of) + endif +#endif + if (dNeq(sense(j),state(instance)%sense(j,of),0.1_pReal)) then + deltaState(instance)%sense (j,of) = sense(j) - state(instance)%sense(j,of) ! switch sense + deltaState(instance)%chi0 (j,of) = abs(state(instance)%crss_back(j,of)) - state(instance)%chi0(j,of) ! remember current backstress magnitude + deltaState(instance)%gamma0(j,of) = state(instance)%accshear(j,of) - state(instance)%gamma0(j,of) ! remember current accumulated shear + else + deltaState(instance)%sense (j,of) = 0.0_pReal ! no change + deltaState(instance)%chi0 (j,of) = 0.0_pReal + deltaState(instance)%gamma0(j,of) = 0.0_pReal + endif + enddo + +end subroutine plastic_kinehardening_deltaState + + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates the rate of change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_kinehardening_dotState(Tstar_v,ipc,ip,el) + use lattice, only: & + lattice_Sslip_v, & + lattice_maxNslipFamily, & + lattice_NslipSystem, & + lattice_NnonSchmid + use material, only: & + material_phase, & + phaseAt, phasememberAt, & + plasticState, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation, vector form + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element !< microstructure state + + integer(pInt) :: & + instance,ph, & + f,i,j,k, & + index_myFamily,index_otherFamily, & + nSlip, & + offset_accshear, & + of + + real(pReal), dimension(plastic_kinehardening_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_pos,gdot_neg, & + tau_pos,tau_neg + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + nSlip = plastic_kinehardening_totalNslip(instance) + + dotState(instance)%sumGamma(of) = 0.0_pReal + + call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & + Tstar_v,ph,instance,of) + + j = 0_pInt + slipFamilies: do f = 1_pInt,lattice_maxNslipFamily + slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) + j = j+1_pInt + dotState(instance)%crss(j,of) = & ! evolution of slip resistance j + dot_product(param(instance)%hardeningMatrix_SlipSlip(j,1:nSlip),abs(gdot_pos+gdot_neg)) * & + ( param(instance)%theta1(f) + & + (param(instance)%theta0(f) - param(instance)%theta1(f) & + + param(instance)%theta0(f)*param(instance)%theta1(f)*state(instance)%sumGamma(of)/param(instance)%tau1(f)) & + *exp(-state(instance)%sumGamma(of)*param(instance)%theta0(f)/param(instance)%tau1(f)) & ! V term depending on the harding law + ) + dotState(instance)%crss_back(j,of) = & ! evolution of back stress resistance j + state(instance)%sense(j,of)*abs(gdot_pos(j)+gdot_neg(j)) * & + ( param(instance)%theta1_b(f) + & + (param(instance)%theta0_b(f) - param(instance)%theta1_b(f) & + + param(instance)%theta0_b(f)*param(instance)%theta1_b(f)/(param(instance)%tau1_b(f)+state(instance)%chi0(j,of)) & + *(state(instance)%accshear(j,of)-state(instance)%gamma0(j,of))) & + *exp(-(state(instance)%accshear(j,of)-state(instance)%gamma0(j,of)) & + *param(instance)%theta0_b(f)/(param(instance)%tau1_b(f)+state(instance)%chi0(j,of))) & + ) ! V term depending on the harding law for back stress + + dotState(instance)%accshear(j,of) = abs(gdot_pos(j)+gdot_neg(j)) + dotState(instance)%sumGamma(of) = dotState(instance)%sumGamma(of) + dotState(instance)%accshear(j,of) + enddo slipSystems + enddo slipFamilies + +end subroutine plastic_kinehardening_dotState + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_kinehardening_postResults(Tstar_v,ipc,ip,el) + use material, only: & + material_phase, & + plasticState, & + phaseAt, phasememberAt, & + phase_plasticityInstance + use lattice, only: & + lattice_Sslip_v, & + lattice_maxNslipFamily, & + lattice_NslipSystem, & + lattice_NnonSchmid + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element !< microstructure state + + real(pReal), dimension(plastic_kinehardening_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + plastic_kinehardening_postResults + + integer(pInt) :: & + instance,ph, of, & + nSlip,& + o,f,i,c,j,k, & + index_myFamily + + real(pReal), dimension(plastic_kinehardening_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_pos,gdot_neg, & + tau_pos,tau_neg + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + + nSlip = plastic_kinehardening_totalNslip(instance) + + plastic_kinehardening_postResults = 0.0_pReal + c = 0_pInt + + call plastic_kinehardening_shearRates(gdot_pos,gdot_neg,tau_pos,tau_neg, & + Tstar_v,ph,instance,of) + + outputsLoop: do o = 1_pInt,plastic_kinehardening_Noutput(instance) + select case(param(instance)%outputID(o)) + case (crss_ID) + plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%crss(:,of) + c = c + nSlip + + case(crss_back_ID) + plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%crss_back(:,of) + c = c + nSlip + + case (sense_ID) + plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%sense(:,of) + c = c + nSlip + + case (chi0_ID) + plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%chi0(:,of) + c = c + nSlip + + case (gamma0_ID) + plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%gamma0(:,of) + c = c + nSlip + + case (accshear_ID) + plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = state(instance)%accshear(:,of) + c = c + nSlip + + case (sumGamma_ID) + plastic_kinehardening_postResults(c+1_pInt) = state(instance)%sumGamma(of) + c = c + 1_pInt + + case (shearrate_ID) + plastic_kinehardening_postResults(c+1_pInt:c+nSlip) = gdot_pos+gdot_neg + c = c + nSlip + + case (resolvedstress_ID) + j = 0_pInt + slipFamilies: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems: do i = 1_pInt,plastic_kinehardening_Nslip(f,instance) + j = j + 1_pInt + plastic_kinehardening_postResults(c+j) = & + dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + enddo slipSystems + enddo slipFamilies + c = c + nSlip + + end select + enddo outputsLoop + +end function plastic_kinehardening_postResults + +end module plastic_kinehardening diff --git a/src/prec.f90 b/src/prec.f90 index f35735780..2cdc533b6 100644 --- a/src/prec.f90 +++ b/src/prec.f90 @@ -68,7 +68,7 @@ module prec nTrans = 0_pInt logical :: & nonlocal = .false. - real(pReal), pointer, dimension(:,:), contiguous :: & + real(pReal), pointer, dimension(:,:) :: & slipRate, & !< slip rate accumulatedSlip !< accumulated plastic slip end type diff --git a/src/spectral_damage.f90 b/src/spectral_damage.f90 index c6caf410d..def1af303 100644 --- a/src/spectral_damage.f90 +++ b/src/spectral_damage.f90 @@ -4,6 +4,10 @@ !> @brief Spectral solver for nonlocal damage !-------------------------------------------------------------------------------------------------- module spectral_damage +#include +#include + use PETScdmda + use PETScsnes use prec, only: & pInt, & pReal @@ -18,7 +22,6 @@ module spectral_damage implicit none private -#include character (len=*), parameter, public :: & spectral_damage_label = 'spectraldamage' @@ -46,13 +49,9 @@ module spectral_damage public :: & spectral_damage_init, & spectral_damage_solution, & - spectral_damage_forward, & - spectral_damage_destroy + spectral_damage_forward external :: & - PETScFinalize, & - MPI_Abort, & - MPI_Bcast, & - MPI_Allreduce + PETScErrorF ! is called in the CHKERRQ macro contains @@ -79,32 +78,22 @@ subroutine spectral_damage_init() damage_nonlocal_getMobility implicit none - integer(pInt), dimension(:), allocatable :: localK + PetscInt, dimension(:), allocatable :: localK integer(pInt) :: proc integer(pInt) :: i, j, k, cell DM :: damage_grid Vec :: uBound, lBound PetscErrorCode :: ierr character(len=100) :: snes_type - external :: & - SNESCreate, & SNESSetOptionsPrefix, & - DMDACreate3D, & - SNESSetDM, & - DMDAGetCorners, & - DMCreateGlobalVector, & - DMDASNESSetFunctionLocal, & - SNESSetFromOptions, & SNESGetType, & - VecSet, & - DMGetGlobalVector, & - DMRestoreGlobalVector, & - SNESVISetVariableBounds + DMDAGetCorners, & + DMDASNESSetFunctionLocal write(6,'(/,a)') ' <<<+- spectral_damage init -+>>>' write(6,'(/,a)') ' Shanthraj et al., Handbook of Mechanics of Materials, volume in press, ' - write(6,'(/,a)') ' chapter Spectral Solvers for Crystal Plasticity and Multi-Physics Simulations. Springer, 2018 ' + write(6,'(a,/)') ' chapter Spectral Solvers for Crystal Plasticity and Multi-Physics Simulations. Springer, 2018 ' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" @@ -116,21 +105,23 @@ subroutine spectral_damage_init() do proc = 1, worldsize call MPI_Bcast(localK(proc),1,MPI_INTEGER,proc-1,PETSC_COMM_WORLD,ierr) enddo - call DMDACreate3d(PETSC_COMM_WORLD, & + call DMDACreate3D(PETSC_COMM_WORLD, & DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & !< cut off stencil at boundary DMDA_STENCIL_BOX, & !< Moore (26) neighborhood around central point grid(1),grid(2),grid(3), & !< global grid 1, 1, worldsize, & 1, 0, & !< #dof (damage phase field), ghost boundary width (domain overlap) - grid(1),grid(2),localK, & !< local grid + [grid(1)],[grid(2)],localK, & !< local grid damage_grid,ierr) !< handle, error CHKERRQ(ierr) call SNESSetDM(damage_snes,damage_grid,ierr); CHKERRQ(ierr) !< connect snes to da + call DMsetFromOptions(damage_grid,ierr); CHKERRQ(ierr) + call DMsetUp(damage_grid,ierr); CHKERRQ(ierr) call DMCreateGlobalVector(damage_grid,solution,ierr); CHKERRQ(ierr) !< global solution vector (grid x 1, i.e. every def grad tensor) call DMDASNESSetFunctionLocal(damage_grid,INSERT_VALUES,spectral_damage_formResidual,& - PETSC_NULL_OBJECT,ierr) !< residual vector of same shape as solution vector + PETSC_NULL_SNES,ierr) !< residual vector of same shape as solution vector CHKERRQ(ierr) - call SNESSetFromOptions(damage_snes,ierr); CHKERRQ(ierr) !< pull it all together with additional cli arguments + call SNESSetFromOptions(damage_snes,ierr); CHKERRQ(ierr) !< pull it all together with additional CLI arguments call SNESGetType(damage_snes,snes_type,ierr); CHKERRQ(ierr) if (trim(snes_type) == 'vinewtonrsls' .or. & trim(snes_type) == 'vinewtonssls') then @@ -138,7 +129,7 @@ subroutine spectral_damage_init() call DMGetGlobalVector(damage_grid,uBound,ierr); CHKERRQ(ierr) call VecSet(lBound,0.0,ierr); CHKERRQ(ierr) call VecSet(uBound,1.0,ierr); CHKERRQ(ierr) - call SNESVISetVariableBounds(damage_snes,lBound,uBound,ierr) !< variable bounds for variational inequalities like contact mechanics, damage etc. + call SNESVISetVariableBounds(damage_snes,lBound,uBound,ierr) !< variable bounds for variational inequalities like contact mechanics, damage etc. call DMRestoreGlobalVector(damage_grid,lBound,ierr); CHKERRQ(ierr) call DMRestoreGlobalVector(damage_grid,uBound,ierr); CHKERRQ(ierr) endif @@ -206,8 +197,7 @@ type(tSolutionState) function spectral_damage_solution(timeinc,timeinc_old,loadC external :: & VecMin, & VecMax, & - SNESSolve, & - SNESGetConvergedReason + SNESSolve spectral_damage_solution%converged =.false. @@ -216,7 +206,7 @@ type(tSolutionState) function spectral_damage_solution(timeinc,timeinc_old,loadC params%timeinc = timeinc params%timeincOld = timeinc_old - call SNESSolve(damage_snes,PETSC_NULL_OBJECT,solution,ierr); CHKERRQ(ierr) + call SNESSolve(damage_snes,PETSC_NULL_VEC,solution,ierr); CHKERRQ(ierr) call SNESGetConvergedReason(damage_snes,reason,ierr); CHKERRQ(ierr) if (reason < 1) then @@ -244,14 +234,12 @@ type(tSolutionState) function spectral_damage_solution(timeinc,timeinc_old,loadC call VecMin(solution,position,minDamage,ierr); CHKERRQ(ierr) call VecMax(solution,position,maxDamage,ierr); CHKERRQ(ierr) - if (worldrank == 0) then - if (spectral_damage_solution%converged) & - write(6,'(/,a)') ' ... nonlocal damage converged .....................................' - write(6,'(/,a,f8.6,2x,f8.6,2x,f8.6,/)',advance='no') ' Minimum|Maximum|Delta Damage = ',& + if (spectral_damage_solution%converged) & + write(6,'(/,a)') ' ... nonlocal damage converged .....................................' + write(6,'(/,a,f8.6,2x,f8.6,2x,f8.6,/)',advance='no') ' Minimum|Maximum|Delta Damage = ',& minDamage, maxDamage, stagNorm - write(6,'(/,a)') ' ===========================================================================' - flush(6) - endif + write(6,'(/,a)') ' ===========================================================================' + flush(6) end function spectral_damage_solution @@ -361,9 +349,6 @@ subroutine spectral_damage_forward() DM :: dm_local PetscScalar, dimension(:,:,:), pointer :: x_scal PetscErrorCode :: ierr - - external :: & - SNESGetDM if (cutBack) then damage_current = damage_lastInc @@ -397,23 +382,6 @@ subroutine spectral_damage_forward() call MPI_Allreduce(MPI_IN_PLACE,mobility_ref,1,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) endif - end subroutine spectral_damage_forward - -!-------------------------------------------------------------------------------------------------- -!> @brief destroy routine -!-------------------------------------------------------------------------------------------------- -subroutine spectral_damage_destroy() - - implicit none - PetscErrorCode :: ierr - - external :: & - VecDestroy, & - SNESDestroy - - call VecDestroy(solution,ierr); CHKERRQ(ierr) - call SNESDestroy(damage_snes,ierr); CHKERRQ(ierr) - -end subroutine spectral_damage_destroy +end subroutine spectral_damage_forward end module spectral_damage diff --git a/src/spectral_interface.f90 b/src/spectral_interface.f90 index eca92df9d..d2adcf9ba 100644 --- a/src/spectral_interface.f90 +++ b/src/spectral_interface.f90 @@ -11,9 +11,9 @@ module DAMASK_interface use prec, only: & pInt + implicit none private -#include logical, public, protected :: appendToOutFile = .false. !< Append to existing spectralOut file (in case of restart, not in case of regridding) integer(pInt), public, protected :: spectralRestartInc = 0_pInt !< Increment at which calculation starts character(len=1024), public, protected :: & @@ -44,7 +44,13 @@ contains subroutine DAMASK_interface_init() use, intrinsic :: & iso_fortran_env - +#include +#if PETSC_VERSION_MAJOR!=3 || PETSC_VERSION_MINOR!=9 +=================================================================================================== +========================= THIS VERSION OF DAMASK REQUIRES PETSc 3.9.x ========================= +=================================================================================================== +#endif + use PETScSys use system_routines, only: & getHostName @@ -72,11 +78,8 @@ subroutine DAMASK_interface_init() logical :: error external :: & quit,& - MPI_Comm_rank,& - MPI_Comm_size,& - PETScInitialize, & - MPI_Init_Thread, & - MPI_abort + PETScErrorF, & ! is called in the CHKERRQ macro + PETScInitialize open(6, encoding='UTF-8') ! for special characters in output @@ -91,7 +94,7 @@ subroutine DAMASK_interface_init() call quit(1_pInt) endif #endif - call PetscInitialize(PETSC_NULL_CHARACTER,ierr) ! according to PETSc manual, that should be the first line in the code + call PETScInitialize(PETSC_NULL_CHARACTER,ierr) ! according to PETSc manual, that should be the first line in the code CHKERRQ(ierr) ! this is a macro definition, it is case sensitive call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) call MPI_Comm_size(PETSC_COMM_WORLD,worldsize,ierr);CHKERRQ(ierr) @@ -104,10 +107,6 @@ subroutine DAMASK_interface_init() write(output_unit,'(a)') ' STDERR != 0' call quit(1_pInt) endif - if (PETSC_VERSION_MAJOR /= 3 .or. PETSC_VERSION_MINOR /= 7) then - write(6,'(a,2(i1.1,a))') 'PETSc ',PETSC_VERSION_MAJOR,'.',PETSC_VERSION_MINOR,'.x not supported' - call quit(1_pInt) - endif else mainProcess close(6) ! disable output for non-master processes (open 6 to rank specific file for debug) open(6,file='/dev/null',status='replace') ! close(6) alone will leave some temp files in cwd @@ -525,5 +524,4 @@ pure function IIO_stringPos(string) end function IIO_stringPos - end module diff --git a/src/spectral_mech_AL.f90 b/src/spectral_mech_AL.f90 deleted file mode 100644 index 67eda6f42..000000000 --- a/src/spectral_mech_AL.f90 +++ /dev/null @@ -1,723 +0,0 @@ -!-------------------------------------------------------------------------------------------------- -!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH -!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH -!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH -!> @brief AL scheme solver -!-------------------------------------------------------------------------------------------------- -module spectral_mech_AL - use prec, only: & - pInt, & - pReal - use math, only: & - math_I3 - use spectral_utilities, only: & - tSolutionState, & - tSolutionParams - - implicit none - private -#include - - character (len=*), parameter, public :: & - DAMASK_spectral_solverAL_label = 'al' - -!-------------------------------------------------------------------------------------------------- -! derived types - type(tSolutionParams), private :: params - real(pReal), private, dimension(3,3) :: mask_stress = 0.0_pReal - -!-------------------------------------------------------------------------------------------------- -! PETSc data - DM, private :: da - SNES, private :: snes - Vec, private :: solution_vec - -!-------------------------------------------------------------------------------------------------- -! common pointwise data - real(pReal), private, dimension(:,:,:,:,:), allocatable :: & - F_lastInc, & !< field of previous compatible deformation gradients - F_lambda_lastInc, & !< field of previous incompatible deformation gradient - Fdot, & !< field of assumed rate of compatible deformation gradient - F_lambdaDot !< field of assumed rate of incopatible deformation gradient - -!-------------------------------------------------------------------------------------------------- -! stress, stiffness and compliance average etc. - real(pReal), private, dimension(3,3) :: & - F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient - F_aim = math_I3, & !< current prescribed deformation gradient - F_aim_lastInc = math_I3, & !< previous average deformation gradient - F_av = 0.0_pReal, & !< average incompatible def grad field - P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress - P_avLastEval = 0.0_pReal !< average 1st Piola--Kirchhoff stress last call of CPFEM_general - - character(len=1024), private :: incInfo !< time and increment information - - real(pReal), private, dimension(3,3,3,3) :: & - C_volAvg = 0.0_pReal, & !< current volume average stiffness - C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness - C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness - C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness - S = 0.0_pReal, & !< current compliance (filled up with zeros) - C_scale = 0.0_pReal, & - S_scale = 0.0_pReal - - real(pReal), private :: & - err_BC, & !< deviation from stress BC - err_curl, & !< RMS of curl of F - err_div !< RMS of div of P - - integer(pInt), private :: & - totalIter = 0_pInt !< total iteration in current increment - - public :: & - AL_init, & - AL_solution, & - AL_forward, & - AL_destroy - external :: & - PETScFinalize, & - MPI_Abort, & - MPI_Bcast, & - MPI_Allreduce - -contains - -!-------------------------------------------------------------------------------------------------- -!> @brief allocates all necessary fields and fills them with data, potentially from restart info -!> @todo use sourced allocation, e.g. allocate(Fdot,source = F_lastInc) -!-------------------------------------------------------------------------------------------------- -subroutine AL_init -#if defined(__GFORTRAN__) || __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use IO, only: & - IO_intOut, & - IO_read_realFile, & - IO_timeStamp - use debug, only: & - debug_level, & - debug_spectral, & - debug_spectralRestart - use FEsolving, only: & - restartInc - use numerics, only: & - worldrank, & - worldsize - use homogenization, only: & - materialpoint_F0 - use DAMASK_interface, only: & - getSolverJobName - use spectral_utilities, only: & - Utilities_constitutiveResponse, & - Utilities_updateGamma, & - Utilities_updateIPcoords, & - wgt - use mesh, only: & - grid, & - grid3 - use math, only: & - math_invSym3333 - - implicit none - real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P - real(pReal), dimension(3,3) :: & - temp33_Real = 0.0_pReal - - PetscErrorCode :: ierr - PetscScalar, pointer, dimension(:,:,:,:) :: & - FandF_lambda, & ! overall pointer to solution data - F, & ! specific (sub)pointer - F_lambda ! specific (sub)pointer - - integer(pInt), dimension(:), allocatable :: localK - integer(pInt) :: proc - character(len=1024) :: rankStr - - external :: & - SNESCreate, & - SNESSetOptionsPrefix, & - DMDACreate3D, & - SNESSetDM, & - DMCreateGlobalVector, & - DMDASNESSetFunctionLocal, & - SNESGetConvergedReason, & - SNESSetConvergenceTest, & - SNESSetFromOptions - - write(6,'(/,a)') ' <<<+- DAMASK_spectral_solverAL init -+>>>' - write(6,'(/,a)') ' Shanthraj et al., International Journal of Plasticity, 66:31–45, 2015' - write(6,'(/,a)') ' https://doi.org/10.1016/j.ijplas.2014.02.006' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() -#include "compilation_info.f90" - -!-------------------------------------------------------------------------------------------------- -! allocate global fields - allocate (F_lastInc (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (Fdot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (F_lambda_lastInc(3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (F_lambdaDot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - -!-------------------------------------------------------------------------------------------------- -! initialize solver specific parts of PETSc - call SNESCreate(PETSC_COMM_WORLD,snes,ierr); CHKERRQ(ierr) - call SNESSetOptionsPrefix(snes,'mech_',ierr);CHKERRQ(ierr) - allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 - do proc = 1, worldsize - call MPI_Bcast(localK(proc),1,MPI_INTEGER,proc-1,PETSC_COMM_WORLD,ierr) - enddo - call DMDACreate3d(PETSC_COMM_WORLD, & - DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary - DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point - grid(1),grid(2),grid(3), & ! global grid - 1 , 1, worldsize, & - 18, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) - grid(1),grid(2),localK, & ! local grid - da,ierr) ! handle, error - CHKERRQ(ierr) - call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) ! connect snes to da - call DMCreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 9, i.e. every def grad tensor) - call DMDASNESSetFunctionLocal(da,INSERT_VALUES,AL_formResidual,PETSC_NULL_OBJECT,ierr) ! residual vector of same shape as solution vector - CHKERRQ(ierr) - call SNESSetConvergenceTest(snes,AL_converged,PETSC_NULL_OBJECT,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "_converged" - CHKERRQ(ierr) - call SNESSetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional cli arguments - -!-------------------------------------------------------------------------------------------------- -! init fields - call DMDAVecGetArrayF90(da,solution_vec,FandF_lambda,ierr); CHKERRQ(ierr) ! places pointer on PETSc data - F => FandF_lambda( 0: 8,:,:,:) - F_lambda => FandF_lambda( 9:17,:,:,:) - - restart: if (restartInc > 0_pInt) then - if (iand(debug_level(debug_spectral),debug_spectralRestart) /= 0) then - write(6,'(/,a,'//IO_intOut(restartInc)//',a)') & - 'reading values of increment ', restartInc, ' from file' - flush(6) - endif - write(rankStr,'(a1,i0)')'_',worldrank - call IO_read_realFile(777,'F'//trim(rankStr),trim(getSolverJobName()),size(F)) - read (777,rec=1) F; close (777) - call IO_read_realFile(777,'F_lastInc'//trim(rankStr),trim(getSolverJobName()),size(F_lastInc)) - read (777,rec=1) F_lastInc; close (777) - call IO_read_realFile(777,'F_lambda'//trim(rankStr),trim(getSolverJobName()),size(F_lambda)) - read (777,rec=1) F_lambda; close (777) - call IO_read_realFile(777,'F_lambda_lastInc'//trim(rankStr),trim(getSolverJobName()),size(F_lambda_lastInc)) - read (777,rec=1) F_lambda_lastInc; close (777) - call IO_read_realFile(777,'F_aimDot',trim(getSolverJobName()),size(F_aimDot)) - read (777,rec=1) F_aimDot; close (777) - F_aim = reshape(sum(sum(sum(F,dim=4),dim=3),dim=2) * wgt, [3,3]) ! average of F - F_aim_lastInc = sum(sum(sum(F_lastInc,dim=5),dim=4),dim=3) * wgt ! average of F_lastInc - elseif (restartInc == 0_pInt) then restart - F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity - F = reshape(F_lastInc,[9,grid(1),grid(2),grid3]) - F_lambda = F - F_lambda_lastInc = F_lastInc - endif restart - - materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent - call Utilities_updateIPcoords(reshape(F,shape(F_lastInc))) - call Utilities_constitutiveResponse(P,temp33_Real,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2 - reshape(F,shape(F_lastInc)), & ! target F - 0.0_pReal, & ! time increment - math_I3) ! no rotation of boundary condition - nullify(F) - nullify(F_lambda) - call DMDAVecRestoreArrayF90(da,solution_vec,FandF_lambda,ierr); CHKERRQ(ierr) ! write data back to PETSc - - restartRead: if (restartInc > 0_pInt) then - if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & - write(6,'(/,a,'//IO_intOut(restartInc)//',a)') & - 'reading more values of increment ', restartInc, ' from file' - flush(6) - call IO_read_realFile(777,'C_volAvg',trim(getSolverJobName()),size(C_volAvg)) - read (777,rec=1) C_volAvg; close (777) - call IO_read_realFile(777,'C_volAvgLastInc',trim(getSolverJobName()),size(C_volAvgLastInc)) - read (777,rec=1) C_volAvgLastInc; close (777) - call IO_read_realFile(777,'C_ref',trim(getSolverJobName()),size(C_minMaxAvg)) - read (777,rec=1) C_minMaxAvg; close (777) - endif restartRead - - call Utilities_updateGamma(C_minMaxAvg,.true.) - C_scale = C_minMaxAvg - S_scale = math_invSym3333(C_minMaxAvg) - -end subroutine AL_init - - -!-------------------------------------------------------------------------------------------------- -!> @brief solution for the AL scheme with internal iterations -!-------------------------------------------------------------------------------------------------- -type(tSolutionState) function AL_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation_BC) - use IO, only: & - IO_error - use numerics, only: & - update_gamma - use math, only: & - math_invSym3333 - use spectral_utilities, only: & - tBoundaryCondition, & - Utilities_maskedCompliance, & - Utilities_updateGamma - use FEsolving, only: & - restartWrite, & - terminallyIll - - implicit none - -!-------------------------------------------------------------------------------------------------- -! input data for solution - character(len=*), intent(in) :: & - incInfoIn - real(pReal), intent(in) :: & - timeinc, & !< increment time for current solution - timeinc_old !< increment time of last successful increment - type(tBoundaryCondition), intent(in) :: & - stress_BC - real(pReal), dimension(3,3), intent(in) :: rotation_BC - -!-------------------------------------------------------------------------------------------------- -! PETSc Data - PetscErrorCode :: ierr - SNESConvergedReason :: reason - - external :: & - SNESSolve, & - SNESGetConvergedReason - - incInfo = incInfoIn - -!-------------------------------------------------------------------------------------------------- -! update stiffness (and gamma operator) - S = Utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) - if (update_gamma) then - call Utilities_updateGamma(C_minMaxAvg,restartWrite) - C_scale = C_minMaxAvg - S_scale = math_invSym3333(C_minMaxAvg) - endif - -!-------------------------------------------------------------------------------------------------- -! set module wide availabe data - mask_stress = stress_BC%maskFloat - params%stress_BC = stress_BC%values - params%rotation_BC = rotation_BC - params%timeinc = timeinc - params%timeincOld = timeinc_old - -!-------------------------------------------------------------------------------------------------- -! solve BVP - call SNESSolve(snes,PETSC_NULL_OBJECT,solution_vec,ierr); CHKERRQ(ierr) - -!-------------------------------------------------------------------------------------------------- -! check convergence - call SNESGetConvergedReason(snes,reason,ierr); CHKERRQ(ierr) - - AL_solution%converged = reason > 0 - AL_solution%iterationsNeeded = totalIter - AL_solution%termIll = terminallyIll - terminallyIll = .false. - if (reason == -4) call IO_error(893_pInt) ! MPI error - -end function AL_solution - - -!-------------------------------------------------------------------------------------------------- -!> @brief forms the AL residual vector -!-------------------------------------------------------------------------------------------------- -subroutine AL_formResidual(in,x_scal,f_scal,dummy,ierr) - use numerics, only: & - itmax, & - itmin, & - polarAlpha, & - polarBeta - use mesh, only: & - grid, & - grid3 - use IO, only: & - IO_intOut - use math, only: & - math_rotate_backward33, & - math_transpose33, & - math_mul3333xx33, & - math_invSym3333, & - math_mul33x33 - use debug, only: & - debug_level, & - debug_spectral, & - debug_spectralRotation - use spectral_utilities, only: & - wgt, & - tensorField_real, & - utilities_FFTtensorForward, & - utilities_fourierGammaConvolution, & - utilities_FFTtensorBackward, & - Utilities_constitutiveResponse, & - Utilities_divergenceRMS, & - Utilities_curlRMS - use homogenization, only: & - materialpoint_dPdF - use FEsolving, only: & - terminallyIll - - implicit none - DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: in - PetscScalar, & - target, dimension(3,3,2, XG_RANGE,YG_RANGE,ZG_RANGE), intent(in) :: x_scal !< what is this? - PetscScalar, & - target, dimension(3,3,2, X_RANGE,Y_RANGE,Z_RANGE), intent(out) :: f_scal !< what is this? - PetscScalar, pointer, dimension(:,:,:,:,:) :: & - F, & - F_lambda, & - residual_F, & - residual_F_lambda - PetscInt :: & - PETScIter, & - nfuncs - PetscObject :: dummy - PetscErrorCode :: ierr - integer(pInt) :: & - i, j, k, e - - external :: & - SNESGetNumberFunctionEvals, & - SNESGetIterationNumber - - F => x_scal(1:3,1:3,1,& - XG_RANGE,YG_RANGE,ZG_RANGE) - F_lambda => x_scal(1:3,1:3,2,& - XG_RANGE,YG_RANGE,ZG_RANGE) - residual_F => f_scal(1:3,1:3,1,& - X_RANGE, Y_RANGE, Z_RANGE) - residual_F_lambda => f_scal(1:3,1:3,2,& - X_RANGE, Y_RANGE, Z_RANGE) - - F_av = sum(sum(sum(F,dim=5),dim=4),dim=3) * wgt - call MPI_Allreduce(MPI_IN_PLACE,F_av,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) - - call SNESGetNumberFunctionEvals(snes,nfuncs,ierr); CHKERRQ(ierr) - call SNESGetIterationNumber(snes,PETScIter,ierr); CHKERRQ(ierr) - - if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1_pInt ! new increment -!-------------------------------------------------------------------------------------------------- -! begin of new iteration - newIteration: if (totalIter <= PETScIter) then - totalIter = totalIter + 1_pInt - write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') & - trim(incInfo), ' @ Iteration ', itmin, '≤',totalIter, '≤', itmax - if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & - write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & - ' deformation gradient aim (lab) =', math_transpose33(math_rotate_backward33(F_aim,params%rotation_BC)) - write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & - ' deformation gradient aim =', math_transpose33(F_aim) - flush(6) - endif newIteration - -!-------------------------------------------------------------------------------------------------- -! - tensorField_real = 0.0_pReal - do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt, grid(1) - tensorField_real(1:3,1:3,i,j,k) = & - polarBeta*math_mul3333xx33(C_scale,F(1:3,1:3,i,j,k) - math_I3) -& - polarAlpha*math_mul33x33(F(1:3,1:3,i,j,k), & - math_mul3333xx33(C_scale,F_lambda(1:3,1:3,i,j,k) - math_I3)) - enddo; enddo; enddo - -!-------------------------------------------------------------------------------------------------- -! doing convolution in Fourier space - call utilities_FFTtensorForward() - call utilities_fourierGammaConvolution(math_rotate_backward33(polarBeta*F_aim,params%rotation_BC)) - call utilities_FFTtensorBackward() - -!-------------------------------------------------------------------------------------------------- -! constructing F_lambda residual - residual_F_lambda = polarBeta*F - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) !< eq (16) in doi: 10.1016/j.ijplas.2014.02.006 - -!-------------------------------------------------------------------------------------------------- -! evaluate constitutive response - P_avLastEval = P_av - - call Utilities_constitutiveResponse(residual_F,P_av,C_volAvg,C_minMaxAvg, & - F - residual_F_lambda/polarBeta,params%timeinc, params%rotation_BC) - call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) - -!-------------------------------------------------------------------------------------------------- -! calculate divergence - tensorField_real = 0.0_pReal - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = residual_F !< stress field in disguise - call utilities_FFTtensorForward() - err_div = Utilities_divergenceRMS() !< root mean squared error in divergence of stress - -!-------------------------------------------------------------------------------------------------- -! constructing residual - e = 0_pInt - do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt, grid(1) - e = e + 1_pInt - residual_F(1:3,1:3,i,j,k) = math_mul3333xx33(math_invSym3333(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,e) + C_scale), & - residual_F(1:3,1:3,i,j,k) - & - math_mul33x33(F(1:3,1:3,i,j,k), & - math_mul3333xx33(C_scale,F_lambda(1:3,1:3,i,j,k) - math_I3))) & - + residual_F_lambda(1:3,1:3,i,j,k) !< eq (16) in doi: 10.1016/j.ijplas.2014.02.006 - enddo; enddo; enddo - -!-------------------------------------------------------------------------------------------------- -! calculating curl - tensorField_real = 0.0_pReal - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = F - call utilities_FFTtensorForward() - err_curl = Utilities_curlRMS() - - nullify(F) - nullify(F_lambda) - nullify(residual_F) - nullify(residual_F_lambda) -end subroutine AL_formResidual - - -!-------------------------------------------------------------------------------------------------- -!> @brief convergence check -!-------------------------------------------------------------------------------------------------- -subroutine AL_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) - use numerics, only: & - itmax, & - itmin, & - err_div_tolRel, & - err_div_tolAbs, & - err_curl_tolRel, & - err_curl_tolAbs, & - err_stress_tolRel, & - err_stress_tolAbs - use math, only: & - math_mul3333xx33 - use FEsolving, only: & - terminallyIll - - implicit none - SNES :: snes_local - PetscInt :: PETScIter - PetscReal :: & - xnorm, & - snorm, & - fnorm - SNESConvergedReason :: reason - PetscObject :: dummy - PetscErrorCode :: ierr - real(pReal) :: & - curlTol, & - divTol, & - BCTol - -!-------------------------------------------------------------------------------------------------- -! stress BC handling - F_aim = F_aim - math_mul3333xx33(S, ((P_av - params%stress_BC))) ! S = 0.0 for no bc - err_BC = maxval(abs((1.0_pReal-mask_stress) * math_mul3333xx33(C_scale,F_aim-F_av) + & - mask_stress * (P_av-params%stress_BC))) ! mask = 0.0 for no bc - -!-------------------------------------------------------------------------------------------------- -! error calculation - curlTol = max(maxval(abs(F_aim-math_I3))*err_curl_tolRel ,err_curl_tolAbs) - divTol = max(maxval(abs(P_av)) *err_div_tolRel ,err_div_tolAbs) - BCTol = max(maxval(abs(P_av)) *err_stress_tolRel,err_stress_tolAbs) - - converged: if ((totalIter >= itmin .and. & - all([ err_div /divTol, & - err_curl/curlTol, & - err_BC /BCTol ] < 1.0_pReal)) & - .or. terminallyIll) then - reason = 1 - elseif (totalIter >= itmax) then converged - reason = -1 - else converged - reason = 0 - endif converged - -!-------------------------------------------------------------------------------------------------- -! report - write(6,'(1/,a)') ' ... reporting .............................................................' - write(6,'(/,a,f12.2,a,es8.2,a,es9.2,a)') ' error divergence = ', & - err_div/divTol, ' (',err_div, ' / m, tol = ',divTol,')' - write(6, '(a,f12.2,a,es8.2,a,es9.2,a)') ' error curl = ', & - err_curl/curlTol,' (',err_curl,' -, tol = ',curlTol,')' - write(6, '(a,f12.2,a,es8.2,a,es9.2,a)') ' error BC = ', & - err_BC/BCTol, ' (',err_BC, ' Pa, tol = ',BCTol,')' - write(6,'(/,a)') ' ===========================================================================' - flush(6) - -end subroutine AL_converged - -!-------------------------------------------------------------------------------------------------- -!> @brief forwarding routine -!> @details find new boundary conditions and best F estimate for end of current timestep -!> possibly writing restart information, triggering of state increment in DAMASK, and updating of IPcoordinates -!-------------------------------------------------------------------------------------------------- -subroutine AL_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) - use math, only: & - math_mul33x33, & - math_mul3333xx33, & - math_transpose33, & - math_rotate_backward33 - use numerics, only: & - worldrank - use homogenization, only: & - materialpoint_F0 - use mesh, only: & - grid, & - grid3 - use CPFEM2, only: & - CPFEM_age - use spectral_utilities, only: & - Utilities_calculateRate, & - Utilities_forwardField, & - Utilities_updateIPcoords, & - tBoundaryCondition, & - cutBack - use IO, only: & - IO_write_JobRealFile - use FEsolving, only: & - restartWrite - - implicit none - logical, intent(in) :: & - guess - real(pReal), intent(in) :: & - timeinc_old, & - timeinc, & - loadCaseTime !< remaining time of current load case - type(tBoundaryCondition), intent(in) :: & - stress_BC, & - deformation_BC - real(pReal), dimension(3,3), intent(in) ::& - rotation_BC - PetscErrorCode :: ierr - PetscScalar, dimension(:,:,:,:), pointer :: FandF_lambda, F, F_lambda - integer(pInt) :: i, j, k - real(pReal), dimension(3,3) :: F_lambda33 - character(len=32) :: rankStr - -!-------------------------------------------------------------------------------------------------- -! update coordinates and rate and forward last inc - call DMDAVecGetArrayF90(da,solution_vec,FandF_lambda,ierr); CHKERRQ(ierr) - F => FandF_lambda( 0: 8,:,:,:) - F_lambda => FandF_lambda( 9:17,:,:,:) - - if (cutBack) then - C_volAvg = C_volAvgLastInc ! QUESTION: where is this required? - C_minMaxAvg = C_minMaxAvgLastInc ! QUESTION: where is this required? - else - !-------------------------------------------------------------------------------------------------- - ! restart information for spectral solver - if (restartWrite) then ! QUESTION: where is this logical properly set? - write(6,'(/,a)') ' writing converged results for restart' - flush(6) - - if (worldrank == 0_pInt) then - call IO_write_jobRealFile(777,'C_volAvg',size(C_volAvg)) - write (777,rec=1) C_volAvg; close(777) - call IO_write_jobRealFile(777,'C_volAvgLastInc',size(C_volAvgLastInc)) - write (777,rec=1) C_volAvgLastInc; close(777) - ! call IO_write_jobRealFile(777,'C_minMaxAvg',size(C_volAvg)) - ! write (777,rec=1) C_minMaxAvg; close(777) - ! call IO_write_jobRealFile(777,'C_minMaxAvgLastInc',size(C_volAvgLastInc)) - ! write (777,rec=1) C_minMaxAvgLastInc; close(777) - call IO_write_jobRealFile(777,'F_aimDot',size(F_aimDot)) - write (777,rec=1) F_aimDot; close(777) - endif - - write(rankStr,'(a1,i0)')'_',worldrank - call IO_write_jobRealFile(777,'F'//trim(rankStr),size(F)) ! writing deformation gradient field to file - write (777,rec=1) F; close (777) - call IO_write_jobRealFile(777,'F_lastInc'//trim(rankStr),size(F_lastInc)) ! writing F_lastInc field to file - write (777,rec=1) F_lastInc; close (777) - call IO_write_jobRealFile(777,'F_lambda'//trim(rankStr),size(F_lambda)) ! writing deformation gradient field to file - write (777,rec=1) F_lambda; close (777) - call IO_write_jobRealFile(777,'F_lambda_lastInc'//trim(rankStr),size(F_lambda_lastInc)) ! writing F_lastInc field to file - write (777,rec=1) F_lambda_lastInc; close (777) - endif - - call CPFEM_age() ! age state and kinematics - call utilities_updateIPcoords(F) - - C_volAvgLastInc = C_volAvg - C_minMaxAvgLastInc = C_minMaxAvg - - if (guess) then ! QUESTION: better with a = L ? x:y - F_aimDot = stress_BC%maskFloat * (F_aim - F_aim_lastInc)/timeinc_old ! initialize with correction based on last inc - else - F_aimDot = 0.0_pReal - endif - F_aim_lastInc = F_aim - !-------------------------------------------------------------------------------------------------- - ! calculate rate for aim - if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F - F_aimDot = & - F_aimDot + deformation_BC%maskFloat * math_mul33x33(deformation_BC%values, F_aim_lastInc) - elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed - F_aimDot = & - F_aimDot + deformation_BC%maskFloat * deformation_BC%values - elseif (deformation_BC%myType=='f') then ! aim at end of load case is prescribed - F_aimDot = & - F_aimDot + deformation_BC%maskFloat * (deformation_BC%values - F_aim_lastInc)/loadCaseTime - endif - - - Fdot = Utilities_calculateRate(guess, & - F_lastInc,reshape(F,[3,3,grid(1),grid(2),grid3]),timeinc_old, & - math_rotate_backward33(F_aimDot,rotation_BC)) - F_lambdaDot = Utilities_calculateRate(guess, & - F_lambda_lastInc,reshape(F_lambda,[3,3,grid(1),grid(2),grid3]), timeinc_old, & - math_rotate_backward33(F_aimDot,rotation_BC)) - F_lastInc = reshape(F, [3,3,grid(1),grid(2),grid3]) ! winding F forward - F_lambda_lastInc = reshape(F_lambda, [3,3,grid(1),grid(2),grid3]) ! winding F_lambda forward - materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent - endif - -!-------------------------------------------------------------------------------------------------- -! update average and local deformation gradients - F_aim = F_aim_lastInc + F_aimDot * timeinc - - F = reshape(Utilities_forwardField(timeinc,F_lastInc,Fdot, & ! estimate of F at end of time+timeinc that matches rotated F_aim on average - math_rotate_backward33(F_aim,rotation_BC)),& - [9,grid(1),grid(2),grid3]) - if (guess) then - F_lambda = reshape(Utilities_forwardField(timeinc,F_lambda_lastInc,F_lambdadot), & - [9,grid(1),grid(2),grid3]) ! does not have any average value as boundary condition - else - do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt, grid(1) - F_lambda33 = reshape(F_lambda(1:9,i,j,k),[3,3]) - F_lambda33 = math_mul3333xx33(S_scale,math_mul33x33(F_lambda33, & - math_mul3333xx33(C_scale,& - math_mul33x33(math_transpose33(F_lambda33),& - F_lambda33) -math_I3))*0.5_pReal)& - + math_I3 - F_lambda(1:9,i,j,k) = reshape(F_lambda33,[9]) - enddo; enddo; enddo - endif - - nullify(F) - nullify(F_lambda) - call DMDAVecRestoreArrayF90(da,solution_vec,FandF_lambda,ierr); CHKERRQ(ierr) - -end subroutine AL_forward - -!-------------------------------------------------------------------------------------------------- -!> @brief destroy routine -!-------------------------------------------------------------------------------------------------- -subroutine AL_destroy() - use spectral_utilities, only: & - Utilities_destroy - - implicit none - PetscErrorCode :: ierr - - external :: & - VecDestroy, & - SNESDestroy, & - DMDestroy - - call VecDestroy(solution_vec,ierr); CHKERRQ(ierr) - call SNESDestroy(snes,ierr); CHKERRQ(ierr) - call DMDestroy(da,ierr); CHKERRQ(ierr) - -end subroutine AL_destroy - -end module spectral_mech_AL diff --git a/src/spectral_mech_Basic.f90 b/src/spectral_mech_Basic.f90 index bef70153d..1c949bb7b 100644 --- a/src/spectral_mech_Basic.f90 +++ b/src/spectral_mech_Basic.f90 @@ -5,6 +5,10 @@ !> @brief Basic scheme PETSc solver !-------------------------------------------------------------------------------------------------- module spectral_mech_basic +#include +#include + use PETScdmda + use PETScsnes use prec, only: & pInt, & pReal @@ -16,10 +20,9 @@ module spectral_mech_basic implicit none private -#include character (len=*), parameter, public :: & - DAMASK_spectral_SolverBasicPETSC_label = 'basicpetsc' + DAMASK_spectral_SolverBasicPETSC_label = 'basic' !-------------------------------------------------------------------------------------------------- ! derived types @@ -64,13 +67,9 @@ module spectral_mech_basic public :: & basicPETSc_init, & basicPETSc_solution, & - BasicPETSc_forward, & - basicPETSc_destroy + BasicPETSc_forward external :: & - PETScFinalize, & - MPI_Abort, & - MPI_Bcast, & - MPI_Allreduce + PETScErrorF ! is called in the CHKERRQ macro contains @@ -118,25 +117,18 @@ subroutine basicPETSc_init PetscErrorCode :: ierr PetscScalar, pointer, dimension(:,:,:,:) :: F - - integer(pInt), dimension(:), allocatable :: localK + PetscInt, dimension(:), allocatable :: localK integer(pInt) :: proc character(len=1024) :: rankStr external :: & - SNESCreate, & SNESSetOptionsPrefix, & - DMDACreate3D, & - SNESSetDM, & - DMCreateGlobalVector, & - DMDASNESSetFunctionLocal, & - SNESGetConvergedReason, & SNESSetConvergenceTest, & - SNESSetFromOptions + DMDASNESsetFunctionLocal write(6,'(/,a)') ' <<<+- DAMASK_spectral_solverBasicPETSc init -+>>>' write(6,'(/,a)') ' Shanthraj et al., International Journal of Plasticity, 66:31–45, 2015' - write(6,'(/,a)') ' https://doi.org/10.1016/j.ijplas.2014.02.006' + write(6,'(a,/)') ' https://doi.org/10.1016/j.ijplas.2014.02.006' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" @@ -159,16 +151,18 @@ subroutine basicPETSc_init grid(1),grid(2),grid(3), & ! global grid 1 , 1, worldsize, & 9, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) - grid(1),grid(2),localK, & ! local grid + [grid(1)],[grid(2)],localK, & ! local grid da,ierr) ! handle, error CHKERRQ(ierr) call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) ! connect snes to da - call DMCreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 9, i.e. every def grad tensor) - call DMDASNESSetFunctionLocal(da,INSERT_VALUES,BasicPETSC_formResidual,PETSC_NULL_OBJECT,ierr) ! residual vector of same shape as solution vector + call DMsetFromOptions(da,ierr); CHKERRQ(ierr) + call DMsetUp(da,ierr); CHKERRQ(ierr) + call DMcreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 9, i.e. every def grad tensor) + call DMDASNESsetFunctionLocal(da,INSERT_VALUES,BasicPETSC_formResidual,PETSC_NULL_SNES,ierr) ! residual vector of same shape as solution vector CHKERRQ(ierr) - call SNESSetConvergenceTest(snes,BasicPETSC_converged,PETSC_NULL_OBJECT,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "_converged" + call SNESsetConvergenceTest(snes,BasicPETSC_converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "_converged" CHKERRQ(ierr) - call SNESSetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional cli arguments + call SNESsetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional CLI arguments !-------------------------------------------------------------------------------------------------- ! init fields @@ -255,8 +249,7 @@ type(tSolutionState) function basicPETSc_solution(incInfoIn,timeinc,timeinc_old, SNESConvergedReason :: reason external :: & - SNESSolve, & - SNESGetConvergedReason + SNESsolve incInfo = incInfoIn @@ -276,7 +269,7 @@ type(tSolutionState) function basicPETSc_solution(incInfoIn,timeinc,timeinc_old, !-------------------------------------------------------------------------------------------------- ! solve BVP - call SNESSolve(snes,PETSC_NULL_OBJECT,solution_vec,ierr); CHKERRQ(ierr) + call SNESsolve(snes,PETSC_NULL_VEC,solution_vec,ierr); CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! check convergence @@ -334,10 +327,6 @@ subroutine BasicPETSC_formResidual(in,x_scal,f_scal,dummy,ierr) real(pReal), dimension(3,3) :: & deltaF_aim - external :: & - SNESGetNumberFunctionEvals, & - SNESGetIterationNumber - call SNESGetNumberFunctionEvals(snes,nfuncs,ierr); CHKERRQ(ierr) call SNESGetIterationNumber(snes,PETScIter,ierr); CHKERRQ(ierr) @@ -551,25 +540,4 @@ subroutine BasicPETSc_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation end subroutine BasicPETSc_forward -!-------------------------------------------------------------------------------------------------- -!> @brief destroy routine -!-------------------------------------------------------------------------------------------------- -subroutine BasicPETSc_destroy() - use spectral_utilities, only: & - Utilities_destroy - - implicit none - PetscErrorCode :: ierr - - external :: & - VecDestroy, & - SNESDestroy, & - DMDestroy - - call VecDestroy(solution_vec,ierr); CHKERRQ(ierr) - call SNESDestroy(snes,ierr); CHKERRQ(ierr) - call DMDestroy(da,ierr); CHKERRQ(ierr) - -end subroutine BasicPETSc_destroy - end module spectral_mech_basic diff --git a/src/spectral_mech_Polarisation.f90 b/src/spectral_mech_Polarisation.f90 index 02e0e0ab8..9e567f0c9 100644 --- a/src/spectral_mech_Polarisation.f90 +++ b/src/spectral_mech_Polarisation.f90 @@ -5,6 +5,10 @@ !> @brief Polarisation scheme solver !-------------------------------------------------------------------------------------------------- module spectral_mech_Polarisation +#include +#include + use PETScdmda + use PETScsnes use prec, only: & pInt, & pReal @@ -16,7 +20,6 @@ module spectral_mech_Polarisation implicit none private -#include character (len=*), parameter, public :: & DAMASK_spectral_solverPolarisation_label = 'polarisation' @@ -70,13 +73,9 @@ module spectral_mech_Polarisation public :: & Polarisation_init, & Polarisation_solution, & - Polarisation_forward, & - Polarisation_destroy + Polarisation_forward external :: & - PETScFinalize, & - MPI_Abort, & - MPI_Bcast, & - MPI_Allreduce + PETScErrorF ! is called in the CHKERRQ macro contains @@ -125,28 +124,21 @@ subroutine Polarisation_init PetscErrorCode :: ierr PetscScalar, pointer, dimension(:,:,:,:) :: & - FandF_tau, & ! overall pointer to solution data - F, & ! specific (sub)pointer - F_tau ! specific (sub)pointer - - integer(pInt), dimension(:), allocatable :: localK + FandF_tau, & ! overall pointer to solution data + F, & ! specific (sub)pointer + F_tau ! specific (sub)pointer + PetscInt, dimension(:), allocatable :: localK integer(pInt) :: proc character(len=1024) :: rankStr external :: & - SNESCreate, & SNESSetOptionsPrefix, & - DMDACreate3D, & - SNESSetDM, & - DMCreateGlobalVector, & - DMDASNESSetFunctionLocal, & - SNESGetConvergedReason, & SNESSetConvergenceTest, & - SNESSetFromOptions + DMDASNESsetFunctionLocal write(6,'(/,a)') ' <<<+- DAMASK_spectral_solverPolarisation init -+>>>' write(6,'(/,a)') ' Shanthraj et al., International Journal of Plasticity, 66:31–45, 2015' - write(6,'(/,a)') ' https://doi.org/10.1016/j.ijplas.2014.02.006' + write(6,'(a,/)') ' https://doi.org/10.1016/j.ijplas.2014.02.006' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" @@ -171,16 +163,18 @@ subroutine Polarisation_init grid(1),grid(2),grid(3), & ! global grid 1 , 1, worldsize, & 18, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) - grid(1),grid(2),localK, & ! local grid + [grid(1)],[grid(2)],localK, & ! local grid da,ierr) ! handle, error CHKERRQ(ierr) call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) ! connect snes to da - call DMCreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 9, i.e. every def grad tensor) - call DMDASNESSetFunctionLocal(da,INSERT_VALUES,Polarisation_formResidual,PETSC_NULL_OBJECT,ierr) ! residual vector of same shape as solution vector + call DMsetFromOptions(da,ierr); CHKERRQ(ierr) + call DMsetUp(da,ierr); CHKERRQ(ierr) + call DMcreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 18, i.e. every def grad tensor) + call DMDASNESsetFunctionLocal(da,INSERT_VALUES,Polarisation_formResidual,PETSC_NULL_SNES,ierr) ! residual vector of same shape as solution vector CHKERRQ(ierr) - call SNESSetConvergenceTest(snes,Polarisation_converged,PETSC_NULL_OBJECT,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "_converged" + call SNESsetConvergenceTest(snes,Polarisation_converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "_converged" CHKERRQ(ierr) - call SNESSetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional cli arguments + call SNESsetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional CLI arguments !-------------------------------------------------------------------------------------------------- ! init fields @@ -280,8 +274,7 @@ type(tSolutionState) function Polarisation_solution(incInfoIn,timeinc,timeinc_ol SNESConvergedReason :: reason external :: & - SNESSolve, & - SNESGetConvergedReason + SNESSolve incInfo = incInfoIn @@ -304,7 +297,7 @@ type(tSolutionState) function Polarisation_solution(incInfoIn,timeinc,timeinc_ol !-------------------------------------------------------------------------------------------------- ! solve BVP - call SNESSolve(snes,PETSC_NULL_OBJECT,solution_vec,ierr); CHKERRQ(ierr) + call SNESsolve(snes,PETSC_NULL_VEC,solution_vec,ierr); CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! check convergence @@ -375,10 +368,6 @@ subroutine Polarisation_formResidual(in,x_scal,f_scal,dummy,ierr) integer(pInt) :: & i, j, k, e - external :: & - SNESGetNumberFunctionEvals, & - SNESGetIterationNumber - F => x_scal(1:3,1:3,1,& XG_RANGE,YG_RANGE,ZG_RANGE) F_tau => x_scal(1:3,1:3,2,& @@ -685,25 +674,4 @@ subroutine Polarisation_forward(guess,timeinc,timeinc_old,loadCaseTime,deformati end subroutine Polarisation_forward -!-------------------------------------------------------------------------------------------------- -!> @brief destroy routine -!-------------------------------------------------------------------------------------------------- -subroutine Polarisation_destroy() - use spectral_utilities, only: & - Utilities_destroy - - implicit none - PetscErrorCode :: ierr - - external :: & - VecDestroy, & - SNESDestroy, & - DMDestroy - - call VecDestroy(solution_vec,ierr); CHKERRQ(ierr) - call SNESDestroy(snes,ierr); CHKERRQ(ierr) - call DMDestroy(da,ierr); CHKERRQ(ierr) - -end subroutine Polarisation_destroy - end module spectral_mech_Polarisation diff --git a/src/spectral_thermal.f90 b/src/spectral_thermal.f90 index ff318f395..8e5b95ab9 100644 --- a/src/spectral_thermal.f90 +++ b/src/spectral_thermal.f90 @@ -4,6 +4,10 @@ !> @brief Spectral solver for thermal conduction !-------------------------------------------------------------------------------------------------- module spectral_thermal +#include +#include + use PETScdmda + use PETScsnes use prec, only: & pInt, & pReal @@ -18,7 +22,6 @@ module spectral_thermal implicit none private -#include character (len=*), parameter, public :: & spectral_thermal_label = 'spectralthermal' @@ -46,13 +49,9 @@ module spectral_thermal public :: & spectral_thermal_init, & spectral_thermal_solution, & - spectral_thermal_forward, & - spectral_thermal_destroy + spectral_thermal_forward external :: & - PETScFinalize, & - MPI_Abort, & - MPI_Bcast, & - MPI_Allreduce + PETScErrorF ! is called in the CHKERRQ macro contains @@ -92,22 +91,15 @@ subroutine spectral_thermal_init PetscErrorCode :: ierr external :: & - SNESCreate, & - SNESSetOptionsPrefix, & - DMDACreate3D, & - SNESSetDM, & - DMDAGetCorners, & - DMCreateGlobalVector, & - DMDASNESSetFunctionLocal, & - SNESSetFromOptions + SNESsetOptionsPrefix, & + DMDAgetCorners, & + DMDASNESsetFunctionLocal - mainProcess: if (worldrank == 0_pInt) then - write(6,'(/,a)') ' <<<+- spectral_thermal init -+>>>' - write(6,'(/,a)') ' Shanthraj et al., Handbook of Mechanics of Materials, volume in press,' - write(6,'(/,a)') ' chapter Spectral Solvers for Crystal Plasticity and Multi-Physics Simulations. Springer, 2018' - write(6,'(a15,a)') ' Current time: ',IO_timeStamp() + write(6,'(/,a)') ' <<<+- spectral_thermal init -+>>>' + write(6,'(/,a)') ' Shanthraj et al., Handbook of Mechanics of Materials, volume in press,' + write(6,'(/,a)') ' chapter Spectral Solvers for Crystal Plasticity and Multi-Physics Simulations. Springer, 2018' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" - endif mainProcess !-------------------------------------------------------------------------------------------------- ! initialize solver specific parts of PETSc @@ -117,21 +109,23 @@ subroutine spectral_thermal_init do proc = 1, worldsize call MPI_Bcast(localK(proc),1,MPI_INTEGER,proc-1,PETSC_COMM_WORLD,ierr) enddo - call DMDACreate3d(PETSC_COMM_WORLD, & + call DMDACreate3D(PETSC_COMM_WORLD, & DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point grid(1),grid(2),grid(3), & ! global grid 1, 1, worldsize, & - 1, 0, & ! #dof (temperature field), ghost boundary width (domain overlap) - grid (1),grid(2),localK, & ! local grid - thermal_grid,ierr) ! handle, error + 1, 0, & !< #dof (thermal phase field), ghost boundary width (domain overlap) + [grid(1)],[grid(2)],localK, & !< local grid + thermal_grid,ierr) !< handle, error CHKERRQ(ierr) call SNESSetDM(thermal_snes,thermal_grid,ierr); CHKERRQ(ierr) ! connect snes to da + call DMsetFromOptions(thermal_grid,ierr); CHKERRQ(ierr) + call DMsetUp(thermal_grid,ierr); CHKERRQ(ierr) call DMCreateGlobalVector(thermal_grid,solution ,ierr); CHKERRQ(ierr) ! global solution vector (grid x 1, i.e. every def grad tensor) call DMDASNESSetFunctionLocal(thermal_grid,INSERT_VALUES,spectral_thermal_formResidual,& - PETSC_NULL_OBJECT,ierr) ! residual vector of same shape as solution vector + PETSC_NULL_SNES,ierr) ! residual vector of same shape as solution vector CHKERRQ(ierr) - call SNESSetFromOptions(thermal_snes,ierr); CHKERRQ(ierr) ! pull it all together with additional cli arguments + call SNESSetFromOptions(thermal_snes,ierr); CHKERRQ(ierr) ! pull it all together with additional CLI arguments !-------------------------------------------------------------------------------------------------- ! init fields @@ -207,8 +201,7 @@ type(tSolutionState) function spectral_thermal_solution(timeinc,timeinc_old,load external :: & VecMin, & VecMax, & - SNESSolve, & - SNESGetConvergedReason + SNESSolve spectral_thermal_solution%converged =.false. @@ -217,7 +210,7 @@ type(tSolutionState) function spectral_thermal_solution(timeinc,timeinc_old,load params%timeinc = timeinc params%timeincOld = timeinc_old - call SNESSolve(thermal_snes,PETSC_NULL_OBJECT,solution,ierr); CHKERRQ(ierr) + call SNESSolve(thermal_snes,PETSC_NULL_VEC,solution,ierr); CHKERRQ(ierr) call SNESGetConvergedReason(thermal_snes,reason,ierr); CHKERRQ(ierr) if (reason < 1) then @@ -246,15 +239,13 @@ type(tSolutionState) function spectral_thermal_solution(timeinc,timeinc_old,load enddo; enddo; enddo call VecMin(solution,position,minTemperature,ierr); CHKERRQ(ierr) - call VecMax(solution,position,maxTemperature,ierr); CHKERRQ(ierr) - if (worldrank == 0) then - if (spectral_thermal_solution%converged) & - write(6,'(/,a)') ' ... thermal conduction converged ..................................' - write(6,'(/,a,f8.4,2x,f8.4,2x,f8.4,/)',advance='no') ' Minimum|Maximum|Delta Temperature / K = ',& + call VecMax(solution,position,maxTemperature,ierr); CHKERRQ(ierr) + if (spectral_thermal_solution%converged) & + write(6,'(/,a)') ' ... thermal conduction converged ..................................' + write(6,'(/,a,f8.4,2x,f8.4,2x,f8.4,/)',advance='no') ' Minimum|Maximum|Delta Temperature / K = ',& minTemperature, maxTemperature, stagNorm - write(6,'(/,a)') ' ===========================================================================' - flush(6) - endif + write(6,'(/,a)') ' ===========================================================================' + flush(6) end function spectral_thermal_solution @@ -361,9 +352,6 @@ subroutine spectral_thermal_forward() PetscScalar, dimension(:,:,:), pointer :: x_scal PetscErrorCode :: ierr - external :: & - SNESGetDM - if (cutBack) then temperature_current = temperature_lastInc temperature_stagInc = temperature_lastInc @@ -401,23 +389,6 @@ subroutine spectral_thermal_forward() call MPI_Allreduce(MPI_IN_PLACE,mobility_ref,1,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) endif - end subroutine spectral_thermal_forward - -!-------------------------------------------------------------------------------------------------- -!> @brief destroy routine -!-------------------------------------------------------------------------------------------------- -subroutine spectral_thermal_destroy() - - implicit none - PetscErrorCode :: ierr - - external :: & - VecDestroy, & - SNESDestroy - - call VecDestroy(solution,ierr); CHKERRQ(ierr) - call SNESDestroy(thermal_snes,ierr); CHKERRQ(ierr) - -end subroutine spectral_thermal_destroy +end subroutine spectral_thermal_forward end module spectral_thermal diff --git a/src/spectral_utilities.f90 b/src/spectral_utilities.f90 index 4289d7829..b209ab2ea 100644 --- a/src/spectral_utilities.f90 +++ b/src/spectral_utilities.f90 @@ -5,6 +5,8 @@ !-------------------------------------------------------------------------------------------------- module spectral_utilities use, intrinsic :: iso_c_binding +#include + use PETScSys use prec, only: & pReal, & pInt @@ -13,7 +15,6 @@ module spectral_utilities implicit none private -#include include 'fftw3-mpi.f03' logical, public :: cutBack = .false. !< cut back of BVP solver in case convergence is not achieved or a material point is terminally ill @@ -139,7 +140,6 @@ module spectral_utilities utilities_constitutiveResponse, & utilities_calculateRate, & utilities_forwardField, & - utilities_destroy, & utilities_updateIPcoords, & FIELD_UNDEFINED_ID, & FIELD_MECH_ID, & @@ -147,6 +147,8 @@ module spectral_utilities FIELD_DAMAGE_ID private :: & utilities_getFreqDerivative + external :: & + PETScErrorF ! is called in the CHKERRQ macro contains @@ -195,12 +197,6 @@ subroutine utilities_init() geomSize implicit none - - external :: & - PETScOptionsClear, & - PETScOptionsInsertString, & - MPI_Abort - PetscErrorCode :: ierr integer(pInt) :: i, j, k integer(pInt), dimension(3) :: k_s @@ -214,10 +210,12 @@ subroutine utilities_init() scalarSize = 1_C_INTPTR_T, & vecSize = 3_C_INTPTR_T, & tensorSize = 9_C_INTPTR_T + external :: & + PetscOptionsInsertString write(6,'(/,a)') ' <<<+- spectral_utilities init -+>>>' write(6,'(/,a)') ' Eisenlohr et al., International Journal of Plasticity, 46:37–53, 2013' - write(6,'(/,a)') ' https://doi.org/10.1016/j.ijplas.2012.09.012' + write(6,'(a,/)') ' https://doi.org/10.1016/j.ijplas.2012.09.012' write(6,'(a15,a)') ' Current time: ',IO_timeStamp() #include "compilation_info.f90" @@ -232,13 +230,13 @@ subroutine utilities_init() trim(PETScDebug), & ' add more using the PETSc_Options keyword in numerics.config '; flush(6) - call PetscOptionsClear(PETSC_NULL_OBJECT,ierr) + call PETScOptionsClear(PETSC_NULL_OPTIONS,ierr) CHKERRQ(ierr) - if(debugPETSc) call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(PETSCDEBUG),ierr) + if(debugPETSc) call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(PETSCDEBUG),ierr) CHKERRQ(ierr) - call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(petsc_defaultOptions),ierr) + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_defaultOptions),ierr) CHKERRQ(ierr) - call PetscOptionsInsertString(PETSC_NULL_OBJECT,trim(petsc_options),ierr) + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) CHKERRQ(ierr) grid1Red = grid(1)/2_pInt + 1_pInt @@ -632,9 +630,6 @@ real(pReal) function utilities_divergenceRMS() integer(pInt) :: i, j, k, ierr complex(pReal), dimension(3) :: rescaledGeom - external :: & - MPI_Allreduce - write(6,'(/,a)') ' ... calculating divergence ................................................' flush(6) @@ -686,9 +681,6 @@ real(pReal) function utilities_curlRMS() complex(pReal), dimension(3,3) :: curl_fourier complex(pReal), dimension(3) :: rescaledGeom - external :: & - MPI_Allreduce - write(6,'(/,a)') ' ... calculating curl ......................................................' flush(6) @@ -962,9 +954,6 @@ subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,& real(pReal), dimension(3,3,3,3) :: max_dPdF, min_dPdF real(pReal) :: max_dPdF_norm, min_dPdF_norm, defgradDetMin, defgradDetMax, defgradDet - external :: & - MPI_Allreduce - write(6,'(/,a)') ' ... evaluating constitutive response ......................................' flush(6) @@ -1081,9 +1070,6 @@ function utilities_forwardField(timeinc,field_lastInc,rate,aim) real(pReal), dimension(3,3) :: fieldDiff !< - aim PetscErrorCode :: ierr - external :: & - MPI_Allreduce - utilities_forwardField = field_lastInc + rate*timeinc if (present(aim)) then !< correct to match average fieldDiff = sum(sum(sum(utilities_forwardField,dim=5),dim=4),dim=3)*wgt @@ -1175,8 +1161,6 @@ subroutine utilities_updateIPcoords(F) integer(pInt) :: i, j, k, m, ierr real(pReal), dimension(3) :: step, offset_coords real(pReal), dimension(3,3) :: Favg - external & - MPI_Bcast !-------------------------------------------------------------------------------------------------- ! integration in Fourier space @@ -1215,21 +1199,4 @@ subroutine utilities_updateIPcoords(F) end subroutine utilities_updateIPcoords - -!-------------------------------------------------------------------------------------------------- -!> @brief cleans up -!-------------------------------------------------------------------------------------------------- -subroutine utilities_destroy() - implicit none - - call fftw_destroy_plan(planTensorForth) - call fftw_destroy_plan(planTensorBack) - call fftw_destroy_plan(planVectorForth) - call fftw_destroy_plan(planVectorBack) - call fftw_destroy_plan(planScalarForth) - call fftw_destroy_plan(planScalarBack) - -end subroutine utilities_destroy - - end module spectral_utilities diff --git a/src/system_routines.f90 b/src/system_routines.f90 index 07e12a20b..2740011b4 100644 --- a/src/system_routines.f90 +++ b/src/system_routines.f90 @@ -10,11 +10,12 @@ module system_routines public :: & isDirectory, & getCWD, & - getHostName + getHostName, & + setCWD interface - function isDirectory_C(path) BIND(C) + function isDirectory_C(path) bind(C) use, intrinsic :: ISO_C_Binding, only: & C_INT, & C_CHAR @@ -38,6 +39,14 @@ interface integer(C_INT),intent(out) :: stat end subroutine getHostName_C + function chdir_C(path) bind(C) + use, intrinsic :: ISO_C_Binding, only: & + C_INT, & + C_CHAR + integer(C_INT) :: chdir_C + character(kind=C_CHAR), dimension(1024), intent(in) :: path ! C string is an array + end function chdir_C + end interface @@ -123,5 +132,27 @@ logical function getHostName(str) 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 + + 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 + end module system_routines