diff --git a/.gitattributes b/.gitattributes index 6bc316a77..9d1380127 100644 --- a/.gitattributes +++ b/.gitattributes @@ -14,7 +14,7 @@ # ignore files from MSC.Marc in language statistics install/MarcMentat/** linguist-vendored src/Marc/include/* linguist-vendored -install/MarcMentat/apply_DAMASK_modifications.py linguist-vendored=false +install/MarcMentat/MSC_modifications.py linguist-vendored=false # ignore reference files for tests in language statistics python/tests/reference/** linguist-vendored diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 2dd33b072..d40cc1d75 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -47,7 +47,7 @@ variables: PETSC_INTELLLVM: "Libraries/PETSc/3.16.3/oneAPI-2022.0.1-IntelMPI-2021.5.0" PETSC_INTEL: "Libraries/PETSc/3.16.5/Intel-2022.0.1-IntelMPI-2021.5.0" # ++++++++++++ MSC Marc +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - MSC: "FEM/MSC/2022.2" + MSC: "FEM/MSC/2022.3" IntelMarc: "Compiler/Intel/19.1.2 Libraries/IMKL/2020" HDF5Marc: "HDF5/1.12.2/Intel-19.1.2" diff --git a/PRIVATE b/PRIVATE index ecfe3b3f0..e9254133c 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit ecfe3b3f057f4f81b3b1a12399bf238bc2546de7 +Subproject commit e9254133c1e9ea3855a4fd17078d4c6f7d8728b1 diff --git a/VERSION b/VERSION index e1724f8bb..a52014503 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -3.0.0-alpha7-171-g26ff1b895 +3.0.0-alpha7-220-g85115d12f diff --git a/examples/config/phase/thermal/source/externalheat_ramp-and-hold.yaml b/examples/config/phase/thermal/source/externalheat_ramp-and-hold.yaml index 3567f55cf..e6cc8f509 100644 --- a/examples/config/phase/thermal/source/externalheat_ramp-and-hold.yaml +++ b/examples/config/phase/thermal/source/externalheat_ramp-and-hold.yaml @@ -1,4 +1,4 @@ type: externalheat -f_T: [1, 1, 0, 0] -t_n: [0, 500, 500.001, 1000] +f: [1, 1, 0, 0] +t: [0, 500, 500.001, 1000] diff --git a/install/MarcMentat/2022.3/Marc_tools/comp_damask_hmp.patch b/install/MarcMentat/2022.3/Marc_tools/comp_damask_hmp.patch new file mode 100644 index 000000000..886ebf008 --- /dev/null +++ b/install/MarcMentat/2022.3/Marc_tools/comp_damask_hmp.patch @@ -0,0 +1,49 @@ +--- ++++ +@@ -6,18 +6,27 @@ + DIR=$1 + user=$3 + program=$4 ++usernoext=$user ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f` ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .F` ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .for` ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f90` ++ ++# add BLAS options for linking ++ BLAS="%BLAS%" ++ + . $DIR/tools/include + DIRJOB=$2 + cd $DIRJOB +-echo "Compiling and linking user subroutine $user.f on host `hostname`" ++echo "Compiling and linking user subroutine $user on host `hostname`" + echo "program: $program" +- $FORTRAN $user.f || \ ++ $DFORTHIGHMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null +- userobj=$user.o ++ userobj=$usernoext.o + + + $LOAD ${program} $DIR/lib/main.o\ +@@ -33,9 +42,13 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $BLAS \ + $SYSLIBS || \ + { +- echo "$0: link failed for $user.o on host `hostname`" ++ echo "$0: link failed for $usernoext.o on host `hostname`" + exit 1 + } + /bin/rm $userobj ++ /bin/rm $DIRJOB/*.mod ++ /bin/rm $DIRJOB/*.smod ++ /bin/rm $DIRJOB/*_genmod.f90 diff --git a/install/MarcMentat/2022.3/Marc_tools/comp_damask_lmp.patch b/install/MarcMentat/2022.3/Marc_tools/comp_damask_lmp.patch new file mode 100644 index 000000000..191cb1a53 --- /dev/null +++ b/install/MarcMentat/2022.3/Marc_tools/comp_damask_lmp.patch @@ -0,0 +1,49 @@ +--- ++++ +@@ -6,18 +6,27 @@ + DIR=$1 + user=$3 + program=$4 ++usernoext=$user ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f` ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .F` ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .for` ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f90` ++ ++# add BLAS options for linking ++ BLAS="%BLAS%" ++ + . $DIR/tools/include + DIRJOB=$2 + cd $DIRJOB +-echo "Compiling and linking user subroutine $user.f on host `hostname`" ++echo "Compiling and linking user subroutine $user on host `hostname`" + echo "program: $program" +- $FORTRAN $user.f || \ ++ $DFORTRANLOWMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null +- userobj=$user.o ++ userobj=$usernoext.o + + + $LOAD ${program} $DIR/lib/main.o\ +@@ -33,9 +42,13 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $BLAS \ + $SYSLIBS || \ + { +- echo "$0: link failed for $user.o on host `hostname`" ++ echo "$0: link failed for $usernoext.o on host `hostname`" + exit 1 + } + /bin/rm $userobj ++ /bin/rm $DIRJOB/*.mod ++ /bin/rm $DIRJOB/*.smod ++ /bin/rm $DIRJOB/*_genmod.f90 diff --git a/install/MarcMentat/2022.3/Marc_tools/comp_damask_mp.patch b/install/MarcMentat/2022.3/Marc_tools/comp_damask_mp.patch new file mode 100644 index 000000000..7c9cf7ba7 --- /dev/null +++ b/install/MarcMentat/2022.3/Marc_tools/comp_damask_mp.patch @@ -0,0 +1,49 @@ +--- ++++ +@@ -6,18 +6,27 @@ + DIR=$1 + user=$3 + program=$4 ++usernoext=$user ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f` ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .F` ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .for` ++usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f90` ++ ++# add BLAS options for linking ++ BLAS="%BLAS%" ++ + . $DIR/tools/include + DIRJOB=$2 + cd $DIRJOB +-echo "Compiling and linking user subroutine $user.f on host `hostname`" ++echo "Compiling and linking user subroutine $user on host `hostname`" + echo "program: $program" +- $FORTRAN $user.f || \ ++ $DFORTRANMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null +- userobj=$user.o ++ userobj=$usernoext.o + + + $LOAD ${program} $DIR/lib/main.o\ +@@ -33,9 +42,13 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $BLAS \ + $SYSLIBS || \ + { +- echo "$0: link failed for $user.o on host `hostname`" ++ echo "$0: link failed for $usernoext.o on host `hostname`" + exit 1 + } + /bin/rm $userobj ++ /bin/rm $DIRJOB/*.mod ++ /bin/rm $DIRJOB/*.smod ++ /bin/rm $DIRJOB/*_genmod.f90 diff --git a/install/MarcMentat/2022.3/Marc_tools/include_linux64.patch b/install/MarcMentat/2022.3/Marc_tools/include_linux64.patch new file mode 100644 index 000000000..8a758c795 --- /dev/null +++ b/install/MarcMentat/2022.3/Marc_tools/include_linux64.patch @@ -0,0 +1,75 @@ +--- ++++ +@@ -166,6 +166,15 @@ + MARC_COSIM_LIB="$MSCCOSIM_HOME/CoSim$MSCCOSIM_VERSION/Dcosim$MSCCOSIM_VERSION/lib" + fi + ++# DAMASK uses the HDF5 compiler wrapper around the Intel compiler ++H5FC=$(h5fc -shlib -show) ++if [[ "$H5FC" == *"$dir is"* ]]; then ++ H5FC=$(echo $(echo "$H5FC" | tail -n1) | sed -e "s/\-shlib/-fPIC -qopenmp/g") ++ H5FC=${H5FC%-lmpifort*} ++fi ++HDF5_LIB=${H5FC//*ifort/} ++FCOMP="$H5FC" ++ + # AEM + if test "$MARCDLLOUTDIR" = ""; then + DLLOUTDIR="$MARC_LIB" +@@ -594,7 +603,7 @@ + PROFILE=" $PROFILE -pg" + fi + +-FORT_OPT="-c -assume byterecl -safe_cray_ptr -mp1 -WB -fp-model source" ++FORT_OPT="-c -implicitnone -stand f18 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr -mp1 -WB -fp-model source" + if test "$MTHREAD" = "OPENMP" + then + FORT_OPT=" $FORT_OPT -qopenmp" +@@ -607,7 +616,7 @@ + FORT_OPT=" $FORT_OPT -save -zero" + fi + if test "$MARCHDF_HDF" = "HDF"; then +- FORT_OPT="$FORT_OPT -DMARCHDF_HDF=$MARCHDF_HDF $HDF_INCLUDE" ++ FORT_OPT="$FORT_OPT -DMARCHDF=$MARCHDF_HDF" + fi + + FORTLOW="$FCOMP $FORT_OPT $PROFILE -O0 $I8FFLAGS -I$MARC_SOURCE/common \ +@@ -621,6 +630,29 @@ + # for compiling free form f90 files. high opt, integer(4) + FORTF90="$FCOMP -c -O3" + ++# determine DAMASK version ++if test -n "$DAMASK_USER"; then ++ DAMASKROOT=`dirname $DAMASK_USER`/../.. ++ read DAMASKVERSION < $DAMASKROOT/VERSION ++ DAMASKVERSION="'"$DAMASKVERSION"'" ++else ++ DAMASKVERSION="'N/A'" ++fi ++ ++# DAMASK compiler calls ++DFORTLOWMP="$FCOMP -c -O0 -qno-offload -implicitnone -stand f18 -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=2022.1 -DDAMASKVERSION=$DAMASKVERSION \ ++ -qopenmp -qopenmp-threadprivate=compat\ ++ $MUMPS_INCLUDE $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD -I$MARC_MOD" ++DFORTRANMP="$FCOMP -c -O1 -qno-offload -implicitnone -stand f18 -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=2022.1 -DDAMASKVERSION=$DAMASKVERSION \ ++ -qopenmp -qopenmp-threadprivate=compat\ ++ $MUMPS_INCLUDE $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD -I$MARC_MOD" ++DFORTHIGHMP="$FCOMP -c -O3 -qno-offload -implicitnone -stand f18 -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=2022.1 -DDAMASKVERSION=$DAMASKVERSION \ ++ -qopenmp -qopenmp-threadprivate=compat\ ++ $MUMPS_INCLUDE $I8DEFINES -DLinux -DLINUX -DLinux_intel $FDEFINES $DDM $SOLVERFLAGS -I$KDTREE2_MOD -I$MARC_MOD" ++ + if test "$MARCDEBUG" = "ON" + then + FORTLOW="$FCOMP $FORT_OPT $PROFILE $I8FFLAGS -I$MARC_SOURCE/common \ +@@ -778,7 +810,7 @@ + + SOLVERLIBS="${BCSSOLVERLIBS} ${VKISOLVERLIBS} ${CASISOLVERLIBS} ${MF2SOLVERLIBS} \ + -L$MARC_MKL \ +- $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/libkdtree2.a $MARC_LIB/libtetmeshinterface.a $MARC_LIB/libcaefatigueinterface.a -L$MARC_LIB -lmkl_blacs_intelmpi_ilp64 -lmkl_scalapack_ilp64 -lmkl_intel_ilp64 -lmkl_intel_thread -lmkl_core -liomp5 -ltetmesh -lmeshgems -lmg-tetra -lmeshgems_stubs $HDF_LIBS $SOLVER2LIBS" ++ $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/libkdtree2.a $MARC_LIB/libtetmeshinterface.a $MARC_LIB/libcaefatigueinterface.a -L$MARC_LIB -lmkl_blacs_intelmpi_ilp64 -lmkl_scalapack_ilp64 -lmkl_intel_ilp64 -lmkl_intel_thread -lmkl_core -liomp5 -ltetmesh -lmeshgems -lmg-tetra -lmeshgems_stubs $HDF5_LIB $SOLVER2LIBS" + + SOLVERLIBS_DLL=${SOLVERLIBS} + if test "$AEM_DLL" -eq 1 diff --git a/install/MarcMentat/2022.3/Marc_tools/run_damask_hmp.patch b/install/MarcMentat/2022.3/Marc_tools/run_damask_hmp.patch new file mode 100644 index 000000000..a63591c4b --- /dev/null +++ b/install/MarcMentat/2022.3/Marc_tools/run_damask_hmp.patch @@ -0,0 +1,517 @@ +--- ++++ +@@ -136,6 +136,11 @@ + # is created. For job running in the background, the log # + # file is always created. Default is "yes" # + ############################################################################## ++# remove all Mentat paths from LD_LIBRARY_PATH ++LD_LIBRARY_PATH=:$LD_LIBRARY_PATH: ++LD_LIBRARY_PATH=${LD_LIBRARY_PATH//+([!(:)])mentat2022.2+([!(:)])/:} ++LD_LIBRARY_PATH=${LD_LIBRARY_PATH//+([(:)])/:} ++LD_LIBRARY_PATH=${LD_LIBRARY_PATH#:}; LD_LIBRARY_PATH=${LD_LIBRARY_PATH%:} + # set DIR to the directory in which this script is + REALCOM="`/bin/ls -l $0 |awk '{ print $NF; }'`" + DIR=`dirname $REALCOM` +@@ -302,7 +307,23 @@ + + . "$DIR/getarch" + ++ ++# getting user subroutine file name ++found=0 ++for i in "$@"; do ++ if test $found = 1; then ++ DAMASK_USER=$i ++ found=0 ++ fi ++ case $i in ++ -u* | -U*) ++ found=1 ++ ;; ++ esac ++done ++# sourcing include_linux64 (needs DAMASK_USER to be set) + . $MARC_INCLUDE ++ + # + + # +@@ -405,7 +426,7 @@ + did= + vid= + user= +-usersubname= ++usernoext= + objs= + qid=background + cpu= +@@ -676,50 +697,19 @@ + esac + ;; + -u* | -U*) +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user +- basefile=`$BASENAME $value` +- if test ${basefile##*.} = f +- then +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user.f +- elif test ${basefile##*.} = F +- then +- user=`dirname $value`/`$BASENAME $value .F` +- usersubname=$user.F +- elif test ${basefile##*.} = f90 +- then +- user=`dirname $value`/`$BASENAME $value .f90` +- usersubname=$user.f90 +- elif test ${basefile##*.} = F90 +- then +- user=`dirname $value`/`$BASENAME $value .F90` +- usersubname=$user.F90 +- fi ++ user=$value + case $user in + \/*) + ;; + *) + user=`pwd`/$user +- usersubname=`pwd`/$usersubname + ;; + esac +- if test ! -f $usersubname +- then +- if test -f $usersubname.f +- then +- usersubname=$usersubname.f +- elif test -f $usersubname.F +- then +- usersubname=$usersubname.F +- elif test -f $usersubname.f90 +- then +- usersubname=$usersubname.f90 +- elif test -f $usersubname.F90 +- then +- usersubname=$usersubname.F90 +- fi +- fi ++ usernoext=$user ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .F` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .for` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f90` + ;; + -obj | -OBJ) + objs="$value" +@@ -1207,12 +1197,12 @@ + fi + fi + fi +- if test "$usersubname" ++ if test "$user" + then +- if test ! -f $usersubname ++ if test ! -f $user + then + error="$error +-user subroutine file $usersubname not accessible" ++user subroutine file $user not accessible" + fi + fi + if test "$objs" +@@ -1531,7 +1521,7 @@ + Marc shared lib : $progdll + Version type : $mode + Job ID : $DIRJID/$jid$extra_job_info +-User subroutine name : $usersubname ++User subroutine name : $user + User objects/libs : $objs + Restart file job ID : $rid + Substructure file ID : $sid +@@ -1564,7 +1554,7 @@ + Marc shared lib : $progdll + Version type : $mode + Job ID : $DIRJID/$jid$extra_job_info +-User subroutine name : $usersubname ++User subroutine name : $user + User objects/libs : $objs + Restart file job ID : $rid + Substructure file ID : $sid +@@ -1687,7 +1677,7 @@ + ;; + esac + fi +- $ECHO "User subroutine name ($usersubname)? $ECHOTXT" ++ $ECHO "User subroutine name ($user)? $ECHOTXT" + read value + if test "$value" + then +@@ -1696,50 +1686,19 @@ + user= + ;; + *) +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user +- basefile=`$BASENAME $value` +- if test ${basefile##*.} = f +- then +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user.f +- elif test ${basefile##*.} = F +- then +- user=`dirname $value`/`$BASENAME $value .F` +- usersubname=$user.F +- elif test ${basefile##*.} = f90 +- then +- user=`dirname $value`/`$BASENAME $value .f90` +- usersubname=$user.f90 +- elif test ${basefile##*.} = F90 +- then +- user=`dirname $value`/`$BASENAME $value .F90` +- usersubname=$user.F90 +- fi ++ user=$value + case $user in + \/*) + ;; + *) + user=`pwd`/$user +- usersubname=`pwd`/$usersubname + ;; + esac +- if test ! -f $usersubname +- then +- if test -f $usersubname.f +- then +- usersubname=$usersubname.f +- elif test -f $usersubname.F +- then +- usersubname=$usersubname.F +- elif test -f $usersubname.f90 +- then +- usersubname=$usersubname.f90 +- elif test -f $usersubname.F90 +- then +- usersubname=$usersubname.F90 +- fi +- fi ++ usernoext=$user ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .F` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .for` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f90` + ;; + esac + fi +@@ -2274,11 +2233,12 @@ + # + # user subroutine used + # ++# add DAMASK options for linking ++ DAMASK="-lstdc++" + + if test "$user" + then +-# program=$user.marc +- program=$DIRJOB/`$BASENAME $user .f`.marc ++ program=$usernoext.marc + case $program in + \/* | \.\/*) + bd= +@@ -2391,7 +2351,7 @@ + fi + if test "$user" + then +- execpath=$DIRJOB/`$BASENAME $user .f`.marc ++ execpath=$usernoext.marc + usersub=1 + fi + export execpath +@@ -3274,44 +3234,27 @@ + echo + if test "$user" + then +- userobj=$DIRJOB/`$BASENAME $user .f`.o +- basefile=`$BASENAME $usersubname` +- if test ${basefile##*.} = f +- then +- usersub=$DIRJOB/`$BASENAME $user .f`.F +- ln -sf "$user.f" "$usersub" +- else +- usersub=$usersubname +- fi +- ++ userobj=$usernoext.o + fi + cat > $jid.runmarcscript << END4 + if test "$user" + then +- if test ${basefile##*.} = f +- then +- ln -sf "$user.f" "$usersub" +- fi + if test $MACHINENAME = "CRAY" + then +- $FORTRAN $usersub || \ ++ $DFORTHIGHMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + else +- $FORTRAN $usersub -o $userobj || \ ++ $DFORTHIGHMP $user -o $userobj || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + fi +- if test ${basefile##*.} = f +- then +- /bin/rm -f "$usersub" +- fi + fi + + +@@ -3331,6 +3274,7 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $DAMASK \ + $SFLIB \ + $OPENSSL_LIB \ + $SYSLIBS \ +@@ -3344,6 +3288,9 @@ + prgsav=yes + fi + /bin/rm $userobj 2>/dev/null ++/bin/rm $DIRJOB/*.mod 2>/dev/null ++/bin/rm $DIRJOB/*.smod 2>/dev/null ++/bin/rm $DIRJOB/*_genmod.f90 2>/dev/null + + # + # run marc +@@ -3390,7 +3337,7 @@ + fi + else + if test $cpdll = yes; then +- filename=`basename $usersubname .f` ++ filename=$usernoext + /bin/cp $DIRJOB/$marcdll $DIRJOB/${filename}_$marcdll 2>/dev/null + fi + if test $rmdll = yes +@@ -3556,7 +3503,7 @@ + # first copy over the user sub if local directories + if test ${dirstatus[$counter]} = "local" + then +- $RCP $user.f $i:$DIR1/ ++ $RCP $user $i:$DIR1/ + fi + # do the compilation on the other machine + if test ${dirstatus[$counter]} = "shared" +@@ -3569,21 +3516,21 @@ + remoteuser=$DIR1/`$BASENAME $user` + $RSH $i /bin/rm $remoteprog 2> /dev/null + echo +- $RSH $i $DIR2/tools/comp_user $DIR2 $DIR1 $remoteuser $remoteprog ++ $RSH $i $DIR2/tools/comp_damask_hmp $DIR2 $DIR1 $remoteuser $remoteprog + # check if successful, the new executable should be there + line=`$RSH $i /bin/ls $remoteprog 2> /dev/null` + if test "$line" + then + echo compilation and linking successful on host $i + else +- echo "$0: compile failed for $user.f on host $i" ++ echo "$0: compile failed for $user on host $i" + echo " $PRODUCT Exit number 3" + exit 1 + fi + # remove the user subroutine on remote machine + if test ${dirstatus[$counter]} = "local" + then +- $RSH $i /bin/rm $remoteuser.f 2> /dev/null ++ $RSH $i /bin/rm $remoteuser 2> /dev/null + fi + fi + fi +@@ -3593,39 +3540,27 @@ + if test "$userhost" + then + echo +- echo "Compiling and linking user subroutine $user.f on host `hostname`" +- fi +- userobj=$DIRJOB/`$BASENAME $user .f`.o +- basefile=`$BASENAME $usersubname` +- if test ${basefile##*.} = f +- then +- usersub=$DIRJOB/`$BASENAME $user .f`.F +- ln -sf "$user.f" "$usersub" +- else +- usersub=$usersubname ++ echo "Compiling and linking user subroutine $user on host `hostname`" + fi ++ userobj=$usernoext.o + if test $MACHINENAME = "CRAY" + then +- $FORTRAN $usersub || \ ++ $DFORTHIGHMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + echo " $PRODUCT Exit number 3" + exit 1 + } + /bin/rm $program 2>/dev/null + else +- $FORTRAN $usersub -o $userobj || \ ++ $DFORTHIGHMP $user -o $userobj || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + echo " $PRODUCT Exit number 3" + exit 1 + } + /bin/rm $program 2>/dev/null + fi +- if test ${basefile##*.} = f +- then +- /bin/rm -f "$usersub" +- fi + fi # if test $user + + +@@ -3645,6 +3580,7 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $DAMASK \ + $SFLIB \ + $OPENSSL_LIB \ + $SYSLIBS \ +@@ -3686,6 +3622,9 @@ + prgsav=yes + fi # if test $link + /bin/rm $userobj 2>/dev/null ++/bin/rm $DIRJOB/*.mod 2>/dev/null ++/bin/rm $DIRJOB/*.smod 2>/dev/null ++/bin/rm $DIRJOB/*_genmod.f90 2>/dev/null + + # + # run marc +@@ -3779,7 +3718,7 @@ + else + #dllrun >0 + if test $cpdll = yes; then +- filename=`basename $usersubname .f` ++ filename=$usernoext + /bin/cp $DIRJOB/$marcdll $DIRJOB/${filename}_$marcdll 2>/dev/null + fi + if test $rmdll = yes;then +@@ -3904,7 +3843,7 @@ + # first copy over the user sub if local directories + if test ${dirstatus[$counter]} = "local" + then +- $RCP $user.f $i:$DIR1/ ++ $RCP $user $i:$DIR1/ + fi + # do the compilation on the other machine + if test ${dirstatus[$counter]} = "shared" +@@ -3917,20 +3856,20 @@ + remoteuser=$DIR1/`$BASENAME $user` + $RSH $i /bin/rm $remoteprog 2> /dev/null + echo +- $RSH $i $DIR2/tools/comp_user $DIR2 $DIR1 $remoteuser $remoteprog ++ $RSH $i $DIR2/tools/comp_damask_hmp $DIR2 $DIR1 $remoteuser $remoteprog + # check if successful, the new executable should be there + line=`$RSH $i /bin/ls $remoteprog 2> /dev/null` + if test "$line" + then + echo compilation and linking successful on host $i + else +- echo "$0: compile failed for $user.f on host $i" ++ echo "$0: compile failed for $user on host $i" + exit 1 + fi + # remove the user subroutine on remote machine + if test ${dirstatus[$counter]} = "local" + then +- $RSH $i /bin/rm $remoteuser.f 2> /dev/null ++ $RSH $i /bin/rm $remoteuser 2> /dev/null + fi + fi + fi +@@ -3940,37 +3879,25 @@ + if test "$userhost" + then + echo +- echo "Compiling and linking user subroutine $user.f on host `hostname`" +- fi +- userobj=$DIRJOB/`$BASENAME $user .f`.o +- basefile=`$BASENAME $usersubname` +- if test ${basefile##*.} = f +- then +- usersub=$DIRJOB/`$BASENAME $user .f`.F +- ln -sf "$user.f" "$usersub" +- else +- usersub=$usersubname ++ echo "Compiling and linking user subroutine $user on host `hostname`" + fi ++ userobj=$usernoext.o + if test $MACHINENAME = "CRAY" + then +- $FORTRAN $usersub || \ ++ $DFORTHIGHMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + else +- $FORTRAN $usersub -o $userobj || \ ++ $DFORTHIGHMP $user -o $userobj || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + fi +- if test ${basefile##*.} = f +- then +- /bin/rm -f "$usersub" +- fi + fi # if test $user + + +@@ -3990,6 +3917,7 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $DAMASK \ + $SFLIB \ + $OPENSSL_LIB \ + $SYSLIBS \ +@@ -4030,7 +3958,9 @@ + prgsav=yes + fi # if test $link + /bin/rm $userobj 2>/dev/null +- ++/bin/rm $DIRJOB/*.mod 2>/dev/null ++/bin/rm $DIRJOB/*.smod 2>/dev/null ++/bin/rm $DIRJOB/*_genmod.f90 2>/dev/null + # done if no job id given + if test -z "$jid" + then +@@ -4149,7 +4079,7 @@ + else + #dllrun >0 + if test $cpdll = yes; then +- filename=`basename $usersubname .f` ++ filename=$usernoext + /bin/cp $DIRJOB/$marcdll $DIRJOB/${filename}_$marcdll 2>/dev/null + fi + if test $rmdll = yes;then diff --git a/install/MarcMentat/2022.3/Marc_tools/run_damask_lmp.patch b/install/MarcMentat/2022.3/Marc_tools/run_damask_lmp.patch new file mode 100644 index 000000000..4371ece0c --- /dev/null +++ b/install/MarcMentat/2022.3/Marc_tools/run_damask_lmp.patch @@ -0,0 +1,517 @@ +--- ++++ +@@ -136,6 +136,11 @@ + # is created. For job running in the background, the log # + # file is always created. Default is "yes" # + ############################################################################## ++# remove all Mentat paths from LD_LIBRARY_PATH ++LD_LIBRARY_PATH=:$LD_LIBRARY_PATH: ++LD_LIBRARY_PATH=${LD_LIBRARY_PATH//+([!(:)])mentat2022.2+([!(:)])/:} ++LD_LIBRARY_PATH=${LD_LIBRARY_PATH//+([(:)])/:} ++LD_LIBRARY_PATH=${LD_LIBRARY_PATH#:}; LD_LIBRARY_PATH=${LD_LIBRARY_PATH%:} + # set DIR to the directory in which this script is + REALCOM="`/bin/ls -l $0 |awk '{ print $NF; }'`" + DIR=`dirname $REALCOM` +@@ -302,7 +307,23 @@ + + . "$DIR/getarch" + ++ ++# getting user subroutine file name ++found=0 ++for i in "$@"; do ++ if test $found = 1; then ++ DAMASK_USER=$i ++ found=0 ++ fi ++ case $i in ++ -u* | -U*) ++ found=1 ++ ;; ++ esac ++done ++# sourcing include_linux64 (needs DAMASK_USER to be set) + . $MARC_INCLUDE ++ + # + + # +@@ -405,7 +426,7 @@ + did= + vid= + user= +-usersubname= ++usernoext= + objs= + qid=background + cpu= +@@ -676,50 +697,19 @@ + esac + ;; + -u* | -U*) +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user +- basefile=`$BASENAME $value` +- if test ${basefile##*.} = f +- then +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user.f +- elif test ${basefile##*.} = F +- then +- user=`dirname $value`/`$BASENAME $value .F` +- usersubname=$user.F +- elif test ${basefile##*.} = f90 +- then +- user=`dirname $value`/`$BASENAME $value .f90` +- usersubname=$user.f90 +- elif test ${basefile##*.} = F90 +- then +- user=`dirname $value`/`$BASENAME $value .F90` +- usersubname=$user.F90 +- fi ++ user=$value + case $user in + \/*) + ;; + *) + user=`pwd`/$user +- usersubname=`pwd`/$usersubname + ;; + esac +- if test ! -f $usersubname +- then +- if test -f $usersubname.f +- then +- usersubname=$usersubname.f +- elif test -f $usersubname.F +- then +- usersubname=$usersubname.F +- elif test -f $usersubname.f90 +- then +- usersubname=$usersubname.f90 +- elif test -f $usersubname.F90 +- then +- usersubname=$usersubname.F90 +- fi +- fi ++ usernoext=$user ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .F` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .for` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f90` + ;; + -obj | -OBJ) + objs="$value" +@@ -1207,12 +1197,12 @@ + fi + fi + fi +- if test "$usersubname" ++ if test "$user" + then +- if test ! -f $usersubname ++ if test ! -f $user + then + error="$error +-user subroutine file $usersubname not accessible" ++user subroutine file $user not accessible" + fi + fi + if test "$objs" +@@ -1531,7 +1521,7 @@ + Marc shared lib : $progdll + Version type : $mode + Job ID : $DIRJID/$jid$extra_job_info +-User subroutine name : $usersubname ++User subroutine name : $user + User objects/libs : $objs + Restart file job ID : $rid + Substructure file ID : $sid +@@ -1564,7 +1554,7 @@ + Marc shared lib : $progdll + Version type : $mode + Job ID : $DIRJID/$jid$extra_job_info +-User subroutine name : $usersubname ++User subroutine name : $user + User objects/libs : $objs + Restart file job ID : $rid + Substructure file ID : $sid +@@ -1687,7 +1677,7 @@ + ;; + esac + fi +- $ECHO "User subroutine name ($usersubname)? $ECHOTXT" ++ $ECHO "User subroutine name ($user)? $ECHOTXT" + read value + if test "$value" + then +@@ -1696,50 +1686,19 @@ + user= + ;; + *) +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user +- basefile=`$BASENAME $value` +- if test ${basefile##*.} = f +- then +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user.f +- elif test ${basefile##*.} = F +- then +- user=`dirname $value`/`$BASENAME $value .F` +- usersubname=$user.F +- elif test ${basefile##*.} = f90 +- then +- user=`dirname $value`/`$BASENAME $value .f90` +- usersubname=$user.f90 +- elif test ${basefile##*.} = F90 +- then +- user=`dirname $value`/`$BASENAME $value .F90` +- usersubname=$user.F90 +- fi ++ user=$value + case $user in + \/*) + ;; + *) + user=`pwd`/$user +- usersubname=`pwd`/$usersubname + ;; + esac +- if test ! -f $usersubname +- then +- if test -f $usersubname.f +- then +- usersubname=$usersubname.f +- elif test -f $usersubname.F +- then +- usersubname=$usersubname.F +- elif test -f $usersubname.f90 +- then +- usersubname=$usersubname.f90 +- elif test -f $usersubname.F90 +- then +- usersubname=$usersubname.F90 +- fi +- fi ++ usernoext=$user ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .F` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .for` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f90` + ;; + esac + fi +@@ -2274,11 +2233,12 @@ + # + # user subroutine used + # ++# add DAMASK options for linking ++ DAMASK="-lstdc++" + + if test "$user" + then +-# program=$user.marc +- program=$DIRJOB/`$BASENAME $user .f`.marc ++ program=$usernoext.marc + case $program in + \/* | \.\/*) + bd= +@@ -2391,7 +2351,7 @@ + fi + if test "$user" + then +- execpath=$DIRJOB/`$BASENAME $user .f`.marc ++ execpath=$usernoext.marc + usersub=1 + fi + export execpath +@@ -3274,44 +3234,27 @@ + echo + if test "$user" + then +- userobj=$DIRJOB/`$BASENAME $user .f`.o +- basefile=`$BASENAME $usersubname` +- if test ${basefile##*.} = f +- then +- usersub=$DIRJOB/`$BASENAME $user .f`.F +- ln -sf "$user.f" "$usersub" +- else +- usersub=$usersubname +- fi +- ++ userobj=$usernoext.o + fi + cat > $jid.runmarcscript << END4 + if test "$user" + then +- if test ${basefile##*.} = f +- then +- ln -sf "$user.f" "$usersub" +- fi + if test $MACHINENAME = "CRAY" + then +- $FORTRAN $usersub || \ ++ $DFORTLOWMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + else +- $FORTRAN $usersub -o $userobj || \ ++ $DFORTLOWMP $user -o $userobj || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + fi +- if test ${basefile##*.} = f +- then +- /bin/rm -f "$usersub" +- fi + fi + + +@@ -3331,6 +3274,7 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $DAMASK \ + $SFLIB \ + $OPENSSL_LIB \ + $SYSLIBS \ +@@ -3344,6 +3288,9 @@ + prgsav=yes + fi + /bin/rm $userobj 2>/dev/null ++/bin/rm $DIRJOB/*.mod 2>/dev/null ++/bin/rm $DIRJOB/*.smod 2>/dev/null ++/bin/rm $DIRJOB/*_genmod.f90 2>/dev/null + + # + # run marc +@@ -3390,7 +3337,7 @@ + fi + else + if test $cpdll = yes; then +- filename=`basename $usersubname .f` ++ filename=$usernoext + /bin/cp $DIRJOB/$marcdll $DIRJOB/${filename}_$marcdll 2>/dev/null + fi + if test $rmdll = yes +@@ -3556,7 +3503,7 @@ + # first copy over the user sub if local directories + if test ${dirstatus[$counter]} = "local" + then +- $RCP $user.f $i:$DIR1/ ++ $RCP $user $i:$DIR1/ + fi + # do the compilation on the other machine + if test ${dirstatus[$counter]} = "shared" +@@ -3569,21 +3516,21 @@ + remoteuser=$DIR1/`$BASENAME $user` + $RSH $i /bin/rm $remoteprog 2> /dev/null + echo +- $RSH $i $DIR2/tools/comp_user $DIR2 $DIR1 $remoteuser $remoteprog ++ $RSH $i $DIR2/tools/comp_damask_lmp $DIR2 $DIR1 $remoteuser $remoteprog + # check if successful, the new executable should be there + line=`$RSH $i /bin/ls $remoteprog 2> /dev/null` + if test "$line" + then + echo compilation and linking successful on host $i + else +- echo "$0: compile failed for $user.f on host $i" ++ echo "$0: compile failed for $user on host $i" + echo " $PRODUCT Exit number 3" + exit 1 + fi + # remove the user subroutine on remote machine + if test ${dirstatus[$counter]} = "local" + then +- $RSH $i /bin/rm $remoteuser.f 2> /dev/null ++ $RSH $i /bin/rm $remoteuser 2> /dev/null + fi + fi + fi +@@ -3593,39 +3540,27 @@ + if test "$userhost" + then + echo +- echo "Compiling and linking user subroutine $user.f on host `hostname`" +- fi +- userobj=$DIRJOB/`$BASENAME $user .f`.o +- basefile=`$BASENAME $usersubname` +- if test ${basefile##*.} = f +- then +- usersub=$DIRJOB/`$BASENAME $user .f`.F +- ln -sf "$user.f" "$usersub" +- else +- usersub=$usersubname ++ echo "Compiling and linking user subroutine $user on host `hostname`" + fi ++ userobj=$usernoext.o + if test $MACHINENAME = "CRAY" + then +- $FORTRAN $usersub || \ ++ $DFORTLOWMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + echo " $PRODUCT Exit number 3" + exit 1 + } + /bin/rm $program 2>/dev/null + else +- $FORTRAN $usersub -o $userobj || \ ++ $DFORTLOWMP $user -o $userobj || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + echo " $PRODUCT Exit number 3" + exit 1 + } + /bin/rm $program 2>/dev/null + fi +- if test ${basefile##*.} = f +- then +- /bin/rm -f "$usersub" +- fi + fi # if test $user + + +@@ -3645,6 +3580,7 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $DAMASK \ + $SFLIB \ + $OPENSSL_LIB \ + $SYSLIBS \ +@@ -3686,6 +3622,9 @@ + prgsav=yes + fi # if test $link + /bin/rm $userobj 2>/dev/null ++/bin/rm $DIRJOB/*.mod 2>/dev/null ++/bin/rm $DIRJOB/*.smod 2>/dev/null ++/bin/rm $DIRJOB/*_genmod.f90 2>/dev/null + + # + # run marc +@@ -3779,7 +3718,7 @@ + else + #dllrun >0 + if test $cpdll = yes; then +- filename=`basename $usersubname .f` ++ filename=$usernoext + /bin/cp $DIRJOB/$marcdll $DIRJOB/${filename}_$marcdll 2>/dev/null + fi + if test $rmdll = yes;then +@@ -3904,7 +3843,7 @@ + # first copy over the user sub if local directories + if test ${dirstatus[$counter]} = "local" + then +- $RCP $user.f $i:$DIR1/ ++ $RCP $user $i:$DIR1/ + fi + # do the compilation on the other machine + if test ${dirstatus[$counter]} = "shared" +@@ -3917,20 +3856,20 @@ + remoteuser=$DIR1/`$BASENAME $user` + $RSH $i /bin/rm $remoteprog 2> /dev/null + echo +- $RSH $i $DIR2/tools/comp_user $DIR2 $DIR1 $remoteuser $remoteprog ++ $RSH $i $DIR2/tools/comp_damask_lmp $DIR2 $DIR1 $remoteuser $remoteprog + # check if successful, the new executable should be there + line=`$RSH $i /bin/ls $remoteprog 2> /dev/null` + if test "$line" + then + echo compilation and linking successful on host $i + else +- echo "$0: compile failed for $user.f on host $i" ++ echo "$0: compile failed for $user on host $i" + exit 1 + fi + # remove the user subroutine on remote machine + if test ${dirstatus[$counter]} = "local" + then +- $RSH $i /bin/rm $remoteuser.f 2> /dev/null ++ $RSH $i /bin/rm $remoteuser 2> /dev/null + fi + fi + fi +@@ -3940,37 +3879,25 @@ + if test "$userhost" + then + echo +- echo "Compiling and linking user subroutine $user.f on host `hostname`" +- fi +- userobj=$DIRJOB/`$BASENAME $user .f`.o +- basefile=`$BASENAME $usersubname` +- if test ${basefile##*.} = f +- then +- usersub=$DIRJOB/`$BASENAME $user .f`.F +- ln -sf "$user.f" "$usersub" +- else +- usersub=$usersubname ++ echo "Compiling and linking user subroutine $user on host `hostname`" + fi ++ userobj=$usernoext.o + if test $MACHINENAME = "CRAY" + then +- $FORTRAN $usersub || \ ++ $DFORTLOWMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + else +- $FORTRAN $usersub -o $userobj || \ ++ $DFORTLOWMP $user -o $userobj || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + fi +- if test ${basefile##*.} = f +- then +- /bin/rm -f "$usersub" +- fi + fi # if test $user + + +@@ -3990,6 +3917,7 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $DAMASK \ + $SFLIB \ + $OPENSSL_LIB \ + $SYSLIBS \ +@@ -4030,7 +3958,9 @@ + prgsav=yes + fi # if test $link + /bin/rm $userobj 2>/dev/null +- ++/bin/rm $DIRJOB/*.mod 2>/dev/null ++/bin/rm $DIRJOB/*.smod 2>/dev/null ++/bin/rm $DIRJOB/*_genmod.f90 2>/dev/null + # done if no job id given + if test -z "$jid" + then +@@ -4149,7 +4079,7 @@ + else + #dllrun >0 + if test $cpdll = yes; then +- filename=`basename $usersubname .f` ++ filename=$usernoext + /bin/cp $DIRJOB/$marcdll $DIRJOB/${filename}_$marcdll 2>/dev/null + fi + if test $rmdll = yes;then diff --git a/install/MarcMentat/2022.3/Marc_tools/run_damask_mp.patch b/install/MarcMentat/2022.3/Marc_tools/run_damask_mp.patch new file mode 100644 index 000000000..11f9f00f4 --- /dev/null +++ b/install/MarcMentat/2022.3/Marc_tools/run_damask_mp.patch @@ -0,0 +1,517 @@ +--- ++++ +@@ -136,6 +136,11 @@ + # is created. For job running in the background, the log # + # file is always created. Default is "yes" # + ############################################################################## ++# remove all Mentat paths from LD_LIBRARY_PATH ++LD_LIBRARY_PATH=:$LD_LIBRARY_PATH: ++LD_LIBRARY_PATH=${LD_LIBRARY_PATH//+([!(:)])mentat2022.2+([!(:)])/:} ++LD_LIBRARY_PATH=${LD_LIBRARY_PATH//+([(:)])/:} ++LD_LIBRARY_PATH=${LD_LIBRARY_PATH#:}; LD_LIBRARY_PATH=${LD_LIBRARY_PATH%:} + # set DIR to the directory in which this script is + REALCOM="`/bin/ls -l $0 |awk '{ print $NF; }'`" + DIR=`dirname $REALCOM` +@@ -302,7 +307,23 @@ + + . "$DIR/getarch" + ++ ++# getting user subroutine file name ++found=0 ++for i in "$@"; do ++ if test $found = 1; then ++ DAMASK_USER=$i ++ found=0 ++ fi ++ case $i in ++ -u* | -U*) ++ found=1 ++ ;; ++ esac ++done ++# sourcing include_linux64 (needs DAMASK_USER to be set) + . $MARC_INCLUDE ++ + # + + # +@@ -405,7 +426,7 @@ + did= + vid= + user= +-usersubname= ++usernoext= + objs= + qid=background + cpu= +@@ -676,50 +697,19 @@ + esac + ;; + -u* | -U*) +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user +- basefile=`$BASENAME $value` +- if test ${basefile##*.} = f +- then +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user.f +- elif test ${basefile##*.} = F +- then +- user=`dirname $value`/`$BASENAME $value .F` +- usersubname=$user.F +- elif test ${basefile##*.} = f90 +- then +- user=`dirname $value`/`$BASENAME $value .f90` +- usersubname=$user.f90 +- elif test ${basefile##*.} = F90 +- then +- user=`dirname $value`/`$BASENAME $value .F90` +- usersubname=$user.F90 +- fi ++ user=$value + case $user in + \/*) + ;; + *) + user=`pwd`/$user +- usersubname=`pwd`/$usersubname + ;; + esac +- if test ! -f $usersubname +- then +- if test -f $usersubname.f +- then +- usersubname=$usersubname.f +- elif test -f $usersubname.F +- then +- usersubname=$usersubname.F +- elif test -f $usersubname.f90 +- then +- usersubname=$usersubname.f90 +- elif test -f $usersubname.F90 +- then +- usersubname=$usersubname.F90 +- fi +- fi ++ usernoext=$user ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .F` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .for` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f90` + ;; + -obj | -OBJ) + objs="$value" +@@ -1207,12 +1197,12 @@ + fi + fi + fi +- if test "$usersubname" ++ if test "$user" + then +- if test ! -f $usersubname ++ if test ! -f $user + then + error="$error +-user subroutine file $usersubname not accessible" ++user subroutine file $user not accessible" + fi + fi + if test "$objs" +@@ -1531,7 +1521,7 @@ + Marc shared lib : $progdll + Version type : $mode + Job ID : $DIRJID/$jid$extra_job_info +-User subroutine name : $usersubname ++User subroutine name : $user + User objects/libs : $objs + Restart file job ID : $rid + Substructure file ID : $sid +@@ -1564,7 +1554,7 @@ + Marc shared lib : $progdll + Version type : $mode + Job ID : $DIRJID/$jid$extra_job_info +-User subroutine name : $usersubname ++User subroutine name : $user + User objects/libs : $objs + Restart file job ID : $rid + Substructure file ID : $sid +@@ -1687,7 +1677,7 @@ + ;; + esac + fi +- $ECHO "User subroutine name ($usersubname)? $ECHOTXT" ++ $ECHO "User subroutine name ($user)? $ECHOTXT" + read value + if test "$value" + then +@@ -1696,50 +1686,19 @@ + user= + ;; + *) +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user +- basefile=`$BASENAME $value` +- if test ${basefile##*.} = f +- then +- user=`dirname $value`/`$BASENAME $value .f` +- usersubname=$user.f +- elif test ${basefile##*.} = F +- then +- user=`dirname $value`/`$BASENAME $value .F` +- usersubname=$user.F +- elif test ${basefile##*.} = f90 +- then +- user=`dirname $value`/`$BASENAME $value .f90` +- usersubname=$user.f90 +- elif test ${basefile##*.} = F90 +- then +- user=`dirname $value`/`$BASENAME $value .F90` +- usersubname=$user.F90 +- fi ++ user=$value + case $user in + \/*) + ;; + *) + user=`pwd`/$user +- usersubname=`pwd`/$usersubname + ;; + esac +- if test ! -f $usersubname +- then +- if test -f $usersubname.f +- then +- usersubname=$usersubname.f +- elif test -f $usersubname.F +- then +- usersubname=$usersubname.F +- elif test -f $usersubname.f90 +- then +- usersubname=$usersubname.f90 +- elif test -f $usersubname.F90 +- then +- usersubname=$usersubname.F90 +- fi +- fi ++ usernoext=$user ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .F` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .for` ++ usernoext=`dirname $usernoext`/`$BASENAME $usernoext .f90` + ;; + esac + fi +@@ -2274,11 +2233,12 @@ + # + # user subroutine used + # ++# add DAMASK options for linking ++ DAMASK="-lstdc++" + + if test "$user" + then +-# program=$user.marc +- program=$DIRJOB/`$BASENAME $user .f`.marc ++ program=$usernoext.marc + case $program in + \/* | \.\/*) + bd= +@@ -2391,7 +2351,7 @@ + fi + if test "$user" + then +- execpath=$DIRJOB/`$BASENAME $user .f`.marc ++ execpath=$usernoext.marc + usersub=1 + fi + export execpath +@@ -3274,44 +3234,27 @@ + echo + if test "$user" + then +- userobj=$DIRJOB/`$BASENAME $user .f`.o +- basefile=`$BASENAME $usersubname` +- if test ${basefile##*.} = f +- then +- usersub=$DIRJOB/`$BASENAME $user .f`.F +- ln -sf "$user.f" "$usersub" +- else +- usersub=$usersubname +- fi +- ++ userobj=$usernoext.o + fi + cat > $jid.runmarcscript << END4 + if test "$user" + then +- if test ${basefile##*.} = f +- then +- ln -sf "$user.f" "$usersub" +- fi + if test $MACHINENAME = "CRAY" + then +- $FORTRAN $usersub || \ ++ $DFORTRANMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + else +- $FORTRAN $usersub -o $userobj || \ ++ $DFORTRANMP $user -o $userobj || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + fi +- if test ${basefile##*.} = f +- then +- /bin/rm -f "$usersub" +- fi + fi + + +@@ -3331,6 +3274,7 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $DAMASK \ + $SFLIB \ + $OPENSSL_LIB \ + $SYSLIBS \ +@@ -3344,6 +3288,9 @@ + prgsav=yes + fi + /bin/rm $userobj 2>/dev/null ++/bin/rm $DIRJOB/*.mod 2>/dev/null ++/bin/rm $DIRJOB/*.smod 2>/dev/null ++/bin/rm $DIRJOB/*_genmod.f90 2>/dev/null + + # + # run marc +@@ -3390,7 +3337,7 @@ + fi + else + if test $cpdll = yes; then +- filename=`basename $usersubname .f` ++ filename=$usernoext + /bin/cp $DIRJOB/$marcdll $DIRJOB/${filename}_$marcdll 2>/dev/null + fi + if test $rmdll = yes +@@ -3556,7 +3503,7 @@ + # first copy over the user sub if local directories + if test ${dirstatus[$counter]} = "local" + then +- $RCP $user.f $i:$DIR1/ ++ $RCP $user $i:$DIR1/ + fi + # do the compilation on the other machine + if test ${dirstatus[$counter]} = "shared" +@@ -3569,21 +3516,21 @@ + remoteuser=$DIR1/`$BASENAME $user` + $RSH $i /bin/rm $remoteprog 2> /dev/null + echo +- $RSH $i $DIR2/tools/comp_user $DIR2 $DIR1 $remoteuser $remoteprog ++ $RSH $i $DIR2/tools/comp_damask_mp $DIR2 $DIR1 $remoteuser $remoteprog + # check if successful, the new executable should be there + line=`$RSH $i /bin/ls $remoteprog 2> /dev/null` + if test "$line" + then + echo compilation and linking successful on host $i + else +- echo "$0: compile failed for $user.f on host $i" ++ echo "$0: compile failed for $user on host $i" + echo " $PRODUCT Exit number 3" + exit 1 + fi + # remove the user subroutine on remote machine + if test ${dirstatus[$counter]} = "local" + then +- $RSH $i /bin/rm $remoteuser.f 2> /dev/null ++ $RSH $i /bin/rm $remoteuser 2> /dev/null + fi + fi + fi +@@ -3593,39 +3540,27 @@ + if test "$userhost" + then + echo +- echo "Compiling and linking user subroutine $user.f on host `hostname`" +- fi +- userobj=$DIRJOB/`$BASENAME $user .f`.o +- basefile=`$BASENAME $usersubname` +- if test ${basefile##*.} = f +- then +- usersub=$DIRJOB/`$BASENAME $user .f`.F +- ln -sf "$user.f" "$usersub" +- else +- usersub=$usersubname ++ echo "Compiling and linking user subroutine $user on host `hostname`" + fi ++ userobj=$usernoext.o + if test $MACHINENAME = "CRAY" + then +- $FORTRAN $usersub || \ ++ $DFORTRANMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + echo " $PRODUCT Exit number 3" + exit 1 + } + /bin/rm $program 2>/dev/null + else +- $FORTRAN $usersub -o $userobj || \ ++ $DFORTRANMP $user -o $userobj || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + echo " $PRODUCT Exit number 3" + exit 1 + } + /bin/rm $program 2>/dev/null + fi +- if test ${basefile##*.} = f +- then +- /bin/rm -f "$usersub" +- fi + fi # if test $user + + +@@ -3645,6 +3580,7 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $DAMASK \ + $SFLIB \ + $OPENSSL_LIB \ + $SYSLIBS \ +@@ -3686,6 +3622,9 @@ + prgsav=yes + fi # if test $link + /bin/rm $userobj 2>/dev/null ++/bin/rm $DIRJOB/*.mod 2>/dev/null ++/bin/rm $DIRJOB/*.smod 2>/dev/null ++/bin/rm $DIRJOB/*_genmod.f90 2>/dev/null + + # + # run marc +@@ -3779,7 +3718,7 @@ + else + #dllrun >0 + if test $cpdll = yes; then +- filename=`basename $usersubname .f` ++ filename=$usernoext + /bin/cp $DIRJOB/$marcdll $DIRJOB/${filename}_$marcdll 2>/dev/null + fi + if test $rmdll = yes;then +@@ -3904,7 +3843,7 @@ + # first copy over the user sub if local directories + if test ${dirstatus[$counter]} = "local" + then +- $RCP $user.f $i:$DIR1/ ++ $RCP $user $i:$DIR1/ + fi + # do the compilation on the other machine + if test ${dirstatus[$counter]} = "shared" +@@ -3917,20 +3856,20 @@ + remoteuser=$DIR1/`$BASENAME $user` + $RSH $i /bin/rm $remoteprog 2> /dev/null + echo +- $RSH $i $DIR2/tools/comp_user $DIR2 $DIR1 $remoteuser $remoteprog ++ $RSH $i $DIR2/tools/comp_damask_mp $DIR2 $DIR1 $remoteuser $remoteprog + # check if successful, the new executable should be there + line=`$RSH $i /bin/ls $remoteprog 2> /dev/null` + if test "$line" + then + echo compilation and linking successful on host $i + else +- echo "$0: compile failed for $user.f on host $i" ++ echo "$0: compile failed for $user on host $i" + exit 1 + fi + # remove the user subroutine on remote machine + if test ${dirstatus[$counter]} = "local" + then +- $RSH $i /bin/rm $remoteuser.f 2> /dev/null ++ $RSH $i /bin/rm $remoteuser 2> /dev/null + fi + fi + fi +@@ -3940,37 +3879,25 @@ + if test "$userhost" + then + echo +- echo "Compiling and linking user subroutine $user.f on host `hostname`" +- fi +- userobj=$DIRJOB/`$BASENAME $user .f`.o +- basefile=`$BASENAME $usersubname` +- if test ${basefile##*.} = f +- then +- usersub=$DIRJOB/`$BASENAME $user .f`.F +- ln -sf "$user.f" "$usersub" +- else +- usersub=$usersubname ++ echo "Compiling and linking user subroutine $user on host `hostname`" + fi ++ userobj=$usernoext.o + if test $MACHINENAME = "CRAY" + then +- $FORTRAN $usersub || \ ++ $DFORTRANMP $user || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + else +- $FORTRAN $usersub -o $userobj || \ ++ $DFORTRANMP $user -o $userobj || \ + { +- echo "$0: compile failed for $user.f" ++ echo "$0: compile failed for $user" + exit 1 + } + /bin/rm $program 2>/dev/null + fi +- if test ${basefile##*.} = f +- then +- /bin/rm -f "$usersub" +- fi + fi # if test $user + + +@@ -3990,6 +3917,7 @@ + $TKLIBS \ + $MRCLIBS \ + $METISLIBS \ ++ $DAMASK \ + $SFLIB \ + $OPENSSL_LIB \ + $SYSLIBS \ +@@ -4030,7 +3958,9 @@ + prgsav=yes + fi # if test $link + /bin/rm $userobj 2>/dev/null +- ++/bin/rm $DIRJOB/*.mod 2>/dev/null ++/bin/rm $DIRJOB/*.smod 2>/dev/null ++/bin/rm $DIRJOB/*_genmod.f90 2>/dev/null + # done if no job id given + if test -z "$jid" + then +@@ -4149,7 +4079,7 @@ + else + #dllrun >0 + if test $cpdll = yes; then +- filename=`basename $usersubname .f` ++ filename=$usernoext + /bin/cp $DIRJOB/$marcdll $DIRJOB/${filename}_$marcdll 2>/dev/null + fi + if test $rmdll = yes;then diff --git a/install/MarcMentat/2022.3/Mentat_bin/edit_window.patch b/install/MarcMentat/2022.3/Mentat_bin/edit_window.patch new file mode 100644 index 000000000..915af9bf6 --- /dev/null +++ b/install/MarcMentat/2022.3/Mentat_bin/edit_window.patch @@ -0,0 +1,24 @@ +--- ++++ +@@ -1,18 +1,5 @@ + #!/bin/sh +-# This script opens a window running an editor. The default window is an +-# xterm, and the default editor is vi. These may be customized. ++# This script opens a window running an editor. ++# The command to invoke the editor is specified during DAMASK installation + +-dir= +-for d in /usr/bin /usr/bin/X11; do +- if test -x "$d/xterm"; then +- dir="$d" +- break +- fi +-done +- +-if test -z "$dir"; then +- echo "$0: Could not find xterm" +- exit 1 +-fi +- +-"$dir/xterm" -T "vi $*" -n "vi $*" -e vi $* ++%EDITOR% $* diff --git a/install/MarcMentat/2022.3/Mentat_bin/kill4.patch b/install/MarcMentat/2022.3/Mentat_bin/kill4.patch new file mode 100644 index 000000000..e69de29bb diff --git a/install/MarcMentat/2022.3/Mentat_bin/kill5.patch b/install/MarcMentat/2022.3/Mentat_bin/kill5.patch new file mode 100644 index 000000000..e69de29bb diff --git a/install/MarcMentat/2022.3/Mentat_bin/kill6.patch b/install/MarcMentat/2022.3/Mentat_bin/kill6.patch new file mode 100644 index 000000000..e69de29bb diff --git a/install/MarcMentat/2022.3/Mentat_bin/submit4.patch b/install/MarcMentat/2022.3/Mentat_bin/submit4.patch new file mode 100644 index 000000000..98c51e76d --- /dev/null +++ b/install/MarcMentat/2022.3/Mentat_bin/submit4.patch @@ -0,0 +1,38 @@ +--- ++++ +@@ -63,10 +63,10 @@ + if [ "$slv" != "" -a "$slv" != "marc" -a "$slv" != "datfit" ]; then + slv="-iam sfm" + fi +-if [ "$slv" == "marc" ]; then ++if [ "$slv" = "marc" ]; then + slv="" + fi +-if [ "$slv" == "datfit" ]; then ++if [ "$slv" = "datfit" ]; then + slv="-iam datfit" + fi + +@@ -91,6 +91,7 @@ + srcfile="-u $srcfile -save y" + ;; + runsaved) ++ srcfile=${srcfile%.*}".marc" + srcfile="-prog $srcfile" + ;; + esac +@@ -189,12 +190,12 @@ + unset PYTHONPATH + + if [ "$doe_first" = "-" ]; then # submit of regular Marc job +- "${DIR}/tools/run_marc" $slv -j $job -v n -b y $nprocds $nprocd \ ++ "${DIR}/tools/run_damask_hmp" $slv -j $job -v n -b y $nprocds $nprocd \ + $srcfile $restart $postfile $viewfactorsfile $hostfile \ + $compat $copy_datfile $copy_postfile $scr_dir $dcoup \ + $assem_recov_nthread $nthread $nsolver $mode $gpu > /dev/null 2>&1 + else # submit of a DoE Marc job +- "${DIR}/tools/run_marc" $slv -j $job -v n -b n $nprocds $nprocd \ ++ "${DIR}/tools/run_damask_hmp" $slv -j $job -v n -b n $nprocds $nprocd \ + $srcfile $restart $postfile $viewfactorsfile $hostfile \ + $compat $copy_datfile $copy_postfile $scr_dir $dcoup \ + $assem_recov_nthread $nthread $nsolver $mode $gpu diff --git a/install/MarcMentat/2022.3/Mentat_bin/submit5.patch b/install/MarcMentat/2022.3/Mentat_bin/submit5.patch new file mode 100644 index 000000000..ab32b1058 --- /dev/null +++ b/install/MarcMentat/2022.3/Mentat_bin/submit5.patch @@ -0,0 +1,38 @@ +--- ++++ +@@ -63,10 +63,10 @@ + if [ "$slv" != "" -a "$slv" != "marc" -a "$slv" != "datfit" ]; then + slv="-iam sfm" + fi +-if [ "$slv" == "marc" ]; then ++if [ "$slv" = "marc" ]; then + slv="" + fi +-if [ "$slv" == "datfit" ]; then ++if [ "$slv" = "datfit" ]; then + slv="-iam datfit" + fi + +@@ -91,6 +91,7 @@ + srcfile="-u $srcfile -save y" + ;; + runsaved) ++ srcfile=${srcfile%.*}".marc" + srcfile="-prog $srcfile" + ;; + esac +@@ -189,12 +190,12 @@ + unset PYTHONPATH + + if [ "$doe_first" = "-" ]; then # submit of regular Marc job +- "${DIR}/tools/run_marc" $slv -j $job -v n -b y $nprocds $nprocd \ ++ "${DIR}/tools/run_damask_mp" $slv -j $job -v n -b y $nprocds $nprocd \ + $srcfile $restart $postfile $viewfactorsfile $hostfile \ + $compat $copy_datfile $copy_postfile $scr_dir $dcoup \ + $assem_recov_nthread $nthread $nsolver $mode $gpu > /dev/null 2>&1 + else # submit of a DoE Marc job +- "${DIR}/tools/run_marc" $slv -j $job -v n -b n $nprocds $nprocd \ ++ "${DIR}/tools/run_damask_mp" $slv -j $job -v n -b n $nprocds $nprocd \ + $srcfile $restart $postfile $viewfactorsfile $hostfile \ + $compat $copy_datfile $copy_postfile $scr_dir $dcoup \ + $assem_recov_nthread $nthread $nsolver $mode $gpu diff --git a/install/MarcMentat/2022.3/Mentat_bin/submit6.patch b/install/MarcMentat/2022.3/Mentat_bin/submit6.patch new file mode 100644 index 000000000..d5ea3cfde --- /dev/null +++ b/install/MarcMentat/2022.3/Mentat_bin/submit6.patch @@ -0,0 +1,38 @@ +--- ++++ +@@ -63,10 +63,10 @@ + if [ "$slv" != "" -a "$slv" != "marc" -a "$slv" != "datfit" ]; then + slv="-iam sfm" + fi +-if [ "$slv" == "marc" ]; then ++if [ "$slv" = "marc" ]; then + slv="" + fi +-if [ "$slv" == "datfit" ]; then ++if [ "$slv" = "datfit" ]; then + slv="-iam datfit" + fi + +@@ -91,6 +91,7 @@ + srcfile="-u $srcfile -save y" + ;; + runsaved) ++ srcfile=${srcfile%.*}".marc" + srcfile="-prog $srcfile" + ;; + esac +@@ -189,12 +190,12 @@ + unset PYTHONPATH + + if [ "$doe_first" = "-" ]; then # submit of regular Marc job +- "${DIR}/tools/run_marc" $slv -j $job -v n -b y $nprocds $nprocd \ ++ "${DIR}/tools/run_damask_lmp" $slv -j $job -v n -b y $nprocds $nprocd \ + $srcfile $restart $postfile $viewfactorsfile $hostfile \ + $compat $copy_datfile $copy_postfile $scr_dir $dcoup \ + $assem_recov_nthread $nthread $nsolver $mode $gpu > /dev/null 2>&1 + else # submit of a DoE Marc job +- "${DIR}/tools/run_marc" $slv -j $job -v n -b n $nprocds $nprocd \ ++ "${DIR}/tools/run_damask_lmp" $slv -j $job -v n -b n $nprocds $nprocd \ + $srcfile $restart $postfile $viewfactorsfile $hostfile \ + $compat $copy_datfile $copy_postfile $scr_dir $dcoup \ + $assem_recov_nthread $nthread $nsolver $mode $gpu diff --git a/install/MarcMentat/2022.3/Mentat_menus/job_run.ms.patch b/install/MarcMentat/2022.3/Mentat_menus/job_run.ms.patch new file mode 100644 index 000000000..e9223b1e4 --- /dev/null +++ b/install/MarcMentat/2022.3/Mentat_menus/job_run.ms.patch @@ -0,0 +1,158 @@ +--- ++++ +@@ -261,11 +261,18 @@ + } + button { + position +25 = +- size 25 4 ++ size 18 4 + text "ADVANCED JOB SUBMISSION" + help "job_run#Job Submission And Control" + popmenu job_submit_adv_pm + } ++ button { ++ position +18 = ++ size 7 4 ++ text "DAMASK" ++ help "damask_run#Job Submission And Control" ++ popmenu damask ++ } + button { + position 0 +4 + size 16 4 +@@ -1207,6 +1214,135 @@ + } + + ++#-------------------------------------------------------------------------------------------------- ++popmenu damask { ++ ++#ifdef QT_MENTAT ++ text "DAMASK.MPIE.DE" ++#endif ++ ++ group { ++#ifndef QT_MENTAT ++ label { ++ position 0 0 ++ size 50 4 ++ text "DAMASK.MPIE.DE" ++ } ++#endif ++ ++ label { ++ position 1 6 ++ size 13 6 ++ text "Optimzation" ++ border_width 1 ++ border_color black ++ } ++ ++ label { ++ position +13 = ++ size 20 6 ++ text "write Input" ++ border_width 1 ++ border_color black ++ } ++ ++ label { ++ position +18 = ++ size 30 6 ++ text "do not write Inp." ++ border_width 1 ++ border_color black ++ } ++ ++ label { ++ position -32 +6 ++ size 12 6 ++ text "O3 / OpenMP" ++ border_width 1 ++ border_color black ++ } ++ ++ popdown { ++ position +12 = ++ size 20 6 ++ text "Submit" ++ command "*submit_job 4 *monitor_job" ++ } ++ ++ popdown { ++ position +20 = ++ size 20 6 ++ text "Execute" ++ command "*execute_job 4 *monitor_job" ++ } ++ ++ label { ++ position -32 +6 ++ size 12 6 ++ text "O1 / OpenMP" ++ border_width 1 ++ border_color black ++ } ++ ++ popdown { ++ position +12 = ++ size 20 6 ++ text "Submit" ++ command "*submit_job 5 *monitor_job" ++ } ++ ++ popdown { ++ position +20 = ++ size 20 6 ++ text "Execute" ++ command "*execute_job 5 *monitor_job" ++ } ++ ++ label { ++ position -32 +6 ++ size 12 6 ++ text "O0 / OpenMP" ++ border_width 1 ++ border_color black ++ } ++ ++ popdown { ++ position +12 = ++ size 20 6 ++ text "Submit" ++ command "*submit_job 6 *monitor_job" ++ } ++ ++ popdown { ++ position +20 = ++ size 20 6 ++ text "Execute" ++ command "*execute_job 6 *monitor_job" ++ } ++ ++ popdown { ++ position 19 +8 ++ size 12 8 ++ text "CANCEL" ++ } ++} ++ ++ window { ++ parent mentat ++ origin 38 8 ++#ifdef DCOM ++ size 50 100 ++#else ++ size 50 94 ++#endif ++ background_color body ++ border_width 1 ++ border_color border ++ buffering single ++ } ++ mode permanent ++} ++ + #-------------------------------------------------------------------------------------------------- + popmenu job_exit_msg_pm { + diff --git a/processing/mentat_pbcOnBoxMesh.py b/processing/mentat_pbcOnBoxMesh.py new file mode 100755 index 000000000..3eedacb7d --- /dev/null +++ b/processing/mentat_pbcOnBoxMesh.py @@ -0,0 +1,262 @@ +#!/usr/bin/env python3 + +import sys +import os +import re +import time +import tempfile +from optparse import OptionParser + +import numpy as np + +import damask + +script_name = os.path.splitext(os.path.basename(__file__))[0] +script_id = ' '.join([script_name,damask.version]) + +# Convert .mfd file into a usable format +# Broken into labeled sections (eg. nodes, links, etc) +# Each section has a list of labeled elements with formatted numerical data +def parseMFD(dat): + formatted = [] + section = 0 + formatted.append({'label': 'header', 'uid': -1, 'els': []}) + # in between =beg= and =end= part of file + in_block = False + for line in dat: + if in_block: # currently in a section + # lines that start with a space are numerical data + if line[0] == ' ': + formatted[section]['els'].append([]) + + # grab numbers + nums = re.split(r'\s+', line.strip()) + + for num in nums: + # floating point has format ' -x.xxxxxxxxxxxxe+yy' + # scientific notation is used for float + if (len(num) >= 4) and (num[-4] == 'e'): + formatted[section]['els'][-1].append(float(num)) + else: # integer + formatted[section]['els'][-1].append(int(num)) + else: # not numerical data, so it is a label for an element or section end + if line[0] == '=' and re.search(r'=end=$', line) is not None: # End of section, avoiding regex if possible + in_block = False + else: + formatted[section]['els'].append([]) + formatted[section]['els'][-1] = line + + else: # Not in a section, we are looking for a =beg= now + search = re.search(r'=beg=\s+(\d+)\s\((.*?)\)', line) + if search is not None: # found start of a new section + section += 1 + in_block = True + formatted.append({'label': search.group(2), 'uid': int(search.group(1)), 'els': []}) + else: # No =beg= found, probably in the header + # Either header or somthing we didn't plan for - just save the line so it isn't lost + if formatted[section]['uid'] > 0: + section += 1 + formatted.append({'label': '', 'uid': -2, 'els': []}) # make dummy section to store unrecognized data + formatted[section]['els'].append(line) + + return formatted + +def asMFD(mfd_data): + result = '' + for section in mfd_data: + if section['uid'] > 0: + result += '=beg={0:5d} ({1})\n'.format(section['uid'], section['label']) + for el in section['els']: + if type(el) == str: + result += el + elif type(el) == list: + for num in el: + if type(num) == int: + result += '{:20d}'.format(num) + elif type(num) == float: + result += '{:20.12e}'.format(num) + else: + print(f'WARNING: encountered unknown type: {type(el)}') + result += '\n' + else: + print(f'WARNING: encountered unknown type: {type(el)}') + if section['uid'] > 0: + result += '=end=\n' + return result.strip() + + +def add_servoLinks(mfd_data,active=[True,True,True]): # directions on which to add PBC + base = ['x','y','z'] + box = {'min': np.zeros(3,dtype='d'), + 'max': np.zeros(3,dtype='d'), + 'delta': np.zeros(3,dtype='d'), + } + + mfd_dict = {} + for i in range(len(mfd_data)): + mfd_dict[mfd_data[i]['label']] = i + + NodeCoords = np.array(mfd_data[mfd_dict['nodes']]['els'][1::4])[:,1:4] + Nnodes = NodeCoords.shape[0] + + box['min'] = NodeCoords.min(axis=0) # find the bounding box + box['max'] = NodeCoords.max(axis=0) + box['delta'] = box['max']-box['min'] + for coord in range(3): # calc the dimension of the bounding box + if box['delta'][coord] != 0.0: + for extremum in ['min','max']: + rounded = round(box[extremum][coord]*1e+15/box['delta'][coord]) * \ + 1e-15*box['delta'][coord] # rounding to 1e-15 of dimension + box[extremum][coord] = 0.0 if rounded == 0.0 else rounded # get rid of -0.0 (negative zeros) + baseNode = {} + linkNodes = [] + +#------------------------------------------------------------------------------------------------- +# loop over all nodes + for node in range(Nnodes): + key = {} + maxFlag = [False, False, False] + Nmax = 0 + Nmin = 0 + for coord in range(3): # for each direction + if box['delta'][coord] != 0.0: + rounded = round(NodeCoords[node,coord]*1e+15/box['delta'][coord]) * \ + 1e-15*box['delta'][coord] # rounding to 1e-15 of dimension + NodeCoords[node,coord] = 0.0 if rounded == 0.0 else rounded # get rid of -0.0 (negative zeros) + key[base[coord]] = "%.8e"%NodeCoords[node,coord] # translate position to string + if (key[base[coord]] == "%.8e"%box['min'][coord]): # compare to min of bounding box (i.e. is on outer face?) + Nmin += 1 # count outer (back) face membership + elif (key[base[coord]] == "%.8e"%box['max'][coord]): # compare to max of bounding box (i.e. is on outer face?) + Nmax += 1 # count outer (front) face membership + maxFlag[coord] = True # remember face membership (for linked nodes) + + if Nmin > 0: # node is on a back face + # prepare for any non-existing entries in the data structure + if key['x'] not in baseNode.keys(): + baseNode[key['x']] = {} + if key['y'] not in baseNode[key['x']].keys(): + baseNode[key['x']][key['y']] = {} + if key['z'] not in baseNode[key['x']][key['y']].keys(): + baseNode[key['x']][key['y']][key['z']] = 0 + + baseNode[key['x']][key['y']][key['z']] = node+1 # remember the base node id + + if Nmax > 0 and Nmax >= Nmin: # node is on at least as many front than back faces + if any([maxFlag[i] and active[i] for i in range(3)]): + linkNodes.append({'id':node+1,'coord':NodeCoords[node],'faceMember':[maxFlag[i] and active[i] for i in range(3)]}) + + mfd_data[mfd_dict['entities']]['els'][0][0] += len(linkNodes) * 3 + + baseCorner = baseNode["%.8e"%box['min'][0]]["%.8e"%box['min'][1]]["%.8e"%box['min'][2]] # detect ultimate base node + + links = {'uid': 1705, 'label': 'links', 'els': [[7,0],[9,0]]} + linkID = 0 + for node in linkNodes: # loop over all linked nodes + linkCoord = [node['coord']] # start list of control node coords with my coords + for dir in range(3): # check for each direction + if node['faceMember'][dir]: # me on this front face + linkCoord[0][dir] = box['min'][dir] # project me onto rear face along dir + linkCoord.append(np.array(box['min'])) # append base corner + linkCoord[-1][dir] = box['max'][dir] # stretch it to corresponding control leg of "dir" + + nLinks = len(linkCoord) + for dof in [1,2,3]: + tied_node = node['id'] + nterms = 1 + nLinks + + linkID += 1 + # Link header + links['els'].append('link{0}\n'.format(linkID)) + links['els'].append([linkID, 1]) + links['els'].append([0]) + links['els'].append([0]) + links['els'].append([0, 0, 0, tied_node]) + + # these need to be put in groups of four + link_payload = [dof, 0, nterms] + + # Individual node contributions (node, dof, coef.) + for i in range(nterms): + if i == nLinks: + link_payload.append(baseCorner) + else: + link_payload.append(baseNode["%.8e"%linkCoord[i][0]]["%.8e"%linkCoord[i][1]]["%.8e"%linkCoord[i][2]]) + for i in range(nterms): + link_payload.append(dof) + for i in range(nterms): + if i == nLinks: + link_payload.append(1.0 - nLinks) + else: + link_payload.append(1.0) + + # Needs to be formatted 4 data points per row, character width of 20, so 80 total + for j in range(0, len(link_payload), 4): + links['els'].append(link_payload[j:j+4]) + if j+4 < len(link_payload): + links['els'].append(link_payload[j+4:]) + + i = 0 + while i < len(mfd_data) and mfd_data[i]['uid'] < 1705: i += 1 + + if mfd_data[i]['uid'] == 1705: del mfd_data[i] + mfd_data.insert(i, links) + + +#-------------------------------------------------------------------------------------------------- +# MAIN +#-------------------------------------------------------------------------------------------------- + +parser = OptionParser(usage='%prog options [file[s]]', description = """ +Set up servo linking to achieve periodic boundary conditions for a regular hexahedral mesh. +Use *py_connection to operate on model presently opened in MSC.Mentat. +""", version = script_id) + +parser.add_option('-p', '--port', + type = int, metavar = 'int', default = None, + help = 'Mentat connection port') +parser.add_option('-x', + action = 'store_false', default = True, + help = 'no PBC along x direction') +parser.add_option('-y', + action = 'store_false', default = True, + help = 'no PBC along y direction') +parser.add_option('-z', + action = 'store_false', default = True, + help = 'no PBC along z direction') + +(options, filenames) = parser.parse_args() + +remote = options.port is not None + +if remote and filenames != []: + parser.error('file can not be specified when port is given.') +if filenames == []: filenames = [None] + +if remote: + sys.path.append(str(damask.solver.Marc().library_path)) + import py_mentat + + print(script_name+': waiting to connect...') + filenames = [os.path.join(tempfile._get_default_tempdir(), next(tempfile._get_candidate_names()) + '.mfd')] + try: + py_mentat.py_connect('',options.port) + py_mentat.py_send('*set_save_formatted on') + py_mentat.py_send('*save_as_model "{}" yes'.format(filenames[0])) + py_mentat.py_get_int("nnodes()") + except py_mentat.InputError as err: + print(f'{err}. Try Tools/Python/"Run as Separate Process" & "Initiate".') + sys.exit(-1) + print( 'connected...') + +for name in filenames: + while remote and not os.path.exists(name): time.sleep(0.5) + with open( name,'r') if name is not None else sys.stdin as file_in: + print(script_name+': '+name) + mfd = parseMFD(file_in) + + add_servoLinks(mfd,[options.x,options.y,options.z]) + with open( name,'w') if name is not None else sys.stdout as file_out: + file_out.write(asMFD(mfd)) + +if remote: + py_mentat.py_send('*open_model "{}"'.format(filenames[0])) diff --git a/processing/pre/mentat_spectralBox.py b/processing/mentat_spectralBox.py similarity index 94% rename from processing/pre/mentat_spectralBox.py rename to processing/mentat_spectralBox.py index 72206a8f4..de6307469 100755 --- a/processing/pre/mentat_spectralBox.py +++ b/processing/mentat_spectralBox.py @@ -7,8 +7,8 @@ from optparse import OptionParser import damask -scriptName = os.path.splitext(os.path.basename(__file__))[0] -scriptID = ' '.join([scriptName,damask.version]) +script_name = os.path.splitext(os.path.basename(__file__))[0] +script_id = ' '.join([script_name,damask.version]) #------------------------------------------------------------------------------------------------- def outMentat(cmd,locals): @@ -45,7 +45,7 @@ def output(cmds,locals,dest): #------------------------------------------------------------------------------------------------- def init(): return [ - "|"+' '.join([scriptID] + sys.argv[1:]), + "|"+' '.join([script_id] + sys.argv[1:]), "*draw_manual", # prevent redrawing in Mentat, should be much faster "*new_model yes", "*reset", @@ -170,7 +170,7 @@ def initial_conditions(material): parser = OptionParser(usage='%prog options [file[s]]', description = """ Generate MSC.Marc FE hexahedral mesh from geom file. -""", version = scriptID) +""", version = script_id) parser.add_option('-p', '--port', dest = 'port', @@ -194,7 +194,7 @@ if options.port is not None: if filenames == []: filenames = [None] for name in filenames: - print(scriptName+': '+name) + print(script_name+': '+name) geom = damask.Grid.load(StringIO(''.join(sys.stdin.read())) if name is None else name) material = geom.material.flatten(order='F') @@ -211,11 +211,11 @@ for name in filenames: '*draw_automatic', ] - outputLocals = {} + output_locals = {} if options.port: py_mentat.py_connect('',options.port) - output(cmds,outputLocals,'Mentat') + output(cmds,output_locals,'Mentat') py_mentat.py_disconnect() else: with sys.stdout if name is None else open(os.path.splitext(name)[0]+'.proc','w') as f: - output(cmds,outputLocals,f) + output(cmds,output_locals,f) diff --git a/processing/pre/mentat_pbcOnBoxMesh.py b/processing/pre/mentat_pbcOnBoxMesh.py deleted file mode 100755 index 1cf18eeda..000000000 --- a/processing/pre/mentat_pbcOnBoxMesh.py +++ /dev/null @@ -1,262 +0,0 @@ -#!/usr/bin/env python3 - -import sys -import os -import re -import time -import tempfile -from optparse import OptionParser - -import numpy as np - -import damask - -scriptName = os.path.splitext(os.path.basename(__file__))[0] -scriptID = ' '.join([scriptName,damask.version]) - -# Convert .mfd file into a usable format -# Broken into labeled sections (eg. nodes, links, etc) -# Each section has a list of labeled elements with formatted numerical data -def parseMFD(dat): - formatted = [] - section = 0 - formatted.append({'label': 'header', 'uid': -1, 'els': []}) - # in between =beg= and =end= part of file - in_block = False - for line in dat: - if in_block: # currently in a section - # lines that start with a space are numerical data - if line[0] == ' ': - formatted[section]['els'].append([]) - - # grab numbers - nums = re.split(r'\s+', line.strip()) - - for num in nums: - # floating point has format ' -x.xxxxxxxxxxxxe+yy' - # scientific notation is used for float - if (len(num) >= 4) and (num[-4] == 'e'): - formatted[section]['els'][-1].append(float(num)) - else: # integer - formatted[section]['els'][-1].append(int(num)) - else: # not numerical data, so it is a label for an element or section end - if line[0] == '=' and re.search(r'=end=$', line) is not None: # End of section, avoiding regex if possible - in_block = False - else: - formatted[section]['els'].append([]) - formatted[section]['els'][-1] = line - - else: # Not in a section, we are looking for a =beg= now - search = re.search(r'=beg=\s+(\d+)\s\((.*?)\)', line) - if search is not None: # found start of a new section - section += 1 - in_block = True - formatted.append({'label': search.group(2), 'uid': int(search.group(1)), 'els': []}) - else: # No =beg= found, probably in the header - # Either header or somthing we didn't plan for - just save the line so it isn't lost - if formatted[section]['uid'] > 0: - section += 1 - formatted.append({'label': '', 'uid': -2, 'els': []}) # make dummy section to store unrecognized data - formatted[section]['els'].append(line) - - return formatted - -def asMFD(mfd_data): - result = '' - for section in mfd_data: - if section['uid'] > 0: - result += '=beg={0:5d} ({1})\n'.format(section['uid'], section['label']) - for el in section['els']: - if type(el) == str: - result += el - elif type(el) == list: - for num in el: - if type(num) == int: - result += '{:20d}'.format(num) - elif type(num) == float: - result += '{:20.12e}'.format(num) - else: - print(f'WARNING: encountered unknown type: {type(el)}') - result += '\n' - else: - print(f'WARNING: encountered unknown type: {type(el)}') - if section['uid'] > 0: - result += '=end=\n' - return result.strip() - - -def add_servoLinks(mfd_data,active=[True,True,True]): # directions on which to add PBC - base = ['x','y','z'] - box = {'min': np.zeros(3,dtype='d'), - 'max': np.zeros(3,dtype='d'), - 'delta': np.zeros(3,dtype='d'), - } - - mfd_dict = {} - for i in range(len(mfd_data)): - mfd_dict[mfd_data[i]['label']] = i - - NodeCoords = np.array(mfd_data[mfd_dict['nodes']]['els'][1::4])[:,1:4] - Nnodes = NodeCoords.shape[0] - - box['min'] = NodeCoords.min(axis=0) # find the bounding box - box['max'] = NodeCoords.max(axis=0) - box['delta'] = box['max']-box['min'] - for coord in range(3): # calc the dimension of the bounding box - if box['delta'][coord] != 0.0: - for extremum in ['min','max']: - rounded = round(box[extremum][coord]*1e+15/box['delta'][coord]) * \ - 1e-15*box['delta'][coord] # rounding to 1e-15 of dimension - box[extremum][coord] = 0.0 if rounded == 0.0 else rounded # get rid of -0.0 (negative zeros) - baseNode = {} - linkNodes = [] - -#------------------------------------------------------------------------------------------------- -# loop over all nodes - for node in range(Nnodes): - key = {} - maxFlag = [False, False, False] - Nmax = 0 - Nmin = 0 - for coord in range(3): # for each direction - if box['delta'][coord] != 0.0: - rounded = round(NodeCoords[node,coord]*1e+15/box['delta'][coord]) * \ - 1e-15*box['delta'][coord] # rounding to 1e-15 of dimension - NodeCoords[node,coord] = 0.0 if rounded == 0.0 else rounded # get rid of -0.0 (negative zeros) - key[base[coord]] = "%.8e"%NodeCoords[node,coord] # translate position to string - if (key[base[coord]] == "%.8e"%box['min'][coord]): # compare to min of bounding box (i.e. is on outer face?) - Nmin += 1 # count outer (back) face membership - elif (key[base[coord]] == "%.8e"%box['max'][coord]): # compare to max of bounding box (i.e. is on outer face?) - Nmax += 1 # count outer (front) face membership - maxFlag[coord] = True # remember face membership (for linked nodes) - - if Nmin > 0: # node is on a back face - # prepare for any non-existing entries in the data structure - if key['x'] not in baseNode.keys(): - baseNode[key['x']] = {} - if key['y'] not in baseNode[key['x']].keys(): - baseNode[key['x']][key['y']] = {} - if key['z'] not in baseNode[key['x']][key['y']].keys(): - baseNode[key['x']][key['y']][key['z']] = 0 - - baseNode[key['x']][key['y']][key['z']] = node+1 # remember the base node id - - if Nmax > 0 and Nmax >= Nmin: # node is on at least as many front than back faces - if any([maxFlag[i] and active[i] for i in range(3)]): - linkNodes.append({'id': node+1,'coord': NodeCoords[node], 'faceMember': [maxFlag[i] and active[i] for i in range(3)]}) - - mfd_data[mfd_dict['entities']]['els'][0][0] += len(linkNodes) * 3 - - baseCorner = baseNode["%.8e"%box['min'][0]]["%.8e"%box['min'][1]]["%.8e"%box['min'][2]] # detect ultimate base node - - links = {'uid': 1705, 'label': 'links', 'els': [[7,0],[9,0]]} - linkID = 0 - for node in linkNodes: # loop over all linked nodes - linkCoord = [node['coord']] # start list of control node coords with my coords - for dir in range(3): # check for each direction - if node['faceMember'][dir]: # me on this front face - linkCoord[0][dir] = box['min'][dir] # project me onto rear face along dir - linkCoord.append(np.array(box['min'])) # append base corner - linkCoord[-1][dir] = box['max'][dir] # stretch it to corresponding control leg of "dir" - - nLinks = len(linkCoord) - for dof in [1,2,3]: - tied_node = node['id'] - nterms = 1 + nLinks - - linkID += 1 - # Link header - links['els'].append('link{0}\n'.format(linkID)) - links['els'].append([linkID, 1]) - links['els'].append([0]) - links['els'].append([0]) - links['els'].append([0, 0, 0, tied_node]) - - # these need to be put in groups of four - link_payload = [dof, 0, nterms] - - # Individual node contributions (node, dof, coef.) - for i in range(nterms): - if i == nLinks: - link_payload.append(baseCorner) - else: - link_payload.append(baseNode["%.8e"%linkCoord[i][0]]["%.8e"%linkCoord[i][1]]["%.8e"%linkCoord[i][2]]) - for i in range(nterms): - link_payload.append(dof) - for i in range(nterms): - if i == nLinks: - link_payload.append(1.0 - nLinks) - else: - link_payload.append(1.0) - - # Needs to be formatted 4 data points per row, character width of 20, so 80 total - for j in range(0, len(link_payload), 4): - links['els'].append(link_payload[j:j+4]) - if j+4 < len(link_payload): - links['els'].append(link_payload[j+4:]) - - i = 0 - while i < len(mfd_data) and mfd_data[i]['uid'] < 1705: i += 1 - - if mfd_data[i]['uid'] == 1705: del mfd_data[i] - mfd_data.insert(i, links) - - -#-------------------------------------------------------------------------------------------------- -# MAIN -#-------------------------------------------------------------------------------------------------- - -parser = OptionParser(usage='%prog options [file[s]]', description = """ -Set up servo linking to achieve periodic boundary conditions for a regular hexahedral mesh. -Use *py_connection to operate on model presently opened in MSC.Mentat. -""", version = scriptID) - -parser.add_option('-p', '--port', - type = int, metavar = 'int', default = None, - help = 'Mentat connection port') -parser.add_option('-x', - action = 'store_false', default = True, - help = 'no PBC along x direction') -parser.add_option('-y', - action = 'store_false', default = True, - help = 'no PBC along y direction') -parser.add_option('-z', - action = 'store_false', default = True, - help = 'no PBC along z direction') - -(options, filenames) = parser.parse_args() - -remote = options.port is not None - -if remote and filenames != []: - parser.error('file can not be specified when port is given.') -if filenames == []: filenames = [None] - -if remote: - sys.path.append(str(damask.solver.Marc().library_path)) - import py_mentat - - print(scriptName+': waiting to connect...') - filenames = [os.path.join(tempfile._get_default_tempdir(), next(tempfile._get_candidate_names()) + '.mfd')] - try: - py_mentat.py_connect('',options.port) - py_mentat.py_send('*set_save_formatted on') - py_mentat.py_send('*save_as_model "{}" yes'.format(filenames[0])) - py_mentat.py_get_int("nnodes()") - except py_mentat.InputError as err: - print(f'{err}. Try Tools/Python/"Run as Separate Process" & "Initiate".') - sys.exit(-1) - print( 'connected...') - -for name in filenames: - while remote and not os.path.exists(name): time.sleep(0.5) - with open( name,'r') if name is not None else sys.stdin as fileIn: - print(scriptName+': '+name) - mfd = parseMFD(fileIn) - - add_servoLinks(mfd,[options.x,options.y,options.z]) - with open( name,'w') if name is not None else sys.stdout as fileOut: - fileOut.write(asMFD(mfd)) - -if remote: - py_mentat.py_send('*open_model "{}"'.format(filenames[0])) diff --git a/python/damask/_config.py b/python/damask/_config.py index f6714cd81..1be1e313a 100644 --- a/python/damask/_config.py +++ b/python/damask/_config.py @@ -8,8 +8,10 @@ import numpy as np import yaml try: from yaml import CSafeLoader as SafeLoader + from yaml import CSafeDumper as SafeDumper except ImportError: from yaml import SafeLoader # type: ignore + from yaml import SafeDumper # type: ignore from ._typehints import FileHandle from . import Rotation @@ -17,20 +19,20 @@ from . import util MyType = TypeVar('MyType', bound='Config') -class NiceDumper(yaml.SafeDumper): +class NiceDumper(SafeDumper): """Make YAML readable for humans.""" def write_line_break(self, data: Optional[str] = None): - super().write_line_break(data) + super().write_line_break(data) # type: ignore - if len(self.indents) == 1: - super().write_line_break() + if len(self.indents) == 1: # type: ignore + super().write_line_break() # type: ignore def increase_indent(self, flow: bool = False, indentless: bool = False): - return super().increase_indent(flow, False) + return super().increase_indent(flow, False) # type: ignore def represent_data(self, data: Any): @@ -41,8 +43,10 @@ class NiceDumper(yaml.SafeDumper): return self.represent_data(data.tolist()) if isinstance(data, Rotation): return self.represent_data(data.quaternion.tolist()) - else: - return super().represent_data(data) + if hasattr(data, 'dtype'): + return self.represent_data(data.item()) + + return super().represent_data(data) def ignore_aliases(self, data: Any) -> bool: diff --git a/python/damask/_grid.py b/python/damask/_grid.py index c73311482..72b3c850f 100644 --- a/python/damask/_grid.py +++ b/python/damask/_grid.py @@ -19,6 +19,14 @@ from . import Rotation from . import Table from . import Colormap from ._typehints import FloatSequence, IntSequence, IntCollection, NumpyRngSeed +try: + import numba as nb # type: ignore +except ImportError: + nb = False + +def numba_njit_wrapper(**kwargs): + return (lambda function: nb.njit(function) if nb else function) + class Grid: """ @@ -1129,7 +1137,7 @@ class Grid: """ def most_frequent(stencil: np.ndarray, selection: Union[None,set], - rng): + rng: np.random.Generator): me = stencil[stencil.size//2] if selection is None or me in selection: unique, counts = np.unique(stencil,return_counts=True) @@ -1289,19 +1297,27 @@ class Grid: Updated grid-based geometry. """ - def tainted_neighborhood(stencil: np.ndarray, selection: Union[None,set]): + @numba_njit_wrapper() + def tainted_neighborhood(stencil: np.ndarray, + selection: Optional[np.ndarray] = None): me = stencil[stencil.size//2] - return np.any(stencil != me if selection is None else - np.in1d(stencil,np.array(list(selection - {me})))) - + if selection is None: + return np.any(stencil != me) + elif not len(selection)==0: + for stencil_item in stencil: + for selection_item in selection: + if stencil_item==selection_item and selection_item!=me: + return True + return False d = np.floor(distance).astype(np.int64) ext = np.linspace(-d,d,1+2*d,dtype=float), xx,yy,zz = np.meshgrid(ext,ext,ext) footprint = xx**2+yy**2+zz**2 <= distance**2+distance*1e-8 offset_ = np.nanmax(self.material)+1 if offset is None else offset selection_ = None if selection is None else \ - set(self.material.flatten()) - set(util.aslist(selection)) if invert_selection else \ - set(self.material.flatten()) & set(util.aslist(selection)) + np.array(list(set(self.material.flatten()) - set(util.aslist(selection)))) if invert_selection else \ + np.array(list(set(self.material.flatten()) & set(util.aslist(selection)))) + mask = ndimage.generic_filter(self.material, tainted_neighborhood, footprint=footprint, diff --git a/python/damask/_orientation.py b/python/damask/_orientation.py index 06eb6f3fc..2206d5b2a 100644 --- a/python/damask/_orientation.py +++ b/python/damask/_orientation.py @@ -627,7 +627,7 @@ class Orientation(Rotation,Crystal): weights : numpy.ndarray, shape (self.shape), optional Relative weights of orientations. return_cloud : bool, optional - Return the set of symmetrically equivalent orientations that was used in averaging. + Return the specific (symmetrically equivalent) orientations that were averaged. Defaults to False. Returns @@ -635,7 +635,7 @@ class Orientation(Rotation,Crystal): average : Orientation Weighted average of original Orientation field. cloud : Orientations, conditional - Set of symmetrically equivalent orientations that were used in averaging. + Symmetrically equivalent version of each orientation that were actually used in averaging. References ---------- @@ -660,7 +660,7 @@ class Orientation(Rotation,Crystal): proper: bool = False, return_operators: bool = False) -> np.ndarray: """ - Rotate vector to ensure it falls into (improper or proper) standard stereographic triangle of crystal symmetry. + Rotate lab frame vector to ensure it falls into (improper or proper) standard stereographic triangle of crystal symmetry. Parameters ---------- @@ -679,7 +679,7 @@ class Orientation(Rotation,Crystal): ------- vector_SST : numpy.ndarray, shape (...,3) Rotated vector falling into SST. - operators : numpy.ndarray of int, shape (...), conditional + operator : numpy.ndarray of int, shape (...), conditional Index of symmetrically equivalent orientation that rotated vector to SST. """ @@ -749,12 +749,12 @@ class Orientation(Rotation,Crystal): in_SST: bool = True, proper: bool = False) -> np.ndarray: """ - Map vector to RGB color within standard stereographic triangle of own symmetry. + Map lab frame vector to RGB color within standard stereographic triangle of own symmetry. Parameters ---------- vector : numpy.ndarray, shape (...,3) - Vector to colorize. + Lab frame vector to colorize. Shape of vector blends with shape of own rotation array. For example, a rotation array of shape (3,2) and a vector array of shape (2,4) result in (3,2,4) outputs. in_SST : bool, optional @@ -771,13 +771,26 @@ class Orientation(Rotation,Crystal): Examples -------- - Inverse pole figure color of the e_3 direction for a crystal in "Cube" orientation with cubic symmetry: + Inverse pole figure color of the e_3 lab direction for a + crystal in "Cube" orientation with cubic symmetry: >>> import damask >>> o = damask.Orientation(family='cubic') >>> o.IPF_color([0,0,1]) array([1., 0., 0.]) + Sample standard triangle for hexagonal symmetry: + + >>> import damask + >>> from matplotlib import pyplot as plt + >>> lab = [0,0,1] + >>> o = damask.Orientation.from_random(shape=500000,family='hexagonal') + >>> coord = damask.util.project_equal_area(o.to_SST(lab)) + >>> color = o.IPF_color(lab) + >>> plt.scatter(coord[:,0],coord[:,1],color=color,s=.06) + >>> plt.axis('scaled') + >>> plt.show() + """ if np.array(vector).shape[-1] != 3: raise ValueError('input is not a field of three-dimensional vectors') @@ -807,7 +820,7 @@ class Orientation(Rotation,Crystal): in_SST_ = np.all(components >= 0.0,axis=-1) with np.errstate(invalid='ignore',divide='ignore'): - rgb = (components/np.linalg.norm(components,axis=-1,keepdims=True))**0.5 # smoothen color ramps + rgb = (components/np.linalg.norm(components,axis=-1,keepdims=True))**(1./3.) # smoothen color ramps rgb = np.clip(rgb,0.,1.) # clip intensity rgb /= np.max(rgb,axis=-1,keepdims=True) # normalize to (HS)V = 1 rgb[np.broadcast_to(~in_SST_[...,np.newaxis],rgb.shape)] = 0.0 diff --git a/python/damask/grid_filters.py b/python/damask/grid_filters.py index bafae81d4..fab346c4e 100644 --- a/python/damask/grid_filters.py +++ b/python/damask/grid_filters.py @@ -75,8 +75,8 @@ def curl(size: _FloatSequence, e[0, 2, 1] = e[2, 1, 0] = e[1, 0, 2] = -1.0 f_fourier = _np.fft.rfftn(f,axes=(0,1,2)) - curl_ = (_np.einsum('slm,ijkl,ijkm ->ijks', e,k_s,f_fourier)*2.0j*_np.pi if n == 3 else # vector, 3 -> 3 - _np.einsum('slm,ijkl,ijknm->ijksn',e,k_s,f_fourier)*2.0j*_np.pi) # tensor, 3x3 -> 3x3 + curl_ = (_np.einsum('slm,ijkl,ijkm ->ijks' if n == 3 else + 'slm,ijkl,ijknm->ijksn',e,k_s,f_fourier)*2.0j*_np.pi) # vector 3->3, tensor 3x3->3x3 return _np.fft.irfftn(curl_,axes=(0,1,2),s=f.shape[:3]) @@ -103,10 +103,10 @@ def divergence(size: _FloatSequence, k_s = _ks(size,f.shape[:3],True) f_fourier = _np.fft.rfftn(f,axes=(0,1,2)) - div_ = (_np.einsum('ijkl,ijkl ->ijk', k_s,f_fourier)*2.0j*_np.pi if n == 3 else # vector, 3 -> 1 - _np.einsum('ijkm,ijklm->ijkl',k_s,f_fourier)*2.0j*_np.pi) # tensor, 3x3 -> 3 + divergence_ = (_np.einsum('ijkl,ijkl ->ijk' if n == 3 else + 'ijkm,ijklm->ijkl', k_s,f_fourier)*2.0j*_np.pi) # vector 3->1, tensor 3x3->3 - return _np.fft.irfftn(div_,axes=(0,1,2),s=f.shape[:3]) + return _np.fft.irfftn(divergence_,axes=(0,1,2),s=f.shape[:3]) def gradient(size: _FloatSequence, @@ -124,17 +124,17 @@ def gradient(size: _FloatSequence, Returns ------- ∇ f : numpy.ndarray, shape (:,:,:,3) or (:,:,:,3,3) - Divergence of f. + Gradient of f. """ n = _np.prod(f.shape[3:]) k_s = _ks(size,f.shape[:3],True) f_fourier = _np.fft.rfftn(f,axes=(0,1,2)) - grad_ = (_np.einsum('ijkl,ijkm->ijkm', f_fourier,k_s)*2.0j*_np.pi if n == 1 else # scalar, 1 -> 3 - _np.einsum('ijkl,ijkm->ijklm',f_fourier,k_s)*2.0j*_np.pi) # vector, 3 -> 3x3 + gradient_ = (_np.einsum('ijkl,ijkm->ijkm' if n == 1 else + 'ijkl,ijkm->ijklm',f_fourier,k_s)*2.0j*_np.pi) # scalar 1->3, vector 3->3x3 - return _np.fft.irfftn(grad_,axes=(0,1,2),s=f.shape[:3]) + return _np.fft.irfftn(gradient_,axes=(0,1,2),s=f.shape[:3]) def coordinates0_point(cells: _IntSequence, @@ -296,8 +296,8 @@ def cellsSizeOrigin_coordinates0_point(coordinates0: _np.ndarray, origin = mincorner - delta*.5 # 1D/2D: size/origin combination undefined, set origin to 0.0 - size [_np.where(cells==1)] = origin[_np.where(cells==1)]*2. - origin[_np.where(cells==1)] = 0.0 + size [_np.where(cells == 1)] = origin[_np.where(cells == 1)]*2. + origin[_np.where(cells == 1)] = 0.0 if cells.prod() != len(coordinates0): raise ValueError(f'data count {len(coordinates0)} does not match cells {cells}') diff --git a/python/tests/test_Config.py b/python/tests/test_Config.py index e6fa2daff..0fce31106 100644 --- a/python/tests/test_Config.py +++ b/python/tests/test_Config.py @@ -46,7 +46,8 @@ class TestConfig: assert Config.load(tmp_path/'config.yaml') == config def test_numpy(self,tmp_path): - assert Config({'A':np.ones(3,'i')}).__repr__() == Config({'A':[1,1,1]}).__repr__() + assert Config({'A':np.ones(3,'i'), 'B':np.ones(1)[0]}).__repr__() == \ + Config({'A':[1,1,1], 'B':1.0}).__repr__() def test_abstract_is_valid(self): with pytest.raises(NotImplementedError): diff --git a/python/tests/test_Rotation.py b/python/tests/test_Rotation.py index aa7115200..e59f7e6bf 100644 --- a/python/tests/test_Rotation.py +++ b/python/tests/test_Rotation.py @@ -7,6 +7,7 @@ from damask import Table from damask import _rotation from damask import grid_filters from damask import util +from damask import tensor n = 1000 atol=1.e-4 @@ -20,6 +21,16 @@ def ref_path(ref_path_base): def set_of_rotations(set_of_quaternions): return [Rotation.from_quaternion(s) for s in set_of_quaternions] +@pytest.fixture +def multidim_rotations(set_of_quaternions): + L = len(set_of_quaternions) + i = 0 + while L%(f:=np.random.randint(2,np.sqrt(L).astype(int))) > 0 and i= 0.).all and (v < np.pi+1.e-9).all() - @pytest.mark.parametrize('P',[1,-1]) - @pytest.mark.parametrize('normalize',[True,False]) - def test_Rodrigues(self,set_of_rotations,normalize,P): - c = np.array([P*-1,P*-1,P*-1,1.]) - c[:3] *= 0.9 if normalize else 1.0 - for rot in set_of_rotations: - m = rot.as_matrix() - o = Rotation.from_Rodrigues_vector(rot.as_Rodrigues_vector()*c,normalize,P).as_matrix() - ok = np.allclose(m,o,atol=atol) - assert ok and np.isclose(np.linalg.det(o),1.0), f'{m},{o}' + r = m.as_matrix() + assert np.allclose(1.,np.linalg.det(r)) - def test_Rodrigues_compact(self,set_of_rotations): - for rot in set_of_rotations: - c = rot.as_Rodrigues_vector(compact=True) - r = rot.as_Rodrigues_vector(compact=False) - assert np.allclose(r[:3]*r[3], c, equal_nan=True) + e = m.as_Euler_angles(degrees=False) + assert (e >= 0.).all and (e < np.pi*np.array([2.,1.,2.])+1.e-9).all() + + c = m.as_cubochoric() + assert (np.linalg.norm(c,ord=np.inf,axis=-1) < np.pi**(2./3.)*0.5+1.e-9).all() + + h = m.as_homochoric() + assert (np.linalg.norm(h,axis=-1) < (3.*np.pi/4.)**(1./3.) + 1.e-9).all() - @pytest.mark.parametrize('P',[1,-1]) - def test_homochoric(self,set_of_rotations,P): - cutoff = np.tan(np.pi*.5*(1.-1e-4)) - for rot in set_of_rotations: - m = rot.as_Rodrigues_vector() - o = Rotation.from_homochoric(rot.as_homochoric()*P*-1,P).as_Rodrigues_vector() - ok = np.allclose(np.clip(m,None,cutoff),np.clip(o,None,cutoff),atol=atol) - ok |= np.isclose(m[3],0.0,atol=atol) - assert ok and np.isclose(np.linalg.norm(o[:3]),1.0), f'{m},{o},{rot.as_quaternion()}' - - @pytest.mark.parametrize('P',[1,-1]) - def test_cubochoric(self,set_of_rotations,P): - for rot in set_of_rotations: - m = rot.as_homochoric() - o = Rotation.from_cubochoric(rot.as_cubochoric()*P*-1,P).as_homochoric() - ok = np.allclose(m,o,atol=atol) - assert ok and np.linalg.norm(o) < (3.*np.pi/4.)**(1./3.) + 1.e-9, f'{m},{o},{rot.as_quaternion()}' - - @pytest.mark.parametrize('P',[1,-1]) @pytest.mark.parametrize('accept_homomorph',[True,False]) @pytest.mark.parametrize('normalize',[True,False]) - def test_quaternion(self,set_of_rotations,P,accept_homomorph,normalize): - c = np.array([1,P*-1,P*-1,P*-1]) * (-1 if accept_homomorph else 1) * (0.9 if normalize else 1.0) - for rot in set_of_rotations: - m = rot.as_cubochoric() - o = Rotation.from_quaternion(rot.as_quaternion()*c,accept_homomorph,normalize,P).as_cubochoric() - ok = np.allclose(m,o,atol=atol) - if np.count_nonzero(np.isclose(np.abs(o),np.pi**(2./3.)*.5)): - ok |= np.allclose(m*-1.,o,atol=atol) - assert ok and o.max() < np.pi**(2./3.)*0.5+1.e-9, f'{m},{o},{rot.as_quaternion()}' + @pytest.mark.parametrize('P',[1,-1]) + def test_quaternion(self,multidim_rotations,accept_homomorph,normalize,P): + c = np.array([1,-P,-P,-P]) * (-1 if accept_homomorph else 1) * (0.9 if normalize else 1.0) + m = multidim_rotations + o = Rotation.from_quaternion(m.as_quaternion()*c, + accept_homomorph=accept_homomorph, + normalize=normalize, + P=P) + f = Rotation(np.where(np.isclose(m.as_quaternion()[...,0],0.0,atol=atol)[...,np.newaxis],~o,o)) + assert np.logical_or(m.isclose(o,atol=atol), + m.isclose(f,atol=atol) + ).all() + + + @pytest.mark.parametrize('degrees',[True,False]) + def test_Eulers(self,multidim_rotations,degrees): + m = multidim_rotations + o = Rotation.from_Euler_angles(m.as_Euler_angles(degrees), + degrees=degrees) + f = Rotation(np.where(np.isclose(m.as_quaternion()[...,0],0.0,atol=atol)[...,np.newaxis],~o,o)) + assert np.logical_or(m.isclose(o,atol=atol), + m.isclose(f,atol=atol) + ).all() + + + @pytest.mark.parametrize('degrees',[True,False]) + @pytest.mark.parametrize('normalize',[True,False]) + @pytest.mark.parametrize('P',[1,-1]) + def test_axis_angle(self,multidim_rotations,degrees,normalize,P): + c = np.array([-P,-P,-P,1.]) + c[:3] *= 0.9 if normalize else 1.0 + + m = multidim_rotations + o = Rotation.from_axis_angle(m.as_axis_angle(degrees)*c, + degrees=degrees, + normalize=normalize, + P=P) + f = Rotation(np.where(np.isclose(m.as_quaternion()[...,0],0.0,atol=atol)[...,np.newaxis],~o,o)) + assert np.logical_or(m.isclose(o,atol=atol), + m.isclose(f,atol=atol) + ).all() + + + def test_matrix(self,multidim_rotations): + m = multidim_rotations + o = Rotation.from_matrix(m.as_matrix()) + f = Rotation(np.where(np.isclose(m.as_quaternion()[...,0],0.0,atol=atol)[...,np.newaxis],~o,o)) + assert np.logical_or(m.isclose(o,atol=atol), + m.isclose(f,atol=atol) + ).all() + + + def test_parallel(self,multidim_rotations): + m = multidim_rotations + a = np.broadcast_to(np.array([[1.0,0.0,0.0], + [0.0,1.0,0.0]]),m.shape+(2,3)) + assert m.allclose(Rotation.from_parallel(a,m.broadcast_to(m.shape+(2,))@a)) + + + @pytest.mark.parametrize('normalize',[True,False]) + @pytest.mark.parametrize('P',[1,-1]) + def test_Rodrigues(self,multidim_rotations,normalize,P): + c = np.array([-P,-P,-P,1.]) + c[:3] *= 0.9 if normalize else 1.0 + m = multidim_rotations + o = Rotation.from_Rodrigues_vector(m.as_Rodrigues_vector()*c, + normalize=normalize, + P=P) + f = Rotation(np.where(np.isclose(m.as_quaternion()[...,0],0.0,atol=atol)[...,np.newaxis],~o,o)) + assert np.logical_or(m.isclose(o,atol=atol), + m.isclose(f,atol=atol) + ).all() + + + def test_Rodrigues_compact(self,multidim_rotations): + m = multidim_rotations + c = m.as_Rodrigues_vector(compact=True) + r = m.as_Rodrigues_vector(compact=False) + assert np.allclose(r[...,:3]*r[...,3:], c, equal_nan=True) + + + @pytest.mark.parametrize('P',[1,-1]) + def test_homochoric(self,multidim_rotations,P): + m = multidim_rotations + o = Rotation.from_homochoric(m.as_homochoric()*-P, + P=P) + f = Rotation(np.where(np.isclose(m.as_quaternion()[...,0],0.0,atol=atol)[...,np.newaxis],~o,o)) + assert np.logical_or(m.isclose(o,atol=atol), + m.isclose(f,atol=atol) + ).all() + + + @pytest.mark.parametrize('P',[1,-1]) + def test_cubochoric(self,multidim_rotations,P): + m = multidim_rotations + o = Rotation.from_cubochoric(m.as_cubochoric()*-P, + P=P) + f = Rotation(np.where(np.isclose(m.as_quaternion()[...,0],0.0,atol=atol)[...,np.newaxis],~o,o)) + assert np.logical_or(m.isclose(o,atol=atol), + m.isclose(f,atol=atol) + ).all() + @pytest.mark.parametrize('reciprocal',[True,False]) - def test_basis(self,set_of_rotations,reciprocal): - for rot in set_of_rotations: - om = rot.as_matrix() + 0.1*np.eye(3) - rot = Rotation.from_basis(om,False,reciprocal=reciprocal) - assert np.isclose(np.linalg.det(rot.as_matrix()),1.0) + def test_basis(self,multidim_rotations,reciprocal): + m = multidim_rotations + r = m.as_matrix() + r = np.linalg.inv(tensor.transpose(r)/np.pi) if reciprocal else r + o = Rotation.from_basis(r, + reciprocal=reciprocal) + f = Rotation(np.where(np.isclose(m.as_quaternion()[...,0],0.0,atol=atol)[...,np.newaxis],~o,o)) + assert np.logical_or(m.isclose(o,atol=atol), + m.isclose(f,atol=atol) + ).all() + @pytest.mark.parametrize('shape',[None,1,(4,4)]) def test_random(self,shape): r = Rotation.from_random(shape) - if shape is None: - assert r.shape == () - elif shape == 1: - assert r.shape == (1,) - else: - assert r.shape == shape + assert r.shape == () if shape is None else (1,) if shape == 1 else shape @pytest.mark.parametrize('shape',[None,5,(4,6)]) def test_equal(self,shape): @@ -822,7 +872,7 @@ class TestRotation: def test_equal_ambiguous(self): qu = np.random.rand(10,4) qu[:,0] = 0. - qu/=np.linalg.norm(qu,axis=1,keepdims=True) + qu /= np.linalg.norm(qu,axis=1,keepdims=True) assert (Rotation(qu) == Rotation(-qu)).all() def test_inversion(self): @@ -947,13 +997,13 @@ class TestRotation: p = np.random.rand(n,3) o = Rotation._get_pyramid_order(p,direction) for i,o_i in enumerate(o): - assert np.all(o_i==Rotation._get_pyramid_order(p[i],direction)) + assert (o_i==Rotation._get_pyramid_order(p[i],direction)).all() def test_pyramid_invariant(self): a = np.random.rand(n,3) f = Rotation._get_pyramid_order(a,'forward') b = Rotation._get_pyramid_order(a,'backward') - assert np.all(np.take_along_axis(np.take_along_axis(a,f,-1),b,-1) == a) + assert (np.take_along_axis(np.take_along_axis(a,f,-1),b,-1) == a).all() @pytest.mark.parametrize('data',[np.random.rand(5,3), diff --git a/src/CLI.f90 b/src/CLI.f90 index 4fef460ff..ce7e4ca1b 100644 --- a/src/CLI.f90 +++ b/src/CLI.f90 @@ -209,7 +209,7 @@ subroutine setWorkingDirectory(workingDirectoryArg) workingDirectory = trim(rectifyPath(workingDirectory)) error = setCWD(trim(workingDirectory)) - if(error) then + if (error) then print*, 'ERROR: Invalid Working directory: '//trim(workingDirectory) call quit(1) end if @@ -324,7 +324,7 @@ function rectifyPath(path) end if i = j+index(rectifyPath(j+1:l),'../') end do - if(len_trim(rectifyPath) == 0) rectifyPath = '/' + if (len_trim(rectifyPath) == 0) rectifyPath = '/' rectifyPath = trim(rectifyPath) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 4829d0729..a87046c5a 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -183,7 +183,7 @@ integer(HID_T) function HDF5_openFile(fileName,mode,parallel) end if call H5Pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' #ifdef PETSC if (present(parallel)) then @@ -197,24 +197,24 @@ integer(HID_T) function HDF5_openFile(fileName,mode,parallel) call H5Pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) #endif end if - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' #endif if (m == 'w') then call H5Fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' - elseif(m == 'a') then + if (hdferr < 0) error stop 'HDF5 error' + elseif (m == 'a') then call H5Fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' - elseif(m == 'r') then + if (hdferr < 0) error stop 'HDF5 error' + elseif (m == 'r') then call H5Fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' else error stop 'unknown access mode' end if call H5Pclose_f(plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end function HDF5_openFile @@ -229,7 +229,7 @@ subroutine HDF5_closeFile(fileHandle) integer :: hdferr call H5Fclose_f(fileHandle,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine HDF5_closeFile @@ -248,19 +248,19 @@ integer(HID_T) function HDF5_addGroup(fileHandle,groupName) !------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call H5Pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !------------------------------------------------------------------------------------------------- ! setting I/O mode to collective #ifdef PETSC call H5Pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' #endif !------------------------------------------------------------------------------------------------- ! Create group call H5Gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Pclose_f(aplist_id,hdferr) @@ -284,19 +284,19 @@ integer(HID_T) function HDF5_openGroup(fileHandle,groupName) !------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call H5Pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !------------------------------------------------------------------------------------------------- ! setting I/O mode to collective #ifdef PETSC call H5Pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' #endif !------------------------------------------------------------------------------------------------- ! opening the group call H5Gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Pclose_f(aplist_id,hdferr) @@ -313,7 +313,7 @@ subroutine HDF5_closeGroup(group_id) integer :: hdferr call H5Gclose_f(group_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine HDF5_closeGroup @@ -337,11 +337,11 @@ logical function HDF5_objectExists(loc_id,path) end if call H5Lexists_f(loc_id, p, HDF5_objectExists, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' - if(HDF5_objectExists) then + if (HDF5_objectExists) then call H5Oexists_by_name_f(loc_id, p, HDF5_objectExists, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if end function HDF5_objectExists @@ -374,24 +374,24 @@ subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path) ptr(1) = c_loc(attrValue_(1)) call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_STRING,space_id,attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Awrite_f(attr_id, H5T_STRING, c_loc(ptr), hdferr) ! ptr instead of c_loc(ptr) works on gfortran, not on ifort - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aclose_f(attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(space_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine HDF5_addAttribute_str @@ -419,24 +419,24 @@ subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path) end if call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, int([1],HSIZE_T), hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aclose_f(attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(space_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine HDF5_addAttribute_int @@ -464,24 +464,24 @@ subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path) end if call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, int([1],HSIZE_T), hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aclose_f(attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(space_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine HDF5_addAttribute_real @@ -516,24 +516,24 @@ subroutine HDF5_addAttribute_str_array(loc_id,attrLabel,attrValue,path) end do call H5Screate_simple_f(1,shape(attrValue_,kind=HSIZE_T),space_id,hdferr,shape(attrValue_,kind=HSIZE_T)) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_STRING,space_id,attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Awrite_f(attr_id, H5T_STRING, c_loc(ptr), hdferr) ! ptr instead of c_loc(ptr) works on gfortran, not on ifort - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aclose_f(attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(space_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine HDF5_addAttribute_str_array @@ -564,24 +564,24 @@ subroutine HDF5_addAttribute_int_array(loc_id,attrLabel,attrValue,path) array_size = size(attrValue,kind=HSIZE_T) call H5Screate_simple_f(1, array_size, space_id, hdferr, array_size) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, array_size, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aclose_f(attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(space_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine HDF5_addAttribute_int_array @@ -612,24 +612,24 @@ subroutine HDF5_addAttribute_real_array(loc_id,attrLabel,attrValue,path) array_size = size(attrValue,kind=HSIZE_T) call H5Screate_simple_f(1, array_size, space_id, hdferr, array_size) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' if (attrExists) then call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, array_size, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Aclose_f(attr_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(space_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine HDF5_addAttribute_real_array @@ -645,13 +645,13 @@ subroutine HDF5_setLink(loc_id,target_name,link_name) logical :: linkExists call H5Lexists_f(loc_id, link_name,linkExists, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' if (linkExists) then call H5Ldelete_f(loc_id,link_name, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call H5Lcreate_soft_f(target_name, loc_id, link_name, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine HDF5_setLink @@ -687,7 +687,7 @@ subroutine HDF5_read_real1(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -724,7 +724,7 @@ subroutine HDF5_read_real2(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -761,7 +761,7 @@ subroutine HDF5_read_real3(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -799,7 +799,7 @@ subroutine HDF5_read_real4(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -837,7 +837,7 @@ subroutine HDF5_read_real5(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -875,7 +875,7 @@ subroutine HDF5_read_real6(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -913,7 +913,7 @@ subroutine HDF5_read_real7(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -951,7 +951,7 @@ subroutine HDF5_read_int1(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -989,7 +989,7 @@ subroutine HDF5_read_int2(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -1026,7 +1026,7 @@ subroutine HDF5_read_int3(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -1063,7 +1063,7 @@ subroutine HDF5_read_int4(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -1100,7 +1100,7 @@ subroutine HDF5_read_int5(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -1138,7 +1138,7 @@ subroutine HDF5_read_int6(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -1176,7 +1176,7 @@ subroutine HDF5_read_int7(dataset,loc_id,datasetName,parallel) call H5Dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -1218,7 +1218,7 @@ subroutine HDF5_write_real1(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1259,7 +1259,7 @@ subroutine HDF5_write_real2(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1300,7 +1300,7 @@ subroutine HDF5_write_real3(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1341,7 +1341,7 @@ subroutine HDF5_write_real4(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1383,7 +1383,7 @@ subroutine HDF5_write_real5(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1424,7 +1424,7 @@ subroutine HDF5_write_real6(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1465,7 +1465,7 @@ subroutine HDF5_write_real7(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1529,7 +1529,7 @@ subroutine HDF5_write_real(dataset,loc_id,datasetName,parallel) call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) end select - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1556,14 +1556,14 @@ subroutine HDF5_write_str(dataset,loc_id,datasetName) dataset_ = trim(dataset) call H5Tcopy_f(H5T_C_S1, filetype_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tset_size_f(filetype_id, int(len(dataset_)+1,HSIZE_T), hdferr) ! +1 for NULL - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tcopy_f(H5T_FORTRAN_S1, memtype_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tset_size_f(memtype_id, int(len(dataset_),HSIZE_T), hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, hdferr) if (hdferr < 0) error stop 'HDF5 error' @@ -1579,23 +1579,23 @@ subroutine HDF5_write_str(dataset,loc_id,datasetName) end if call H5Screate_simple_f(1, [1_HSIZE_T], space_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' CALL H5Dcreate_f(loc_id, datasetName, filetype_id, space_id, dataset_id, hdferr, dcpl) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dwrite_f(dataset_id, memtype_id, c_loc(dataset_(1:1)), hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Pclose_f(dcpl, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dclose_f(dataset_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(space_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tclose_f(memtype_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tclose_f(filetype_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine HDF5_write_str @@ -1635,7 +1635,7 @@ subroutine HDF5_write_int1(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1676,7 +1676,7 @@ subroutine HDF5_write_int2(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1717,7 +1717,7 @@ subroutine HDF5_write_int3(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1758,7 +1758,7 @@ subroutine HDF5_write_int4(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1799,7 +1799,7 @@ subroutine HDF5_write_int5(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1840,7 +1840,7 @@ subroutine HDF5_write_int6(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1881,7 +1881,7 @@ subroutine HDF5_write_int7(dataset,loc_id,datasetName,parallel) if (product(totalShape) /= 0) then call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1945,7 +1945,7 @@ subroutine HDF5_write_int(dataset,loc_id,datasetName,parallel) call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) end select - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1978,7 +1978,7 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties (is collective for MPI) call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- readSize = 0_MPI_INTEGER_KIND @@ -1986,7 +1986,7 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ #ifdef PETSC if (parallel) then call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call MPI_Allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get total output size over each process if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' end if @@ -1997,35 +1997,35 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ if (any(globalShape == 0)) then call H5Pclose_f(plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' return end if !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call H5Screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! creating a property list for IO and set it to collective call H5Pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' #ifdef PETSC call H5Pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' #endif !-------------------------------------------------------------------------------------------------- ! open the dataset in the file and get the space ID call H5Dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dget_space_f(dset_id, filespace_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine initialize_read @@ -2039,15 +2039,15 @@ subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id integer :: hdferr call H5Pclose_f(plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Pclose_f(aplist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dclose_f(dset_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(filespace_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(memspace_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine finalize_read @@ -2080,11 +2080,11 @@ subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties (is collective when writing in parallel) call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' #ifdef PETSC if (parallel) then call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end if #endif @@ -2129,19 +2129,19 @@ subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) and in file (global shape) call H5Screate_simple_f(size(myShape), myShape, memspace_id, hdferr, myShape) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Screate_simple_f(size(totalShape), totalShape, filespace_id, hdferr, totalShape) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! create dataset in the file and select a hyperslab from it (the portion of the current process) call H5Dcreate_f(loc_id, trim(datasetName), datatype, filespace_id, dset_id, hdferr, dcpl) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, myShape, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Pclose_f(dcpl , hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' contains !------------------------------------------------------------------------------------------------ @@ -2170,13 +2170,13 @@ subroutine finalize_write(plist_id, dset_id, filespace_id, memspace_id) integer :: hdferr call H5Pclose_f(plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dclose_f(dset_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(filespace_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(memspace_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' end subroutine finalize_write diff --git a/src/IO.f90 b/src/IO.f90 index 1643cac71..8cc350b10 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -484,6 +484,8 @@ subroutine IO_error(error_ID,ext_msg,label1,ID1,label2,ID2) ! user errors case (602) msg = 'invalid selection for debug' + case (603) + msg = 'invalid data for table' !------------------------------------------------------------------------------------------------ ! errors related to YAML data diff --git a/src/Marc/DAMASK_Marc.f90 b/src/Marc/DAMASK_Marc.f90 index 8f93d93dc..024fd410b 100644 --- a/src/Marc/DAMASK_Marc.f90 +++ b/src/Marc/DAMASK_Marc.f90 @@ -70,7 +70,7 @@ subroutine DAMASK_interface_init if (ierr /= 0) then print*, 'working directory "'//trim(wd)//'" does not exist' call quit(1) - endif + end if symmetricSolver = solverIsSymmetric() end subroutine DAMASK_interface_init @@ -105,14 +105,14 @@ logical function solverIsSymmetric() status='old', position='rewind', action='read',iostat=myStat) do read (fileUnit,'(A)',END=100) line - if(index(trim(lc(line)),'solver') == 1) then + if (index(trim(lc(line)),'solver') == 1) then read (fileUnit,'(A)',END=100) line ! next line s = verify(line, ' ') ! start of first chunk s = s + verify(line(s+1:),' ') ! start of second chunk e = s + scan (line(s+1:),' ') ! end of second chunk solverIsSymmetric = line(s:e) /= '1' - endif - enddo + end if + end do 100 close(fileUnit) contains @@ -134,7 +134,7 @@ logical function solverIsSymmetric() lc(i:i) = string(i:i) n = index(UPPER,lc(i:i)) if (n/=0) lc(i:i) = LOWER(n:n) - enddo + end do end function lc end function solverIsSymmetric @@ -153,6 +153,7 @@ end module DAMASK_interface #include "../math.f90" #include "../rotations.f90" #include "../polynomials.f90" +#include "../tables.f90" #include "../lattice.f90" #include "element.f90" #include "../geometry_plastic_nonlocal.f90" @@ -286,7 +287,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & type(tList), pointer :: & debug_Marc ! pointer to Marc debug options - if(debug_basic) then + if (debug_basic) then print'(a,/,i8,i8,i2)', ' MSC.Marc information on shape of element(2), IP:', m, nn print'(a,2(i1))', ' Jacobian: ', ngens,ngens print'(a,i1)', ' Direct stress: ', ndi @@ -299,7 +300,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & transpose(ffn) write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' Deformation gradient at t=n+1:', & transpose(ffn1) - endif + end if defaultNumThreadsInt = omp_get_num_threads() ! remember number of threads set by Marc call omp_set_num_threads(1_pI32) ! no openMP @@ -309,7 +310,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & call materialpoint_initAll debug_Marc => config_debug%get_list('Marc',defaultVal=emptyList) debug_basic = debug_Marc%contains('basic') - endif + end if computationMode = 0 ! save initialization value, since it does not result in any calculation if (lovl == 4 ) then ! jacobian requested by marc @@ -333,35 +334,35 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & lastIncConverged = .true. outdatedByNewInc = .true. print'(a,i6,1x,i2)', '<< HYPELA2 >> new increment..! ',m(1),nn - endif + end if else if ( timinc < theDelta ) then ! >> cutBack << lastIncConverged = .false. outdatedByNewInc = .false. terminallyIll = .false. cycleCounter = -1 ! first calc step increments this to cycle = 0 print'(a,i6,1x,i2)', '<< HYPELA2 >> cutback detected..! ',m(1),nn - endif ! convergence treatment end + end if ! convergence treatment end flush(6) if (lastLovl /= lovl) then cycleCounter = cycleCounter + 1 !mesh_cellnode = mesh_build_cellnodes() ! update cell node coordinates !call mesh_build_ipCoordinates() ! update ip coordinates - endif + end if if (outdatedByNewInc) then computationMode = ior(computationMode,materialpoint_AGERESULTS) outdatedByNewInc = .false. - endif + end if if (lastIncConverged) then computationMode = ior(computationMode,materialpoint_BACKUPJACOBIAN) lastIncConverged = .false. - endif + end if theTime = cptim theDelta = timinc theInc = inc - endif + end if lastLovl = lovl call materialpoint_general(computationMode,ffn,ffn1,t(1),timinc,int(m(1)),int(nn),stress,ddsdde) @@ -369,7 +370,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & d = ddsdde(1:ngens,1:ngens) s = stress(1:ndi+nshear) g = 0.0_pReal - if(symmetricSolver) d = 0.5_pReal*(d+transpose(d)) + if (symmetricSolver) d = 0.5_pReal*(d+transpose(d)) call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value @@ -428,14 +429,14 @@ subroutine uedinc(inc,incsub) do n = lbound(discretization_Marc_FEM2DAMASK_node,1), ubound(discretization_Marc_FEM2DAMASK_node,1) if (discretization_Marc_FEM2DAMASK_node(n) /= -1) then call nodvar(1,n,d_n(1:3,discretization_Marc_FEM2DAMASK_node(n)),nqncomp,nqdatatype) - if(nqncomp == 2) d_n(3,discretization_Marc_FEM2DAMASK_node(n)) = 0.0_pReal - endif - enddo + if (nqncomp == 2) d_n(3,discretization_Marc_FEM2DAMASK_node(n)) = 0.0_pReal + end if + end do call discretization_Marc_UpdateNodeAndIpCoords(d_n) call materialpoint_results(int(inc),cptim) inc_written = int(inc) - endif + end if end subroutine uedinc diff --git a/src/Marc/discretization_Marc.f90 b/src/Marc/discretization_Marc.f90 index b3c412579..405339b9b 100644 --- a/src/Marc/discretization_Marc.f90 +++ b/src/Marc/discretization_Marc.f90 @@ -271,12 +271,12 @@ subroutine inputRead_fileFormat(fileFormat,fileContent) do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 2) cycle - if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'version') then + if (chunkPos(1) < 2) cycle + if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'version') then fileFormat = IO_intValue(fileContent(l),chunkPos,2) exit - endif - enddo + end if + end do end subroutine inputRead_fileFormat @@ -297,13 +297,13 @@ subroutine inputRead_tableStyles(initialcond,hypoelastic,fileContent) do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 6) cycle - if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'table') then + if (chunkPos(1) < 6) cycle + if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'table') then initialcond = IO_intValue(fileContent(l),chunkPos,4) hypoelastic = IO_intValue(fileContent(l),chunkPos,5) exit - endif - enddo + end if + end do end subroutine inputRead_tableStyles @@ -324,23 +324,23 @@ subroutine inputRead_matNumber(matNumber, & do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 1) cycle - if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'hypoelastic') then + if (chunkPos(1) < 1) cycle + if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'hypoelastic') then if (len_trim(fileContent(l+1))/=0) then chunkPos = IO_stringPos(fileContent(l+1)) data_blocks = IO_intValue(fileContent(l+1),chunkPos,1) else data_blocks = 1 - endif + end if allocate(matNumber(data_blocks), source = 0) do i = 0, data_blocks - 1 j = i*(2+tableStyle) + 1 chunkPos = IO_stringPos(fileContent(l+1+j)) matNumber(i+1) = IO_intValue(fileContent(l+1+j),chunkPos,1) - enddo + end do exit - endif - enddo + end if + end do end subroutine inputRead_matNumber @@ -362,14 +362,14 @@ subroutine inputRead_NnodesAndElements(nNodes,nElems,& do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 1) cycle + if (chunkPos(1) < 1) cycle if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'sizing') then nElems = IO_IntValue (fileContent(l),chunkPos,3) - elseif(IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'coordinates') then + elseif (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'coordinates') then chunkPos = IO_stringPos(fileContent(l+1)) nNodes = IO_IntValue (fileContent(l+1),chunkPos,2) - endif - enddo + end if + end do end subroutine inputRead_NnodesAndElements @@ -392,13 +392,13 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,& do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 2) cycle - if(IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'define' .and. & + if (chunkPos(1) < 2) cycle + if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'define' .and. & IO_lc(IO_StringValue(fileContent(l),chunkPos,2)) == 'element') then nElemSets = nElemSets + 1 chunkPos = IO_stringPos(fileContent(l+1)) - if(containsRange(fileContent(l+1),chunkPos)) then + if (containsRange(fileContent(l+1),chunkPos)) then elemInCurrentSet = 1 + abs( IO_intValue(fileContent(l+1),chunkPos,3) & -IO_intValue(fileContent(l+1),chunkPos,1)) else @@ -408,15 +408,15 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,& i = i + 1 chunkPos = IO_stringPos(fileContent(l+i)) elemInCurrentSet = elemInCurrentSet + chunkPos(1) - 1 ! add line's count when assuming 'c' - if(IO_lc(IO_stringValue(fileContent(l+i),chunkPos,chunkPos(1))) /= 'c') then ! line finished, read last value + if (IO_lc(IO_stringValue(fileContent(l+i),chunkPos,chunkPos(1))) /= 'c') then ! line finished, read last value elemInCurrentSet = elemInCurrentSet + 1 ! data ended exit - endif - enddo - endif + end if + end do + end if maxNelemInSet = max(maxNelemInSet, elemInCurrentSet) - endif - enddo + end if + end do end subroutine inputRead_NelemSets @@ -442,14 +442,14 @@ subroutine inputRead_mapElemSets(nameElemSet,mapElemSet,& do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 2) cycle - if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'define' .and. & + if (chunkPos(1) < 2) cycle + if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'define' .and. & IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'element') then elemSet = elemSet+1 nameElemSet(elemSet) = trim(IO_stringValue(fileContent(l),chunkPos,4)) mapElemSet(:,elemSet) = continuousIntValues(fileContent(l+1:),size(mapElemSet,1)-1,nameElemSet,mapElemSet,size(nameElemSet)) - endif - enddo + end if + end do end subroutine inputRead_mapElemSets @@ -473,8 +473,8 @@ subroutine inputRead_mapElems(FEM2DAMASK, & do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 1) cycle - if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then + if (chunkPos(1) < 1) cycle + if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then j = 0 do i = 1,nElems chunkPos = IO_stringPos(fileContent(l+1+i+j)) @@ -484,17 +484,17 @@ subroutine inputRead_mapElems(FEM2DAMASK, & j = j + 1 chunkPos = IO_stringPos(fileContent(l+1+i+j)) nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) - enddo - enddo + end do + end do exit - endif - enddo + end if + end do call math_sort(map_unsorted) allocate(FEM2DAMASK(minval(map_unsorted(1,:)):maxval(map_unsorted(1,:))),source=-1) do i = 1, nElems FEM2DAMASK(map_unsorted(1,i)) = map_unsorted(2,i) - enddo + end do end subroutine inputRead_mapElems @@ -517,21 +517,21 @@ subroutine inputRead_mapNodes(FEM2DAMASK, & do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 1) cycle - if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then + if (chunkPos(1) < 1) cycle + if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then chunkPos = [1,1,10] do i = 1,nNodes map_unsorted(:,i) = [IO_intValue(fileContent(l+1+i),chunkPos,1),i] - enddo + end do exit - endif - enddo + end if + end do call math_sort(map_unsorted) allocate(FEM2DAMASK(minval(map_unsorted(1,:)):maxval(map_unsorted(1,:))),source=-1) do i = 1, nNodes FEM2DAMASK(map_unsorted(1,i)) = map_unsorted(2,i) - enddo + end do end subroutine inputRead_mapNodes @@ -554,16 +554,16 @@ subroutine inputRead_elemNodes(nodes, & do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 1) cycle - if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then + if (chunkPos(1) < 1) cycle + if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then chunkPos = [4,1,10,11,30,31,50,51,70] do i=1,nNode m = discretization_Marc_FEM2DAMASK_node(IO_intValue(fileContent(l+1+i),chunkPos,1)) nodes(1:3,m) = [(mesh_unitlength * IO_floatValue(fileContent(l+1+i),chunkPos,j+1),j=1,3)] - enddo + end do exit - endif - enddo + end if + end do end subroutine inputRead_elemNodes @@ -585,8 +585,8 @@ subroutine inputRead_elemType(elem, & t = -1 do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 1) cycle - if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then + if (chunkPos(1) < 1) cycle + if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then j = 0 do i=1,nElem ! read all elements chunkPos = IO_stringPos(fileContent(l+1+i+j)) @@ -596,17 +596,17 @@ subroutine inputRead_elemType(elem, & else t_ = mapElemtype(IO_stringValue(fileContent(l+1+i+j),chunkPos,2)) if (t /= t_) call IO_error(191,IO_stringValue(fileContent(l+1+i+j),chunkPos,2),label1='type',ID1=t) - endif + end if remainingChunks = elem%nNodes - (chunkPos(1) - 2) do while(remainingChunks > 0) j = j + 1 chunkPos = IO_stringPos(fileContent(l+1+i+j)) remainingChunks = remainingChunks - chunkPos(1) - enddo - enddo + end do + end do exit - endif - enddo + end if + end do contains @@ -676,8 +676,8 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent) do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 1) cycle - if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then + if (chunkPos(1) < 1) cycle + if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then j = 0 do i = 1,nElem chunkPos = IO_stringPos(fileContent(l+1+i+j)) @@ -686,7 +686,7 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent) do k = 1,chunkPos(1)-2 inputRead_connectivityElem(k,e) = & discretization_Marc_FEM2DAMASK_node(IO_IntValue(fileContent(l+1+i+j),chunkPos,k+2)) - enddo + end do nNodesAlreadyRead = chunkPos(1) - 2 do while(nNodesAlreadyRead < nNodes) ! read on if not all nodes in one line j = j + 1 @@ -694,14 +694,14 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent) do k = 1,chunkPos(1) inputRead_connectivityElem(nNodesAlreadyRead+k,e) = & discretization_Marc_FEM2DAMASK_node(IO_IntValue(fileContent(l+1+i+j),chunkPos,k)) - enddo + end do nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) - enddo - endif - enddo + end do + end if + end do exit - endif - enddo + end if + end do end function inputRead_connectivityElem @@ -733,8 +733,8 @@ subroutine inputRead_material(materialAt,& do l = 1, size(fileContent) chunkPos = IO_stringPos(fileContent(l)) - if(chunkPos(1) < 2) cycle - if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'initial' .and. & + if (chunkPos(1) < 2) cycle + if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'initial' .and. & IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'state') then k = merge(2,1,initialcondTableStyle == 2) chunkPos = IO_stringPos(fileContent(l+k)) @@ -749,14 +749,14 @@ subroutine inputRead_material(materialAt,& do i = 1,contInts(1) e = discretization_Marc_FEM2DAMASK_elem(contInts(1+i)) materialAt(e) = ID + 1 - enddo + end do if (initialcondTableStyle == 0) m = m + 1 - enddo - endif - endif - enddo + end do + end if + end if + end do - if(any(materialAt < 1)) call IO_error(180) + if (any(materialAt < 1)) call IO_error(180) end subroutine inputRead_material @@ -791,9 +791,9 @@ pure subroutine buildCells(connectivity,definition, & do c = 1, elem%NcellNodes realNode: if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == 1) then where(connectivity(:,:,e) == -c) connectivity(:,:,e) = connectivity_elem(c,e) - endif realNode - enddo - enddo + end if realNode + end do + end do nCellNode = maxval(connectivity_elem) @@ -806,7 +806,7 @@ pure subroutine buildCells(connectivity,definition, & do c = 1, elem%NcellNodes if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == nParentNodes) & candidates_local = [candidates_local,c] - enddo + end do s = size(candidates_local) if (allocated(candidates_global)) deallocate(candidates_global) @@ -822,8 +822,8 @@ pure subroutine buildCells(connectivity,definition, & if (elem%cellNodeParentNodeWeights(j,c) /= 0) then ! real node 'j' partly defines cell node 'c' p = p + 1 parentsAndWeights(p,1:2) = [connectivity_elem(j,e),elem%cellNodeParentNodeWeights(j,c)] - endif - enddo + end if + end do ! store (and order) real node IDs and their weights together with the element number and local ID do p = 1, nParentNodes m = maxloc(parentsAndWeights(:,1),1) @@ -833,9 +833,9 @@ pure subroutine buildCells(connectivity,definition, & candidates_global(nParentNodes*2+1:nParentNodes*2+2,candidateID) = [e,c] parentsAndWeights(m,1) = -huge(parentsAndWeights(m,1)) ! out of the competition - enddo - enddo - enddo + end do + end do + end do ! sort according to real node IDs + weight (from left to right) call math_sort(candidates_global,sortDim=1) ! sort according to first column @@ -847,13 +847,13 @@ pure subroutine buildCells(connectivity,definition, & do while (n+j<= size(candidates_local)*Nelem) if (candidates_global(p-1,n+j)/=candidates_global(p-1,n)) exit j = j + 1 - enddo + end do e = n+j-1 if (any(candidates_global(p,n:e)/=candidates_global(p,n))) & call math_sort(candidates_global(:,n:e),sortDim=p) n = e+1 - enddo - enddo + end do + end do i = uniqueRows(candidates_global(1:2*nParentNodes,:)) allocate(definition(nParentNodes-1)%parents(i,nParentNodes)) @@ -876,15 +876,15 @@ pure subroutine buildCells(connectivity,definition, & end where j = j+1 - enddo + end do nCellNode = nCellNode + 1 definition(nParentNodes-1)%parents(i,:) = parentsAndWeights(:,1) definition(nParentNodes-1)%weights(i,:) = parentsAndWeights(:,2) i = i + 1 n = n+j - enddo + end do - enddo + end do contains !------------------------------------------------------------------------------------------------ @@ -906,10 +906,10 @@ pure subroutine buildCells(connectivity,definition, & do while (r+d<= size(A,2)) if (any(A(:,r)/=A(:,r+d))) exit d = d+1 - enddo + end do u = u+1 r = r+d - enddo + end do end function uniqueRows @@ -939,10 +939,10 @@ pure function buildCellNodes(node_elem) buildCellNodes(:,n) = buildCellNodes(:,n) & + buildCellNodes(:,cellNodeDefinition(i)%parents(j,k)) & * real(cellNodeDefinition(i)%weights(j,k),pReal) - enddo + end do buildCellNodes(:,n) = buildCellNodes(:,n)/real(sum(cellNodeDefinition(i)%weights(j,:)),pReal) - enddo - enddo + end do + end do end function buildCellNodes @@ -970,9 +970,9 @@ pure function buildIPcoordinates(node_cell) do n = 1, size(connectivity_cell_reshaped,1) buildIPcoordinates(:,i) = buildIPcoordinates(:,i) & + node_cell(:,connectivity_cell_reshaped(n,i)) - enddo + end do buildIPcoordinates(:,i) = buildIPcoordinates(:,i)/real(size(connectivity_cell_reshaped,1),pReal) - enddo + end do end function buildIPcoordinates @@ -1031,8 +1031,8 @@ pure function IPvolume(elem,node) + dot_product((x7-x1), math_cross((x5-x0), (x7-x4)+(x3-x0))) IPvolume(i,e) = IPvolume(i,e)/12.0_pReal end select - enddo - enddo + end do + end do end function IPvolume @@ -1075,11 +1075,11 @@ pure function IPareaNormal(elem,nElem,node) IPareaNormal(1:3,f,i,e) = IPareaNormal(1:3,f,i,e) & + math_cross(nodePos(1:3,mod(n+0,m)+1) - nodePos(1:3,n), & nodePos(1:3,mod(n+1,m)+1) - nodePos(1:3,n)) * 0.5_pReal - enddo + end do end select - enddo - enddo - enddo + end do + end do + end do end function IPareaNormal @@ -1109,10 +1109,10 @@ function IPneighborhood(elem) do n = 1, size(face_unordered) face(n,c) = minval(face_unordered) face_unordered(minloc(face_unordered)) = huge(face_unordered) - enddo + end do face(n:n+3,c) = [e,i,f] - enddo - enddo; enddo + end do + end do; end do !-------------------------------------------------------------------------------------------------- ! sort face definitions @@ -1122,20 +1122,20 @@ function IPneighborhood(elem) e = 1 do while (e < size(face,2)) e = e + 1 - if(any(face(:c,s) /= face(:c,e))) then - if(e-1/=s) call math_sort(face(:,s:e-1),sortDim=c) + if (any(face(:c,s) /= face(:c,e))) then + if (e-1/=s) call math_sort(face(:,s:e-1),sortDim=c) s = e - endif - enddo - enddo + end if + end do + end do IPneighborhood = 0 do c=1, size(face,2) - 1 - if(all(face(:n-1,c) == face(:n-1,c+1))) then + if (all(face(:n-1,c) == face(:n-1,c+1))) then IPneighborhood(:,face(n+2,c+1),face(n+1,c+1),face(n+0,c+1)) = face(n:n+3,c+0) IPneighborhood(:,face(n+2,c+0),face(n+1,c+0),face(n+0,c+0)) = face(n:n+3,c+1) - endif - enddo + end if + end do end function IPneighborhood @@ -1171,29 +1171,29 @@ function continuousIntValues(fileContent,maxN,lookupName,lookupMap,lookupMaxN) if (IO_stringValue(fileContent(l),chunkPos,1) == lookupName(i)) then ! found matching name continuousIntValues = lookupMap(:,i) ! return resp. entity list exit - endif - enddo + end if + end do exit - elseif(containsRange(fileContent(l),chunkPos)) then + elseif (containsRange(fileContent(l),chunkPos)) then first = IO_intValue(fileContent(l),chunkPos,1) last = IO_intValue(fileContent(l),chunkPos,3) do i = first, last, sign(1,last-first) continuousIntValues(1) = continuousIntValues(1) + 1 continuousIntValues(1+continuousIntValues(1)) = i - enddo + end do exit else do i = 1,chunkPos(1)-1 ! interpret up to second to last value continuousIntValues(1) = continuousIntValues(1) + 1 continuousIntValues(1+continuousIntValues(1)) = IO_intValue(fileContent(l),chunkPos,i) - enddo + end do if ( IO_lc(IO_stringValue(fileContent(l),chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value continuousIntValues(1) = continuousIntValues(1) + 1 continuousIntValues(1+continuousIntValues(1)) = IO_intValue(fileContent(l),chunkPos,chunkPos(1)) exit - endif - endif - enddo + end if + end if + end do end function continuousIntValues @@ -1208,9 +1208,9 @@ logical function containsRange(str,chunkPos) containsRange = .False. - if(chunkPos(1) == 3) then - if(IO_lc(IO_stringValue(str,chunkPos,2)) == 'to') containsRange = .True. - endif + if (chunkPos(1) == 3) then + if (IO_lc(IO_stringValue(str,chunkPos,2)) == 'to') containsRange = .True. + end if end function containsRange diff --git a/src/Marc/include/concom2022.3 b/src/Marc/include/concom2022.3 new file mode 100644 index 000000000..2d4deaa34 --- /dev/null +++ b/src/Marc/include/concom2022.3 @@ -0,0 +1,466 @@ +! common block definition file taken from respective MSC.Marc release and reformated to free format +!*********************************************************************** +! +! File: concom.cmn +! +! MSC.Marc include file +! +integer & + iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,& + ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,& + ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,& + ipoist, irpflo, ismall, ismalt, isoil, ispect, ispnow, istore, iswep, ithcrp,& + itherm, iupblg, iupdat, jacflg, jel, jparks, largst, lfond, loadup, loaduq,& + lodcor, lovl, lsub, magnet, ncycle, newtnt, newton, noshr, linear, ivscpl,& + icrpim, iradrt, ipshft, itshr, iangin, iupmdr, iconjf, jincfl, jpermg, jhour,& + isolvr, jritz, jtable, jshell, jdoubl, jform, jcentr, imini, kautth, iautof,& + ibukty, iassum, icnstd, icnstt, kmakmas, imethvp, iradrte, iradrtp, iupdate, iupdatp,& + ncycnt, marmen , idynme, ihavca, ispf, kmini, imixex, largtt, kdoela, iautofg,& + ipshftp, idntrc, ipore, jtablm, jtablc, isnecma, itrnspo, imsdif, jtrnspo, mcnear,& + imech, imecht, ielcmat, ielectt, magnett, imsdift, noplas, jtabls, jactch, jtablth,& + kgmsto , jpzo, ifricsh, iremkin, iremfor, ishearp, jspf, machining, jlshell, icompsol,& + iupblgfo, jcondir, nstcrp, nactive, ipassref, nstspnt, ibeart, icheckmpc, noline, icuring,& + ishrink, ioffsflg, isetoff, ioffsetm,iharmt, inc_incdat, iautspc, ibrake, icbush, istream_input,& + iprsinp, ivlsinp, ifirst_time,ipin_m, jgnstr_glb, imarc_return,iqvcinp, nqvceid, istpnx, imicro1,& + iaxisymm, jbreakglue,iglstif, jfastasm,iwear, iwearcf, imixmeth, ielcmadyn, idinout, igena_meth,& + magf_meth, non_assumed, iredoboudry, ioffsz0,icomplt, mesh_dual, iactrp, mgnewton, iusedens,igsigd0,& + iaem, icosim, inodels, nlharm, iampini, iphasetr, inonlcl, inonlct, iforminp,ispecerror,& + icsprg, imol, imolt, idatafit,iharmpar, inclcase, imultifreq,init_elas, ifatig, iftgmat,& + nchybrid, ibuckle, iexpande +dimension :: ideva(60) +integer num_concom +parameter(num_concom=263) +common/marc_concom/& + iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,& + ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,& + ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,& + ipoist, irpflo, ismall, ismalt, isoil, ispect, ispnow, istore, iswep, ithcrp,& + itherm, iupblg, iupdat, jacflg, jel, jparks, largst, lfond, loadup, loaduq,& + lodcor, lovl, lsub, magnet, ncycle, newtnt, newton, noshr, linear, ivscpl,& + icrpim, iradrt, ipshft, itshr, iangin, iupmdr, iconjf, jincfl, jpermg, jhour,& + isolvr, jritz, jtable, jshell, jdoubl, jform, jcentr, imini, kautth, iautof,& + ibukty, iassum, icnstd, icnstt, kmakmas, imethvp, iradrte, iradrtp, iupdate, iupdatp,& + ncycnt, marmen, idynme, ihavca, ispf, kmini, imixex, largtt, kdoela, iautofg,& + ipshftp, idntrc, ipore, jtablm, jtablc, isnecma, itrnspo, imsdif, jtrnspo, mcnear,& + imech, imecht, ielcmat, ielectt, magnett, imsdift, noplas, jtabls, jactch, jtablth,& + kgmsto , jpzo, ifricsh, iremkin, iremfor, ishearp, jspf, machining, jlshell, icompsol,& + iupblgfo, jcondir, nstcrp, nactive, ipassref, nstspnt, ibeart, icheckmpc, noline, icuring,& + ishrink, ioffsflg, isetoff, ioffsetm,iharmt, inc_incdat, iautspc, ibrake, icbush, istream_input,& + iprsinp, ivlsinp, ifirst_time,ipin_m, jgnstr_glb, imarc_return,iqvcinp, nqvceid, istpnx, imicro1,& + iaxisymm, jbreakglue,iglstif, jfastasm,iwear, iwearcf, imixmeth, ielcmadyn, idinout, igena_meth,& + magf_meth, non_assumed, iredoboudry, ioffsz0,icomplt, mesh_dual, iactrp, mgnewton, iusedens,igsigd0,& + iaem, icosim, inodels, nlharm, iampini, iphasetr, inonlcl, inonlct, iforminp,ispecerror,& + icsprg, imol, imolt, idatafit,iharmpar, inclcase, imultifreq,init_elas, ifatig, iftgmat,& + nchybrid, ibuckle, iexpande +! +! comments of variables: +! +! iacous Control flag for acoustic analysis. Input data. +! iacous=1 modal acoustic analysis. +! iacous=2 harmonic acoustic-structural analysis. +! iasmbl Control flag to indicate that operator matrix should be +! recalculated. +! iautth Control flag for AUTO THERM option. +! ibear Control flag for bearing analysis. Input data. +! icompl Control variable to indicate that a complex analysis is +! being performed. Either a Harmonic analysis with damping, +! or a harmonic electro-magnetic analysis. Input data. +! iconj Flag for EBE conjugate gradient solver (=solver 1, retired) +! Also used for VKI iterative solver. +! icreep Control flag for creep analysis. Input data. +! ideva(60) - debug print out flag +! 1 print element stiffness matrices, mass matrix +! 2 output matrices used in tying +! 3 force the solution of a nonpositive definite matrix +! 4 print info of connections to each node +! 5 info of gap convergence, internal heat generated, contact +! touching and separation +! 6 nodal value array during rezoning +! 7 tying info in CONRAD GAP option, fluid element numbers in +! CHANNEL option +! 8 output incremental displacements in local coord. system +! 9 latent heat output +! 10 stress-strain in local coord. system +! 11 additional info on interlaminar stress +! 12 output right hand side and solution vector +! 13 info of CPU resources used and memory available on NT +! 14 info of mesh adaption process, 2D outline information +! info of penetration checking for remeshing +! save .fem files after afmesh3d meshing +! print local adaptivity info +! 15 surface energy balance flag +! 16 print info regarding pyrolysis +! 17 print info of "streamline topology" +! 18 print mesh data changes after remeshing +! 19 print material flow stress data read in from *.mat file +! if unit flag is on, print out flow stress after conversion +! 20 print information on table input +! 21 print out information regarding kinematic boundary conditions +! 22 print out information regarding dist loads, point loads, film +! and foundations +! 23 print out information about automatic domain decomposition +! 24 print out iteration information in SuperForm status report file +! 25 print out information for ablation +! 26 print out information for films - Table input +! 27 print out the tying forces +! 28 print out for CASI solver, convection, +! 29 DDM single file debug printout +! 30 print out cavity debug info +! 31 print out welding related info +! 32 prints categorized DDM memory usage +! 33 print out the cutting info regarding machining feature +! 34 print out the list of quantities which can be defined via a table +! and for each quantity the supported independent variables +! 35 print out detailed coupling region info +! 36 print out solver debug info level 1 (Least Detailed) +! 37 print out solver debug info level 1 (Medium Detailed) +! 38 print out solver debug info level 1 (Very Detailed) +! 39 print detailed memory allocation info +! 40 print out marc-adams debug info +! 41 output rezone mapping post file for debugging +! 42 output post file after calling oprofos() for debugging +! 43 debug printout for vcct +! 44 debug printout for progressive failure +! 45 print out automatically generated midside node coordinates (arecrd) +! 46 print out message about routine and location, where the ibort is raised (ibort_inc) +! 47 print out summary message of element variables on a +! group-basis after all the automatic changes have been +! made (em_ellibp) +! 48 Automatically generate check results based on max and min vals. +! These vals are stored in the checkr file, which is inserted +! into the *dat file by the generate_check_results script from /marc/tools +! 49 Automatically generate check results based on the real calculated values +! at the sppecified check result locations. +! These vals are stored in the checkr file, which is inserted +! into the *dat file by the update_check_results script from /marc/tools +! 50 generate a file containing the resistance or capacity matrix; +! this file can be used to compare results with a reference file +! 51 print out detailed information for segment-to-segment contact +! 52 print out detailed relative displacement information +! for uniaxial sliding contact +! 53 print out detailed sliding direction information for +! uniaxial sliding contact +! 54 print out detailed information for edges attached to a curve +! 55 print information related to viscoelasticity calculations +! 56 print out detailed information for element coloring for multithreading +! 57 print out extra overheads due to multi-threading. +! These overhead includes (i) time and (ii) memory. +! The memory report will be summed over all the children. +! 58 debug output for ELSTO usage +! 59 print out contact body forces and nodes in contact +! +! idyn Control flag for dynamics. Input data. +! 1 = eigenvalue extraction and / or modal superposition +! 2 = Newmark Beta and Single Step Houbolt (ssh with idynme=1) +! 3 = Houbolt +! 4 = Central difference +! 5 = Newer central difference +! idynt Copy of idyn at begining of increment +! ielas Control flag for ELASTIC analysis. Input data. +! Set by user or automatically turned on by Fourier option. +! Implies that each load case is treated separately. +! In Adaptive meshing analysis , forces re-analysis until +! convergence obtained. +! Also seriously misused to indicate no convergence. +! = 1 elastic option with fourier analysis +! = 2 elastic option without fourier analysis +! =-1 no convergence in recycles or max # increments reached +! Set to 1 if ELASTIC or SUBSTRUC parameter cards are used, +! or if fourier option is used. +! Then set to 2 if not fourier analysis. +! ielcma Control flag for electromagnetic analysis. Input data. +! ielcma = 1 Harmonic formulation +! ielcma = 2 Transient formulation +! ielect Control flag for electrostatic option. Input data. +! iform Control flag indicating that contact will be performed. +! ifour Control flag for Fourier analysis. +! 0 = Odd and even terms. +! 1 = symmetric (cosine) terms +! 2 = antisymmetric (sine) terms. +! iharm Control flag to indicate that a harmonic analysis will +! be performed. May change between passes. +! ihcps Control flag for coupled thermal - stress analysis. +! iheat Control flag for heat transfer analysis. Input data. +! iheatt Permanent control flag for heat transfer analysis. +! Note in coupled analysis iheatt will remain as one, +! but iheat will be zero in stress pass. +! ihresp Control flag to indicate to perform a harmonic subincrement. +! ijoule Control flag for Joule heating. +! ilem Control flag to determin which vector is to be transformed. +! Control flag to see where one is: +! ilem = 1 - elem.f +! ilem = 2 - initst.f +! ilem = 3 - pressr.f +! ilem = 3 - fstif.f +! ilem = 4 - jflux.f +! ilem = 4 - strass.f +! ilem = 5 - mass.f +! ilem = 5 - osolty.f +! ilnmom Control flag for soil - pore pressure calculation. Input data. +! ilnmom = 0 - perform only pore pressure calculation. +! = 1 - couples pore pressure - displacement analysis +! iloren Control flag for DeLorenzi J-Integral evaluation. Input data. +! inc Increment number. +! incext Control flag indicating that currently working on a +! subincrement. +! Could be due to harmonics , damping component (bearing), +! stiffness component (bearing), auto therm creep or +! old viscoplaticity +! incsub Sub-increment number. +! inonlcl control flag for nonlocal pass +! inonlct permanent control flag for nonlocal pass +! ipass Control flag for which part of coupled analysis. +! ipass = -1 - reset to base values +! ipass = 0 - do nothing +! ipass = 1 - stress part +! ipass = 2 - heat transfer part +! 3 - fluid pass +! 4 - joule heating pass +! 5 - pore pressure pass +! 6 - electrostatic pass +! 7 - magnetostatic pass +! 8 - electromagnetic pass +! 9 - diffusion pass +! ipass = 10 - nonlocal part +! iplres Flag indicating that either second matrix is stored. +! dynamic analysis - mass matrix +! heat transfer - specific heat matrix +! buckle - initial stress stiffness +! ipois Control flag indicating Poisson type analysis +! ipois = 1 for heat transfer +! = 1 for heat transfer part of coupled +! = 1 for bearing +! = 1 for electrostatic +! = 1 for magnetostatic +! = 1 for nonlocal part +! ipoist Permanent copy of ipois. In coupled analysis , ipois = 0 +! in stress portion, yet ipoist will still =1. +! irpflo global flag for rigid plastic flow analysis +! = 1 eularian formulation +! = 2 regular formulation; rigid material present in the analysis +! ismall control flag to indicate small displacement analysis. input data. +! ismall = 0 - large disp included. +! ismall = 1 - small displacement. +! the flag is changing between passes. +! ismalt permanent copy of ismall . in heat transfer portion of +! coupled analysis ismall =0 , but ismalt remains the same. +! isoil control flag indicating that soil / pore pressure +! calculation . input data. +! ispect control flag for response spectrum calculation. input data. +! ispnow control flag to indicate to perform a spectrum response +! calculation now. +! istore store stresses flag. +! istore = 0 in elem.f and if first pass of creep +! convergence checking in ogetst.f +! or harmonic analysis or thruc.f if not +! converged. +! iswep control flag for eigenvalue analysis. +! iswep=1 - go do extraction process +! ithcrp control flag for auto therm creep option. input data. +! itherm control flag for either temperature dependent material +! properties and/or thermal loads. +! iupblg control flag for follower force option. input data. +! iupdat control flag for update lagrange option for current element. +! jacflg control flag for lanczos iteration method. input data. +! jel control flag indicating that total load applied in +! increment, ignore previous solution. +! jel = 1 in increment 0 +! = 1 if elastic or fourier +! = 1 in subincrements with elastic and adaptive +! jparks control flag for j integral by parks method. input data. +! largst control flag for finite strain plasticity. input data. +! lfond control variable that indicates if doing elastic +! foundation or film calculation. influences whether +! this is volumetric or surface integration. +! loadup control flag that indicates that nonlinearity occurred +! during previous increment. +! loaduq control flag that indicates that nonlinearity occurred. +! lodcor control flag for switching on the residual load correction. +! notice in input stage lodcor=0 means no loadcor, +! after omarc lodcor=1 means no loadcor +! lovl control flag for determining which "overlay" is to +! be called from ellib. +! lovl = 1 omarc +! = 2 oaread +! = 3 opress +! = 4 oasemb +! = 5 osolty +! = 6 ogetst +! = 7 oscinc +! = 8 odynam +! = 9 opmesh +! = 10 omesh2 +! = 11 osetz +! = 12 oass +! = 13 oincdt +! = 14 oasmas +! = 15 ofluas +! = 16 ofluso +! = 17 oshtra +! = 18 ocass +! = 19 osoltc +! = 20 orezon +! = 21 otest +! = 22 oeigen +! lsub control variable to determine which part of element +! assembly function is being done. +! lsub = 1 - no longer used +! = 2 - beta* +! = 3 - cons* +! = 4 - ldef* +! = 5 - posw* +! = 6 - theta* +! = 7 - tmarx* +! = 8 - geom* +! magnet control flag for magnetostatic analysis. input data. +! ncycle cycle number. accumulated in osolty.f +! note first time through oasemb.f , ncycle = 0. +! newtnt control flag for permanent copy of newton. +! newton iteration type. input data. +! newton : = 1 full newton raphson +! 2 modified newton raphson +! 3 newton raphson with strain correct. +! 4 direct substitution +! 5 direct substitution followed by n.r. +! 6 direct substitution with line search +! 7 full newton raphson with secant initial stress +! 8 secant method +! 9 full newton raphson with line search +! noshr control flag for calculation interlaminar shears for +! elements 22,45, and 75. input data. +!ees +! +! jactch = 1 or 2 if elements are activated or deactivated +! = 3 if elements are adaptively remeshed or rezoned +! = 0 normally / reset to 0 when assembly is done +! ifricsh = 0 call to fricsh in otest not needed +! = 1 call to fricsh (nodal friction) in otest needed +! iremkin = 0 remove deactivated kinematic boundary conditions +! immediately - only in new input format (this is default) +! = 1 remove deactivated kinematic boundary conditions +! gradually - only in new input format +! iremfor = 0 remove force boundary conditions immediately - +! only in new input format (this is default) +! = 1 remove force boundary conditions gradually - +! only in new input format (this is default) +! ishearp set to 1 if shear panel elements are present in the model +! +! jspf = 0 not in spf loadcase +! > 0 in spf loadcase (jspf=1 during first increment) +! machining = 1 if the metal cutting feature is used, for memory allocation purpose +! = 0 (default) if no metal cutting feature required +! +! jlshell = 1 if there is a shell element in the mesh +! icompsol = 1 if there is a composite solid element in the mesh +! iupblgfo = 1 if follower force for point loads +! jcondir = 1 if contact priority option is used +! nstcrp = 0 (default) steady state creep flag (undocumented feature. +! if not 0, turns off special ncycle = 0 code in radial.f) +! nactive = number of active passes, if =1 then it's not a coupled analysis +! ipassref = reference ipass, if not in a multiphysics pass ipass=ipassref +! icheckmpc = value of mpc-check parameter option +! noline = set to 1 in osolty if no line seacrh should be done in ogetst +! icuring = set to 1 if the curing is included for the heat transfer analysis. +! ishrink = set to 1 if shrinkage strain is included for mechancial analysis. +! ioffsflg = 1 for small displacement beam/shell offsets +! = 2 for large displacement beam/shell offsets +! isetoff = 0 - do not apply beam/shell offsets +! = 1 - apply beam/shell offsets +! ioffsetm = min. value of offset flag +! iharmt = 1 global flag if a coupled analysis contains an harmonic pass +! inc_incdat = flag to record increment number of a new loadcase in incdat.f +! iautspc = flag for AutoSPC option +! ibrake = brake squeal in this increment +! icbush = set to 1 if cbush elements present in model +! istream_input = set to 1 for streaming input calling Marc as library +! iprsinp = set to 1 if pressure input, introduced so other variables +! such as h could be a function of pressure +! ivlsinp = set to 1 if velocity input, introduced so other variables +! such as h could be a function of velocity +! ipin_m = # of beam element with PIN flag +! jgnstr_glb = global control over pre or fast integrated composite shells +! imarc_return = Marc return flag for streaming input control +! iqvcimp = if non-zero, then the number of QVECT boundary conditions +! nqvceid = number of QVECT boundary conditions, where emisivity/absorbtion id entered +! istpnx = 1 if to stop at end of increment +! imicro1 = 1 if micro1 interface is used +! iaxisymm = set to 1 if axisymmetric analysis +! jbreakglue = set to 1 if breaking glued option is used +! iglstif = 1 if ddm and global stiffness matrix formed (sgi solver 6 or solver9) +! jfastasm = 1 do fast assembly using SuperForm code +! iwear = set to 1 if wear model, set to 2 if wear model and coordinates updated +! iwearcf = set to 1 to store nodal coefficient of friction for wear calculation +! imixmeth = set=1 then use nonlinear mixture material - allocate memory +! ielcmadyn = flag for magnetodynamics +! 0 - electromagnetics using newmark beta +! 1 - transient magnetics using backward euler +! idinout = flag to control if inside out elements should be deactivated +! igena_meth = 0 - generalized alpha parameters depend on whether or not contact +! is flagged (dynamic,7) +! 10 - generalized alpha parameters are optimized for a contact +! analysis (dynamic,8) +! 11 - generalized alpha parameters are optimized for an analysis +! without contact (dynamic,8) +! magf_meth = - Method to compute force in magnetostatic - structural +! = 1 - Virtual work method based on finite difference for the force computation +! = 2 - Maxwell stress tensor +! = 3 - Virtual work method based on local derivative for the force computation +! non_assumed = 1 no assumed strain formulation (forced) +! iredoboudry set to 1 if contact boundary needs to be recalculated +! ioffsz0 = 1 if composite are used with reference position.ne.0 +! icomplt = 1 global flag if a coupled analysis contains an complex pass +! mesh_dual = 1 two independent meshes are used in magnetodynamic/thermal/structural +! one for magnetodynamic and the other for the remaining passes +! iactrp = 1 in an analysis with global remeshing, include inactive +! rigid bodies on post file +! mgnewton = 1 Use full Newton Raphson iteration for magnetostatic pass +! +! iusedens > 0 if mass density is used in the analysis (dynamics, mass dependent loading) +! igsigd0 = 1 set varselem(igsigd) to zero in next oasemb +! iaem = 1 if marc is called from aem (0 - off - default) +! icosim = 1 if marc is used in co-simulation analysis with ADAMS using the CosimEngine +! = 2 if marc is used in co-simulation analysis with ADAMS using the ACSI interface +! = 3 if marc is used in co-simulation analysis with scFLOW using the CosimEngine +! = 4 if marc is used in co-simulation analysis with scFLOW and ADAMS using the CosimEngine +! inodels = 1 nodal integration elements 239/240/241 present +! nlharm = 0 harmonic subincrements are linear +! = 1 harmonic subincrements are nonlinear +! iampini = 0 amplitude of previous harmonic subinc is initial estimate (default) +! = 1 zero amplitude is initial estimate +! iphasetr = 1 phase transformation material model is used +! iforminp flag indicating that contact is switched on via the CONTACT +! option in the input file (as opposed to the case that contact +! is switched on internally due to cyclic symmetry or model +! section creation) +! ispecerror = a+10*b (only for spectrum response analysis with missing mass option) +! a=0 or a=1 (modal shape with non-zero shift) +! b=0 or b=1 (recover with new assembly of stiffness matrix) +! icsprg = set to 1 if spring elements present in model +! imol Control flag for molecualr diffusion pass +! imolt Permanent control flag for molecualr diffusion pass +! Note in coupled analysis imolt will remain as one, +! but imol will be zero in stress pass or thermal pass. +! idatafit = run Marc to fit parameters +! iharmpar = 1 if harmonic parameter option is used +! inclcase load case increment use for cyclic plasticity data fitting +! imultifreq flag to indicate how many harmonic magnetodynamic passes are computed in coupled +! magnetodynamic/thermal(/structural) analyses. +! 0 or 1 one pass 2 two passes 3 or more is not supported +! init_elas use elastic stress-strain law as the material tangent for +! the first cycle of an increment +! ifatig packed integer telling which fatigue mode is active +! 1 = elastomer +! 10 = stress-life +! 100 = strain-life +! = 2 strain-life fatigue +! iftgmat = 0 no fatigue material properties in the dat file +! = 1 fatigue material properties in the dat file +! nchybrid cycle count used for hybrid contact; meant to force an extra iteration +! if the overlap for a node in hybrid contact is too large +! ibuckle buckle parameter option is active +! iexpande set to 1 if expanded elements (248, 249, 250 or 251) are +! present, 0 otherwise +! +!*********************************************************************** +!$omp threadprivate(/marc_concom/) +!! diff --git a/src/Marc/include/creeps2022.3 b/src/Marc/include/creeps2022.3 new file mode 100644 index 000000000..b35d2b6bf --- /dev/null +++ b/src/Marc/include/creeps2022.3 @@ -0,0 +1,73 @@ +! common block definition file taken from respective MSC.Marc release and reformated to free format +!*********************************************************************** +! +! File: creeps.cmn +! +! MSC.Marc include file +! +real(pReal) cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b +integer icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,& + icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa +real(pReal) time_beg_lcase,time_beg_inc,fractol,time_beg_pst +real(pReal) fraction_donn,timinc_ol2 +! +integer num_creepsr,num_creepsi,num_creeps2r,ncrp_arry +parameter(num_creepsr=7) +parameter(num_creepsi=17) +parameter(num_creeps2r=6) +parameter(ncrp_arry=7) +common/marc_creeps/cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b,icfte,icfst,& + icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa +common/marc_creeps2/time_beg_lcase,time_beg_inc,fractol,time_beg_pst,fraction_donn,timinc_ol2 +! +! cptim Total time at begining of increment. +! timinc Incremental time for this step. +! icfte Local copy number of slopes of creep strain rate function +! versus temperature. Is -1 if exponent law used. +! icfst Local copy number of slopes of creep strain rate function +! versus equivalent stress. Is -1 if exponent law used. +! icfeq Local copy number of slopes of creep strain rate function +! versus equivalent strain. Is -1 if exponent law used. +! icftm Local copy number of slopes of creep strain rate function +! versus time. Is -1 if exponent law used. +! icetem Element number that needs to be checked for creep convergence +! or, if negative, the number of elements that need to +! be checked. In the latter case the elements to check +! are stored in ielcp. +! mcreep Maximum nuber of iterations for explicit creep. +! jcreep Counter of number of iterations for explicit creep +! procedure. jcreep must be .le. mcreep +! icpa(1-6) Pointer to constants in creep strain rate expression. +! icftmp Pointer to temperature dependent creep strain rate data. +! icfstr Pointer to equivalent stress dependent creep strain rate data. +! icfqcp Pointer to equivalent creep strain dependent creep strain +! rate data. +! icfcpm Pointer to equivalent creep strain rate dependent +! creep strain rate data. +! icrppr Permanent copy of icreep +! icrcha Control flag for creep convergence checking , if set to +! 1 then testing on absolute change in stress and creep +! strain, not relative testing. Input data. +! icpb(1-4) Pointer to storage of material id cross reference numbers. +! iicpmt creep law type ID +! =1 - power law +! =2 - solder +! =3 - steady-creep +! =4 - hyperbolic steady-creep +! iicpa Pointer to table IDs for constants in creep strain rate +! expression +! +! +! time_beg_lcase time at the beginning of the current load case +! time_beg_inc time at the beginning of the current increment +! fractol fraction of loadcase or increment time when we +! consider it to be finished +! time_beg_pst time corresponding to first increment to be +! read in from thermal post file for auto step +! +! timinc_old Time step of the previous increment +! +!*********************************************************************** +!!$omp threadprivate(/marc_creeps/) +!!$omp threadprivate(/marc_creeps2/) +!! diff --git a/src/Marc/materialpoint_Marc.f90 b/src/Marc/materialpoint_Marc.f90 index 03d6025b6..2b910217d 100644 --- a/src/Marc/materialpoint_Marc.f90 +++ b/src/Marc/materialpoint_Marc.f90 @@ -15,6 +15,7 @@ module materialpoint_Marc use math use rotations use polynomials + use tables use lattice use material use phase @@ -72,26 +73,27 @@ contains !-------------------------------------------------------------------------------------------------- !> @brief Initialize all modules. !-------------------------------------------------------------------------------------------------- -subroutine materialpoint_initAll +subroutine materialpoint_initAll() - call DAMASK_interface_init - call prec_init - call IO_init - call YAML_types_init - call YAML_parse_init - call HDF5_utilities_init + call DAMASK_interface_init() + call prec_init() + call IO_init() + call YAML_types_init() + call YAML_parse_init() + call HDF5_utilities_init() call results_init(.false.) - call config_init - call math_init - call rotations_init - call polynomials_init - call lattice_init - call discretization_Marc_init + call config_init() + call math_init() + call rotations_init() + call polynomials_init() + call tables_init() + call lattice_init() + call discretization_Marc_init() call material_init(.false.) - call phase_init - call homogenization_init - call materialpoint_init - call config_deallocate + call phase_init() + call homogenization_init() + call materialpoint_init() + call config_deallocate() end subroutine materialpoint_initAll @@ -99,7 +101,7 @@ end subroutine materialpoint_initAll !-------------------------------------------------------------------------------------------------- !> @brief allocate the arrays defined in module materialpoint and initialize them !-------------------------------------------------------------------------------------------------- -subroutine materialpoint_init +subroutine materialpoint_init() type(tList), pointer :: & debug_materialpoint @@ -121,12 +123,12 @@ subroutine materialpoint_init debugmaterialpoint%element = config_debug%get_asInt('element',defaultVal = 1) debugmaterialpoint%ip = config_debug%get_asInt('integrationpoint',defaultVal = 1) - if(debugmaterialpoint%basic) then + if (debugmaterialpoint%basic) then print'(a32,1x,6(i8,1x))', 'materialpoint_cs: ', shape(materialpoint_cs) print'(a32,1x,6(i8,1x))', 'materialpoint_dcsdE: ', shape(materialpoint_dcsdE) print'(a32,1x,6(i8,1x),/)', 'materialpoint_dcsdE_knownGood: ', shape(materialpoint_dcsdE_knownGood) flush(IO_STDOUT) - endif + end if end subroutine materialpoint_init @@ -171,7 +173,7 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip, if (terminallyIll) & print'(a,/)', '# --- terminallyIll --- #' print'(a,/)', '#############################################'; flush (6) - endif + end if if (iand(mode, materialpoint_BACKUPJACOBIAN) /= 0) & materialpoint_dcsde_knownGood = materialpoint_dcsde @@ -220,15 +222,15 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip, - math_delta(j,l) * homogenization_F(i,m,ce) * homogenization_P(k,m,ce) & + 0.5_pReal * ( Kirchhoff(j,l)*math_delta(i,k) + Kirchhoff(i,k)*math_delta(j,l) & + Kirchhoff(j,k)*math_delta(i,l) + Kirchhoff(i,l)*math_delta(j,k)) - enddo; enddo; enddo; enddo; enddo; enddo + end do; end do; end do; end do; end do; end do forall(i=1:3, j=1:3,k=1:3,l=1:3) & H_sym(i,j,k,l) = 0.25_pReal * (H(i,j,k,l) + H(j,i,k,l) + H(i,j,l,k) + H(j,i,l,k)) materialpoint_dcsde(1:6,1:6,ip,elCP) = math_sym3333to66(J_inverse * H_sym,weighted=.false.) - endif terminalIllness - endif validCalculation + end if terminalIllness + end if validCalculation if (debugmaterialpoint%extensive & .and. ((debugmaterialpoint%element == elCP .and. debugmaterialpoint%ip == ip) .or. .not. debugmaterialpoint%selective)) then @@ -237,9 +239,9 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip, print'(a,i8,1x,i2,/,6(12x,6(f10.3,1x)/))', & '<< materialpoint >> Jacobian/GPa at elFE ip ', elFE, ip, transpose(materialpoint_dcsdE(1:6,1:6,ip,elCP))*1.0e-9_pReal flush(IO_STDOUT) - endif + end if - endif + end if if (all(abs(materialpoint_dcsdE(1:6,1:6,ip,elCP)) < 1e-10_pReal)) & call IO_warning(601,label1='element (CP)',ID1=elCP,label2='IP',ID2=ip) diff --git a/src/YAML_parse.f90 b/src/YAML_parse.f90 index a65d80fb3..b1f5aaf71 100644 --- a/src/YAML_parse.f90 +++ b/src/YAML_parse.f90 @@ -55,6 +55,7 @@ end subroutine YAML_parse_init !-------------------------------------------------------------------------------------------------- !> @brief Parse a YAML string with list as root into a a structure of nodes. +!> @details The string needs to end with a newline (unless using libfyaml). !-------------------------------------------------------------------------------------------------- function YAML_parse_str_asList(str) result(list) @@ -72,6 +73,7 @@ end function YAML_parse_str_asList !-------------------------------------------------------------------------------------------------- !> @brief Parse a YAML string with dict as root into a a structure of nodes. +!> @details The string needs to end with a newline (unless using libfyaml). !-------------------------------------------------------------------------------------------------- function YAML_parse_str_asDict(str) result(dict) @@ -118,7 +120,7 @@ recursive function parse_flow(YAML_flow) result(node) d = s + scan(flow_string(s+1:),':') e = d + find_end(flow_string(d+1:),'}') key = trim(adjustl(flow_string(s+1:d-1))) - if(quotedString(key)) key = key(2:len(key)-1) + if (quotedString(key)) key = key(2:len(key)-1) myVal => parse_flow(flow_string(d+1:e-1)) ! parse items (recursively) select type (node) @@ -143,7 +145,7 @@ recursive function parse_flow(YAML_flow) result(node) allocate(tScalar::node) select type (node) class is (tScalar) - if(quotedString(flow_string)) then + if (quotedString(flow_string)) then node = trim(adjustl(flow_string(2:len(flow_string)-1))) else node = trim(adjustl(flow_string)) @@ -198,7 +200,7 @@ logical function quotedString(line) if (scan(line(:1),IO_QUOTES) == 1) then quotedString = .true. - if(line(len(line):len(line)) /= line(:1)) call IO_error(710,ext_msg=line) + if (line(len(line):len(line)) /= line(:1)) call IO_error(710,ext_msg=line) end if end function quotedString @@ -245,7 +247,7 @@ integer function indentDepth(line,offset) integer, optional,intent(in) :: offset indentDepth = verify(line,IO_WHITESPACE) -1 - if(present(offset)) indentDepth = indentDepth + offset + if (present(offset)) indentDepth = indentDepth + offset end function indentDepth @@ -285,7 +287,7 @@ logical function isListItem(line) character(len=*), intent(in) :: line isListItem = .false. - if(len_trim(adjustl(line))> 2 .and. index(trim(adjustl(line)), '-') == 1) then + if (len_trim(adjustl(line))> 2 .and. index(trim(adjustl(line)), '-') == 1) then isListItem = scan(trim(adjustl(line)),' ') == 2 else isListItem = trim(adjustl(line)) == '-' @@ -302,8 +304,8 @@ logical function isKeyValue(line) character(len=*), intent(in) :: line isKeyValue = .false. - if( .not. isKey(line) .and. index(IO_rmComment(line),':') > 0 .and. .not. isFlow(line)) then - if(index(IO_rmComment(line),': ') > 0) isKeyValue = .true. + if ( .not. isKey(line) .and. index(IO_rmComment(line),':') > 0 .and. .not. isFlow(line)) then + if (index(IO_rmComment(line),': ') > 0) isKeyValue = .true. end if end function isKeyValue @@ -317,7 +319,7 @@ logical function isKey(line) character(len=*), intent(in) :: line - if(len(IO_rmComment(line)) == 0) then + if (len(IO_rmComment(line)) == 0) then isKey = .false. else isKey = index(IO_rmComment(line),':',back=.false.) == len(IO_rmComment(line)) .and. & @@ -354,7 +356,7 @@ subroutine skip_empty_lines(blck,s_blck) empty = .true. do while(empty .and. len_trim(blck(s_blck:)) /= 0) empty = len_trim(IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))) == 0 - if(empty) s_blck = s_blck + index(blck(s_blck:),IO_EOL) + if (empty) s_blck = s_blck + index(blck(s_blck:),IO_EOL) end do end subroutine skip_empty_lines @@ -372,10 +374,10 @@ subroutine skip_file_header(blck,s_blck) character(len=:), allocatable :: line line = IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2)) - if(index(adjustl(line),'%YAML') == 1) then + if (index(adjustl(line),'%YAML') == 1) then s_blck = s_blck + index(blck(s_blck:),IO_EOL) call skip_empty_lines(blck,s_blck) - if(trim(IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))) == '---') then + if (trim(IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2))) == '---') then s_blck = s_blck + index(blck(s_blck:),IO_EOL) else call IO_error(708,ext_msg = line) @@ -400,8 +402,8 @@ logical function flow_is_closed(str,e_char) flow_is_closed = .false. N_sq = 0 N_cu = 0 - if(e_char == ']') line = str(index(str(:),'[')+1:) - if(e_char == '}') line = str(index(str(:),'{')+1:) + if (e_char == ']') line = str(index(str(:),'[')+1:) + if (e_char == '}') line = str(index(str(:),'{')+1:) do i = 1, len_trim(line) flow_is_closed = (N_sq==0 .and. N_cu==0 .and. scan(line(i:i),e_char) == 1) @@ -463,7 +465,7 @@ subroutine list_item_inline(blck,s_blck,inline,offset) indent_next = indentDepth(blck(s_blck:)) end do - if(scan(inline,",") > 0) inline = '"'//inline//'"' + if (scan(inline,",") > 0) inline = '"'//inline//'"' end subroutine list_item_inline @@ -483,19 +485,19 @@ recursive subroutine line_isFlow(flow,s_flow,line) list_chunk, & dict_chunk - if(index(adjustl(line),'[') == 1) then + if (index(adjustl(line),'[') == 1) then s = index(line,'[') flow(s_flow:s_flow) = '[' s_flow = s_flow +1 do while(s < len_trim(line)) list_chunk = s + find_end(line(s+1:),']') - if(iskeyValue(line(s+1:list_chunk-1))) then + if (iskeyValue(line(s+1:list_chunk-1))) then flow(s_flow:s_flow) = '{' s_flow = s_flow +1 call keyValue_toFlow(flow,s_flow,line(s+1:list_chunk-1)) flow(s_flow:s_flow) = '}' s_flow = s_flow +1 - elseif(isFlow(line(s+1:list_chunk-1))) then + elseif (isFlow(line(s+1:list_chunk-1))) then call line_isFlow(flow,s_flow,line(s+1:list_chunk-1)) else call line_toFlow(flow,s_flow,line(s+1:list_chunk-1)) @@ -509,20 +511,20 @@ recursive subroutine line_isFlow(flow,s_flow,line) flow(s_flow:s_flow) = ']' s_flow = s_flow+1 - elseif(index(adjustl(line),'{') == 1) then + elseif (index(adjustl(line),'{') == 1) then s = index(line,'{') flow(s_flow:s_flow) = '{' s_flow = s_flow +1 do while(s < len_trim(line)) dict_chunk = s + find_end(line(s+1:),'}') - if( .not. iskeyValue(line(s+1:dict_chunk-1))) call IO_error(705,ext_msg=line) + if ( .not. iskeyValue(line(s+1:dict_chunk-1))) call IO_error(705,ext_msg=line) call keyValue_toFlow(flow,s_flow,line(s+1:dict_chunk-1)) flow(s_flow:s_flow+1) = ', ' s_flow = s_flow +2 s = s + find_end(line(s+1:),'}') end do s_flow = s_flow -1 - if(flow(s_flow-1:s_flow-1) == ',') s_flow = s_flow -1 + if (flow(s_flow-1:s_flow-1) == ',') s_flow = s_flow -1 flow(s_flow:s_flow) = '}' s_flow = s_flow +1 else @@ -549,8 +551,8 @@ recursive subroutine keyValue_toFlow(flow,s_flow,line) offset_value col_pos = index(line,':') - if(line(col_pos+1:col_pos+1) /= ' ') call IO_error(704,ext_msg=line) - if(isFlow(line(col_pos+1:))) then + if (line(col_pos+1:col_pos+1) /= ' ') call IO_error(704,ext_msg=line) + if (isFlow(line(col_pos+1:))) then d_flow = len_trim(adjustl(line(:col_pos))) flow(s_flow:s_flow+d_flow+1) = trim(adjustl(line(:col_pos)))//' ' s_flow = s_flow + d_flow+1 @@ -605,35 +607,35 @@ recursive subroutine lst(blck,flow,s_blck,s_flow,offset) do while (s_blck <= len_trim(blck)) e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 line = IO_rmComment(blck(s_blck:e_blck)) - if(trim(line) == '---' .or. trim(line) == '...') then + if (trim(line) == '---' .or. trim(line) == '...') then exit elseif (len_trim(line) == 0) then s_blck = e_blck + 2 ! forward to next line cycle - elseif(indentDepth(line,offset) > indent) then + elseif (indentDepth(line,offset) > indent) then call decide(blck,flow,s_blck,s_flow,offset) offset = 0 flow(s_flow:s_flow+1) = ', ' s_flow = s_flow + 2 - elseif(indentDepth(line,offset) < indent .or. .not. isListItem(line)) then + elseif (indentDepth(line,offset) < indent .or. .not. isListItem(line)) then offset = 0 exit ! job done (lower level) else - if(trim(adjustl(line)) == '-') then ! list item in next line + if (trim(adjustl(line)) == '-') then ! list item in next line s_blck = e_blck + 2 call skip_empty_lines(blck,s_blck) e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 line = IO_rmComment(blck(s_blck:e_blck)) - if(trim(line) == '---') call IO_error(707,ext_msg=line) - if(indentDepth(line) < indent .or. indentDepth(line) == indent) & + if (trim(line) == '---') call IO_error(707,ext_msg=line) + if (indentDepth(line) < indent .or. indentDepth(line) == indent) & call IO_error(701,ext_msg=line) - if(isScalar(line)) then + if (isScalar(line)) then call line_toFlow(flow,s_flow,line) s_blck = e_blck +2 offset = 0 - elseif(isFlow(line)) then - if(isFlowList(line)) then + elseif (isFlow(line)) then + if (isFlowList(line)) then call remove_line_break(blck,s_blck,']',flow_line) else call remove_line_break(blck,s_blck,'}',flow_line) @@ -643,13 +645,13 @@ recursive subroutine lst(blck,flow,s_blck,s_flow,offset) end if else ! list item in the same line line = line(indentDepth(line)+3:) - if(isScalar(line)) then + if (isScalar(line)) then call list_item_inline(blck,s_blck,inline,offset) offset = 0 call line_toFlow(flow,s_flow,inline) - elseif(isFlow(line)) then + elseif (isFlow(line)) then s_blck = s_blck + index(blck(s_blck:),'-') - if(isFlowList(line)) then + if (isFlowList(line)) then call remove_line_break(blck,s_blck,']',flow_line) else call remove_line_break(blck,s_blck,'}',flow_line) @@ -663,7 +665,7 @@ recursive subroutine lst(blck,flow,s_blck,s_flow,offset) end if end if - if(isScalar(line) .or. isFlow(line)) then + if (isScalar(line) .or. isFlow(line)) then flow(s_flow:s_flow+1) = ', ' s_flow = s_flow + 2 end if @@ -702,33 +704,33 @@ recursive subroutine dct(blck,flow,s_blck,s_flow,offset) do while (s_blck <= len_trim(blck)) e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 line = IO_rmComment(blck(s_blck:e_blck)) - if(trim(line) == '---' .or. trim(line) == '...') then + if (trim(line) == '---' .or. trim(line) == '...') then exit elseif (len_trim(line) == 0) then s_blck = e_blck + 2 ! forward to next line cycle - elseif(indentDepth(line,offset) < indent) then - if(isScalar(line) .or. isFlow(line) .and. previous_isKey) & + elseif (indentDepth(line,offset) < indent) then + if (isScalar(line) .or. isFlow(line) .and. previous_isKey) & call IO_error(701,ext_msg=line) offset = 0 exit ! job done (lower level) - elseif(indentDepth(line,offset) > indent .or. isListItem(line)) then + elseif (indentDepth(line,offset) > indent .or. isListItem(line)) then offset = 0 call decide(blck,flow,s_blck,s_flow,offset) else - if(isScalar(line)) call IO_error(701,ext_msg=line) - if(isFlow(line)) call IO_error(702,ext_msg=line) + if (isScalar(line)) call IO_error(701,ext_msg=line) + if (isFlow(line)) call IO_error(702,ext_msg=line) line = line(indentDepth(line)+1:) - if(previous_isKey) then + if (previous_isKey) then flow(s_flow-1:s_flow) = ', ' s_flow = s_flow + 1 end if - if(isKeyValue(line)) then + if (isKeyValue(line)) then col_pos = index(line,':') - if(isFlow(line(col_pos+1:))) then - if(isFlowList(line(col_pos+1:))) then + if (isFlow(line(col_pos+1:))) then + if (isFlowList(line(col_pos+1:))) then call remove_line_break(blck,s_blck,']',flow_line) else call remove_line_break(blck,s_blck,'}',flow_line) @@ -744,7 +746,7 @@ recursive subroutine dct(blck,flow,s_blck,s_flow,offset) end if end if - if(isScalar(line) .or. isKeyValue(line)) then + if (isScalar(line) .or. isKeyValue(line)) then flow(s_flow:s_flow) = ',' s_flow = s_flow + 1 previous_isKey = .false. @@ -764,7 +766,7 @@ end subroutine dct !-------------------------------------------------------------------------------------------------- -! @brief decide whether next block is list or dict +! @brief Decide whether next block is list or dict. !-------------------------------------------------------------------------------------------------- recursive subroutine decide(blck,flow,s_blck,s_flow,offset) @@ -776,13 +778,13 @@ recursive subroutine decide(blck,flow,s_blck,s_flow,offset) integer :: e_blck character(len=:), allocatable :: line,flow_line - if(s_blck <= len(blck)) then + if (s_blck <= len(blck)) then call skip_empty_lines(blck,s_blck) e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 line = IO_rmComment(blck(s_blck:e_blck)) - if(trim(line) == '---' .or. trim(line) == '...') then + if (trim(line) == '---' .or. trim(line) == '...') then continue ! end parsing at this point but not stop the simulation - elseif(len_trim(line) == 0) then + elseif (len_trim(line) == 0) then s_blck = e_blck +2 call decide(blck,flow,s_blck,s_flow,offset) elseif (isListItem(line)) then @@ -791,14 +793,14 @@ recursive subroutine decide(blck,flow,s_blck,s_flow,offset) call lst(blck,flow,s_blck,s_flow,offset) flow(s_flow:s_flow) = ']' s_flow = s_flow + 1 - elseif(isKey(line) .or. isKeyValue(line)) then + elseif (isKey(line) .or. isKeyValue(line)) then flow(s_flow:s_flow) = '{' s_flow = s_flow + 1 call dct(blck,flow,s_blck,s_flow,offset) flow(s_flow:s_flow) = '}' s_flow = s_flow + 1 - elseif(isFlow(line)) then - if(isFlowList(line)) then + elseif (isFlow(line)) then + if (isFlowList(line)) then call remove_line_break(blck,s_blck,']',flow_line) else call remove_line_break(blck,s_blck,'}',flow_line) @@ -811,11 +813,12 @@ recursive subroutine decide(blck,flow,s_blck,s_flow,offset) end if end if -end subroutine +end subroutine decide !-------------------------------------------------------------------------------------------------- -! @brief Convert all block style YAML parts to flow style. +!> @brief Convert all block style YAML parts to flow style. +!> @details The input needs to end with a newline. !-------------------------------------------------------------------------------------------------- function to_flow(blck) @@ -833,18 +836,18 @@ function to_flow(blck) s_blck = 1 offset = 0 - if(len_trim(blck) /= 0) then + if (len_trim(blck) /= 0) then call skip_empty_lines(blck,s_blck) call skip_file_header(blck,s_blck) line = IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2)) - if(trim(line) == '---') s_blck = s_blck + index(blck(s_blck:),IO_EOL) + if (trim(line) == '---') s_blck = s_blck + index(blck(s_blck:),IO_EOL) call decide(blck,to_flow,s_blck,s_flow,offset) end if line = IO_rmComment(blck(s_blck:s_blck+index(blck(s_blck:),IO_EOL)-2)) - if(trim(line)== '---') call IO_warning(709,ext_msg=line) + if (trim(line)== '---') call IO_warning(709,ext_msg=line) to_flow = trim(to_flow(:s_flow-1)) end_line = index(to_flow,IO_EOL) - if(end_line > 0) to_flow = to_flow(:end_line-1) + if (end_line > 0) to_flow = to_flow(:end_line-1) end function to_flow @@ -852,7 +855,7 @@ end function to_flow !-------------------------------------------------------------------------------------------------- !> @brief Check correctness of some YAML functions. !-------------------------------------------------------------------------------------------------- -subroutine selfTest +subroutine selfTest() if (indentDepth(' a') /= 1) error stop 'indentDepth' if (indentDepth('a') /= 0) error stop 'indentDepth' @@ -880,124 +883,139 @@ subroutine selfTest if (.not. isKey(' a:')) error stop 'isKey' if (.not. isKey(' a: #')) error stop 'isKey' - if( isScalar('a: ')) error stop 'isScalar' - if( isScalar('a: b')) error stop 'isScalar' - if( isScalar('{a:b}')) error stop 'isScalar' - if( isScalar('- a:')) error stop 'isScalar' - if(.not. isScalar(' a')) error stop 'isScalar' + if ( isScalar('a: ')) error stop 'isScalar' + if ( isScalar('a: b')) error stop 'isScalar' + if ( isScalar('{a:b}')) error stop 'isScalar' + if ( isScalar('- a:')) error stop 'isScalar' + if (.not. isScalar(' a')) error stop 'isScalar' basic_list: block - character(len=*), parameter :: block_list = & - " - Casablanca"//IO_EOL//& - " - North by Northwest"//IO_EOL - character(len=*), parameter :: block_list_newline = & - " -"//IO_EOL//& - " Casablanca"//IO_EOL//& - " -"//IO_EOL//& - " North by Northwest"//IO_EOL - character(len=*), parameter :: flow_list = & - "[Casablanca, North by Northwest]" + character(len=*), parameter :: block_list = & + " - Casablanca"//IO_EOL//& + " - North by Northwest"//IO_EOL + character(len=*), parameter :: block_list_newline = & + " -"//IO_EOL//& + " Casablanca"//IO_EOL//& + " -"//IO_EOL//& + " North by Northwest"//IO_EOL + character(len=*), parameter :: flow_list = & + "[Casablanca, North by Northwest]" - if (.not. to_flow(block_list) == flow_list) error stop 'to_flow' - if (.not. to_flow(block_list_newline) == flow_list) error stop 'to_flow' + if (.not. to_flow(block_list) == flow_list) error stop 'to_flow' + if (.not. to_flow(block_list_newline) == flow_list) error stop 'to_flow' end block basic_list basic_dict: block - character(len=*), parameter :: block_dict = & - " aa: Casablanca"//IO_EOL//& - " bb: North by Northwest"//IO_EOL - character(len=*), parameter :: block_dict_newline = & - " aa:"//IO_EOL//& - " Casablanca"//IO_EOL//& - " bb:"//IO_EOL//& - " North by Northwest"//IO_EOL - character(len=*), parameter :: flow_dict = & - "{aa: Casablanca, bb: North by Northwest}" + character(len=*), parameter :: block_dict = & + " aa: Casablanca"//IO_EOL//& + " bb: North by Northwest"//IO_EOL + character(len=*), parameter :: block_dict_newline = & + " aa:"//IO_EOL//& + " Casablanca"//IO_EOL//& + " bb:"//IO_EOL//& + " North by Northwest"//IO_EOL + character(len=*), parameter :: flow_dict = & + "{aa: Casablanca, bb: North by Northwest}" - if (.not. to_flow(block_dict) == flow_dict) error stop 'to_flow' - if (.not. to_flow(block_dict_newline) == flow_dict) error stop 'to_flow' + if (.not. to_flow(block_dict) == flow_dict) error stop 'to_flow' + if (.not. to_flow(block_dict_newline) == flow_dict) error stop 'to_flow' end block basic_dict only_flow: block - character(len=*), parameter :: flow_dict = & - " {a: [b,c: {d: e}, f: g, e]}"//IO_EOL - character(len=*), parameter :: flow_list = & - " [a,b: c, d,e: {f: g}]"//IO_EOL - character(len=*), parameter :: flow_1 = & - "{a: [b, {c: {d: e}}, {f: g}, e]}" - character(len=*), parameter :: flow_2 = & - "[a, {b: c}, d, {e: {f: g}}]" + character(len=*), parameter :: flow_dict = & + " {a: [b,c: {d: e}, f: g, e]}"//IO_EOL + character(len=*), parameter :: flow_list = & + " [a,b: c, d,e: {f: g}]"//IO_EOL + character(len=*), parameter :: flow_1 = & + "{a: [b, {c: {d: e}}, {f: g}, e]}" + character(len=*), parameter :: flow_2 = & + "[a, {b: c}, d, {e: {f: g}}]" - if (.not. to_flow(flow_dict) == flow_1) error stop 'to_flow' - if (.not. to_flow(flow_list) == flow_2) error stop 'to_flow' + if (.not. to_flow(flow_dict) == flow_1) error stop 'to_flow' + if (.not. to_flow(flow_list) == flow_2) error stop 'to_flow' end block only_flow basic_flow: block - character(len=*), parameter :: flow_braces = & - " source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]"//IO_EOL - character(len=*), parameter :: flow_mixed_braces = & - " source: [param: 1, {param: 2}, param: 3, {param: 4}]"//IO_EOL - character(len=*), parameter :: flow = & - "{source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]}" + character(len=*), parameter :: flow_braces = & + " source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]"//IO_EOL + character(len=*), parameter :: flow_mixed_braces = & + " source: [param: 1, {param: 2}, param: 3, {param: 4}]"//IO_EOL + character(len=*), parameter :: flow = & + "{source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]}" - if (.not. to_flow(flow_braces) == flow) error stop 'to_flow' - if (.not. to_flow(flow_mixed_braces) == flow) error stop 'to_flow' + if (.not. to_flow(flow_braces) == flow) error stop 'to_flow' + if (.not. to_flow(flow_mixed_braces) == flow) error stop 'to_flow' end block basic_flow multi_line_flow1: block - character(len=*), parameter :: flow_multi = & - '%YAML 1.1'//IO_EOL//& - '---'//IO_EOL//& - 'a: ["b",'//IO_EOL//& - 'c: '//IO_EOL//& - '"d", "e"]'//IO_EOL + character(len=*), parameter :: flow_multi = & + '%YAML 1.1'//IO_EOL//& + '---'//IO_EOL//& + 'a: ["b",'//IO_EOL//& + 'c: '//IO_EOL//& + '"d", "e"]'//IO_EOL - character(len=*), parameter :: flow = & - '{a: ["b", {c: "d"}, "e"]}' + character(len=*), parameter :: flow = & + '{a: ["b", {c: "d"}, "e"]}' - if( .not. to_flow(flow_multi) == flow) error stop 'to_flow' + if ( .not. to_flow(flow_multi) == flow) error stop 'to_flow' end block multi_line_flow1 multi_line_flow2: block - character(len=*), parameter :: flow_multi = & - "%YAML 1.1"//IO_EOL//& - "---"//IO_EOL//& - "-"//IO_EOL//& - " a: {b:"//IO_EOL//& - "[c,"//IO_EOL//& - "d"//IO_EOL//& - "e, f]}"//IO_EOL + character(len=*), parameter :: flow_multi = & + "%YAML 1.1"//IO_EOL//& + "---"//IO_EOL//& + "-"//IO_EOL//& + " a: {b:"//IO_EOL//& + "[c,"//IO_EOL//& + "d"//IO_EOL//& + "e, f]}"//IO_EOL - character(len=*), parameter :: flow = & - "[{a: {b: [c, d e, f]}}]" + character(len=*), parameter :: flow = & + "[{a: {b: [c, d e, f]}}]" - if( .not. to_flow(flow_multi) == flow) error stop 'to_flow' + if ( .not. to_flow(flow_multi) == flow) error stop 'to_flow' end block multi_line_flow2 basic_mixed: block - character(len=*), parameter :: block_flow = & - "%YAML 1.1"//IO_EOL//& - " "//IO_EOL//& - " "//IO_EOL//& - "---"//IO_EOL//& - " aa:"//IO_EOL//& - " - "//IO_EOL//& - " "//IO_EOL//& - " "//IO_EOL//& - " param_1: [a: b, c, {d: {e: [f: g, h]}}]"//IO_EOL//& - " - c:d"//IO_EOL//& - " e.f,"//IO_EOL//& - " bb:"//IO_EOL//& - " "//IO_EOL//& - " - "//IO_EOL//& - " {param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}"//IO_EOL//& - "..."//IO_EOL - character(len=*), parameter :: mixed_flow = & - '{aa: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}, "c:d e.f,"], bb: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}]}' + character(len=*), parameter :: block_flow = & + "%YAML 1.1"//IO_EOL//& + " "//IO_EOL//& + " "//IO_EOL//& + "---"//IO_EOL//& + " aa:"//IO_EOL//& + " - "//IO_EOL//& + " "//IO_EOL//& + " "//IO_EOL//& + " param_1: [a: b, c, {d: {e: [f: g, h]}}]"//IO_EOL//& + " - c:d"//IO_EOL//& + " e.f,"//IO_EOL//& + " bb:"//IO_EOL//& + " "//IO_EOL//& + " - "//IO_EOL//& + " {param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}"//IO_EOL//& + "..."//IO_EOL + character(len=*), parameter :: mixed_flow = & + '{aa: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}, "c:d e.f,"], bb: [{param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}]}' - if(.not. to_flow(block_flow) == mixed_flow) error stop 'to_flow' + if (.not. to_flow(block_flow) == mixed_flow) error stop 'to_flow' end block basic_mixed + parse: block + + type(tDict), pointer :: dict + type(tList), pointer :: list + character(len=*), parameter :: & + lst = '[1, 2, 3, 4]', & + dct = '{a: 1, b: 2}' + + list => YAML_parse_str_asList(lst//IO_EOL) + if (list%asFormattedString() /= lst) error stop 'str_asList' + dict => YAML_parse_str_asDict(dct//IO_EOL) + if (dict%asFormattedString() /= dct) error stop 'str_asDict' + + end block parse + end subroutine selfTest #endif diff --git a/src/discretization.f90 b/src/discretization.f90 index f24b0eadf..2c605b422 100644 --- a/src/discretization.f90 +++ b/src/discretization.f90 @@ -64,7 +64,7 @@ subroutine discretization_init(materialAt,& discretization_NodeCoords0 = NodeCoords0 discretization_NodeCoords = NodeCoords0 - if(present(sharedNodesBegin)) then + if (present(sharedNodesBegin)) then discretization_sharedNodesBegin = sharedNodesBegin else discretization_sharedNodesBegin = size(discretization_NodeCoords0,2) diff --git a/src/geometry_plastic_nonlocal.f90 b/src/geometry_plastic_nonlocal.f90 index 09c40f8b3..f0da5539b 100644 --- a/src/geometry_plastic_nonlocal.f90 +++ b/src/geometry_plastic_nonlocal.f90 @@ -92,16 +92,16 @@ end subroutine geometry_plastic_nonlocal_setIPareaNormal !--------------------------------------------------------------------------------------------------- subroutine geometry_plastic_nonlocal_disable - if(allocated(geometry_plastic_nonlocal_IPneighborhood)) & + if (allocated(geometry_plastic_nonlocal_IPneighborhood)) & deallocate(geometry_plastic_nonlocal_IPneighborhood) - if(allocated(geometry_plastic_nonlocal_IPvolume0)) & + if (allocated(geometry_plastic_nonlocal_IPvolume0)) & deallocate(geometry_plastic_nonlocal_IPvolume0) - if(allocated(geometry_plastic_nonlocal_IParea0)) & + if (allocated(geometry_plastic_nonlocal_IParea0)) & deallocate(geometry_plastic_nonlocal_IParea0) - if(allocated(geometry_plastic_nonlocal_IPareaNormal0)) & + if (allocated(geometry_plastic_nonlocal_IPareaNormal0)) & deallocate(geometry_plastic_nonlocal_IPareaNormal0) end subroutine geometry_plastic_nonlocal_disable diff --git a/src/grid/DAMASK_grid.f90 b/src/grid/DAMASK_grid.f90 index c9dea0166..2e21dec8d 100644 --- a/src/grid/DAMASK_grid.f90 +++ b/src/grid/DAMASK_grid.f90 @@ -148,7 +148,7 @@ program DAMASK_grid call results_openJobFile(parallel=.false.) call results_writeDataset_str(fileContent,'setup',fname,'load case definition (grid solver)') call results_closeJobFile - endif + end if call parallelization_bcast_str(fileContent) config_load => YAML_parse_str_asDict(fileContent) @@ -198,11 +198,11 @@ program DAMASK_grid thermalActive: if (solver%get_asString('thermal',defaultVal = 'n/a') == 'spectral') then field = field + 1 ID(field) = FIELD_THERMAL_ID - endif thermalActive + end if thermalActive damageActive: if (solver%get_asString('damage',defaultVal = 'n/a') == 'spectral') then field = field + 1 ID(field) = FIELD_DAMAGE_ID - endif damageActive + end if damageActive !-------------------------------------------------------------------------------------------------- @@ -235,7 +235,7 @@ program DAMASK_grid #endif end select call loadCases(l)%rot%fromAxisAngle(step_mech%get_as1dFloat('R',defaultVal = real([0.0,0.0,1.0,0.0],pReal)),degrees=.true.) - enddo readMech + end do readMech if (.not. allocated(loadCases(l)%deformation%myType)) call IO_error(error_ID=837,ext_msg = 'L/dot_F/F missing') step_discretization => load_step%get_dict('discretization') @@ -264,9 +264,9 @@ program DAMASK_grid write(IO_STDOUT,'(2x,12a)',advance='no') ' x ' else write(IO_STDOUT,'(2x,f12.7)',advance='no') loadCases(l)%deformation%values(i,j) - endif - enddo; write(IO_STDOUT,'(/)',advance='no') - enddo + end if + end do; write(IO_STDOUT,'(/)',advance='no') + end do if (any(loadCases(l)%stress%mask .eqv. loadCases(l)%deformation%mask)) errorID = 831 if (any(.not.(loadCases(l)%stress%mask .or. transpose(loadCases(l)%stress%mask)) .and. (math_I3<1))) & errorID = 838 ! no rotation is allowed by stress BC @@ -280,10 +280,10 @@ program DAMASK_grid write(IO_STDOUT,'(2x,12a)',advance='no') ' x ' else write(IO_STDOUT,'(2x,f12.4)',advance='no') loadCases(l)%stress%values(i,j)*1e-6_pReal - endif - enddo; write(IO_STDOUT,'(/)',advance='no') - enddo - endif + end if + end do; write(IO_STDOUT,'(/)',advance='no') + end do + end if if (any(dNeq(loadCases(l)%rot%asMatrix(), math_I3))) & write(IO_STDOUT,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'R:',& transpose(loadCases(l)%rot%asMatrix()) @@ -298,7 +298,7 @@ program DAMASK_grid print'(2x,a)', 'r: 1 (constant step width)' else print'(2x,a,1x,f0.3)', 'r:', loadCases(l)%r - endif + end if print'(2x,a,1x,f0.3)', 't:', loadCases(l)%t print'(2x,a,1x,i0)', 'N:', loadCases(l)%N if (loadCases(l)%f_out < huge(0)) & @@ -308,8 +308,8 @@ program DAMASK_grid if (errorID > 0) call IO_error(errorID,label1='line',ID1=l) - endif reportAndCheck - enddo + end if reportAndCheck + end do !-------------------------------------------------------------------------------------------------- ! doing initialization depending on active solvers @@ -337,14 +337,14 @@ program DAMASK_grid else writeHeader open(newunit=statUnit,file=trim(getSolverJobName())//& '.sta',form='FORMATTED', position='APPEND', status='OLD') - endif writeHeader - endif + end if writeHeader + end if writeUndeformed: if (CLI_restartInc < 1) then print'(/,1x,a)', '... writing initial configuration to file .................................' flush(IO_STDOUT) call materialpoint_results(0,0.0_pReal) - endif writeUndeformed + end if writeUndeformed loadCaseLooping: do l = 1, size(loadCases) t_0 = t ! load case start time @@ -361,7 +361,7 @@ program DAMASK_grid else Delta_t = loadCases(l)%t * (loadCases(l)%r**(inc-1)-loadCases(l)%r**inc) & / (1.0_pReal-loadCases(l)%r**loadCases(l)%N) - endif + end if Delta_t = Delta_t * real(subStepFactor,pReal)**real(-cutBackLevel,pReal) ! depending on cut back level, decrease time step skipping: if (totalIncsCounter <= CLI_restartInc) then ! not yet at restart inc? @@ -402,7 +402,7 @@ program DAMASK_grid case(FIELD_THERMAL_ID); call grid_thermal_spectral_forward(cutBack) case(FIELD_DAMAGE_ID); call grid_damage_spectral_forward(cutBack) end select - enddo + end do if (.not. cutBack) call materialpoint_forward !-------------------------------------------------------------------------------------------------- @@ -422,12 +422,12 @@ program DAMASK_grid if (.not. solres(field)%converged) exit ! no solution found - enddo + end do stagIter = stagIter + 1 stagIterate = stagIter < stagItMax & .and. all(solres(:)%converged) & .and. .not. all(solres(:)%stagConverged) ! stationary with respect to staggered iteration - enddo + end do !-------------------------------------------------------------------------------------------------- ! check solution for either advance or retry @@ -442,7 +442,7 @@ program DAMASK_grid write(statUnit,*) totalIncsCounter, t, cutBackLevel, & solres(1)%converged, solres(1)%iterationsNeeded flush(statUnit) - endif + end if elseif (cutBackLevel < maxCutBack) then ! further cutbacking tolerated? cutBack = .true. stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator @@ -453,9 +453,9 @@ program DAMASK_grid else ! no more options to continue if (worldrank == 0) close(statUnit) call IO_error(950) - endif + end if - enddo subStepLooping + end do subStepLooping cutBackLevel = max(0, cutBackLevel - 1) ! try half number of subincs next inc @@ -463,7 +463,7 @@ program DAMASK_grid print'(/,1x,a,i0,a)', 'increment ', totalIncsCounter, ' converged' else print'(/,1x,a,i0,a)', 'increment ', totalIncsCounter, ' NOT converged' - endif; flush(IO_STDOUT) + end if; flush(IO_STDOUT) call MPI_Allreduce(signals_SIGUSR1,signal,1_MPI_INTEGER_KIND,MPI_LOGICAL,MPI_LOR,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' @@ -471,7 +471,7 @@ program DAMASK_grid print'(/,1x,a)', '... writing results to file ...............................................' flush(IO_STDOUT) call materialpoint_results(totalIncsCounter,t) - endif + end if if (signal) call signals_setSIGUSR1(.false.) call MPI_Allreduce(signals_SIGUSR2,signal,1_MPI_INTEGER_KIND,MPI_LOGICAL,MPI_LOR,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' @@ -482,19 +482,21 @@ program DAMASK_grid call mechanical_restartWrite case(FIELD_THERMAL_ID) call grid_thermal_spectral_restartWrite + case(FIELD_DAMAGE_ID) + call grid_damage_spectral_restartWrite end select end do call materialpoint_restartWrite - endif + end if if (signal) call signals_setSIGUSR2(.false.) call MPI_Allreduce(signals_SIGINT,signal,1_MPI_INTEGER_KIND,MPI_LOGICAL,MPI_LOR,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' if (signal) exit loadCaseLooping - endif skipping + end if skipping - enddo incLooping + end do incLooping - enddo loadCaseLooping + end do loadCaseLooping !-------------------------------------------------------------------------------------------------- @@ -523,9 +525,9 @@ subroutine getMaskedTensor(values,mask,tensor) do j = 1,3 mask(i,j) = row%get_asString(j) == 'x' if (.not. mask(i,j)) values(i,j) = row%get_asFloat(j) - enddo - enddo + end do + end do -end subroutine +end subroutine getMaskedTensor end program DAMASK_grid diff --git a/src/grid/VTI.f90 b/src/grid/VTI.f90 index 5c3cb864a..cc5a6843b 100644 --- a/src/grid/VTI.f90 +++ b/src/grid/VTI.f90 @@ -222,7 +222,7 @@ subroutine cellsSizeOrigin(c,s,o,header) temp = getXMLValue(header,'Origin') o = [(IO_floatValue(temp,IO_stringPos(temp),i),i=1,3)] -end subroutine +end subroutine cellsSizeOrigin !-------------------------------------------------------------------------------------------------- @@ -421,7 +421,7 @@ pure function getXMLValue(line,key) end if end if -end function +end function getXMLValue !-------------------------------------------------------------------------------------------------- diff --git a/src/grid/base64.f90 b/src/grid/base64.f90 index 6e580f043..40986d783 100644 --- a/src/grid/base64.f90 +++ b/src/grid/base64.f90 @@ -73,27 +73,27 @@ function base64_to_bytes(base64_str,s,e) result(bytes) integer(pI64) :: s_bytes, e_bytes, s_str, e_str integer(C_SIGNED_CHAR), dimension(:), allocatable :: bytes - if(.not. validBase64(base64_str)) call IO_error(114,ext_msg='invalid character') + if (.not. validBase64(base64_str)) call IO_error(114,ext_msg='invalid character') - if(present(s)) then - if(s<1_pI64) call IO_error(114, ext_msg='s out of range') + if (present(s)) then + if (s<1_pI64) call IO_error(114, ext_msg='s out of range') s_str = ((s-1_pI64)/3_pI64)*4_pI64 + 1_pI64 s_bytes = mod(s-1_pI64,3_pI64) + 1_pI64 else s_str = 1_pI64 s_bytes = 1_pI64 - endif + end if - if(present(e)) then - if(e>base64_nByte(len(base64_str,kind=pI64))) call IO_error(114, ext_msg='e out of range') + if (present(e)) then + if (e>base64_nByte(len(base64_str,kind=pI64))) call IO_error(114, ext_msg='e out of range') e_str = ((e-1_pI64)/3_pI64)*4_pI64 + 4_pI64 e_bytes = e - base64_nByte(s_str) else e_str = len(base64_str,kind=pI64) e_bytes = base64_nByte(len(base64_str,kind=pI64)) - base64_nByte(s_str) - if(base64_str(e_str-0_pI64:e_str-0_pI64) == '=') e_bytes = e_bytes - 1_pI64 - if(base64_str(e_str-1_pI64:e_str-1_pI64) == '=') e_bytes = e_bytes - 1_pI64 - endif + if (base64_str(e_str-0_pI64:e_str-0_pI64) == '=') e_bytes = e_bytes - 1_pI64 + if (base64_str(e_str-1_pI64:e_str-1_pI64) == '=') e_bytes = e_bytes - 1_pI64 + end if bytes = decodeBase64(base64_str(s_str:e_str)) bytes = bytes(s_bytes:e_bytes) @@ -118,12 +118,12 @@ pure function decodeBase64(base64_str) result(bytes) do while(c < len(base64_str,kind=pI64)) do p=0_pI64,3_pI64 - if(c+p<=len(base64_str,kind=pI64)) then + if (c+p<=len(base64_str,kind=pI64)) then charPos(p) = int(index(base64_encoding,base64_str(c+p:c+p))-1,C_SIGNED_CHAR) else charPos(p) = 0_C_SIGNED_CHAR - endif - enddo + end if + end do call mvbits(charPos(0),0,6,bytes(b+0),2) call mvbits(charPos(1),4,2,bytes(b+0),0) @@ -133,7 +133,7 @@ pure function decodeBase64(base64_str) result(bytes) call mvbits(charPos(3),0,6,bytes(b+2),0) b = b+3_pI64 c = c+4_pI64 - enddo + end do end function decodeBase64 @@ -151,9 +151,9 @@ pure logical function validBase64(base64_str) l = len(base64_str,pI64) validBase64 = .true. - if(mod(l,4_pI64)/=0_pI64 .or. l < 4_pI64) validBase64 = .false. - if(verify(base64_str(:l-2_pI64),base64_encoding, kind=pI64) /= 0_pI64) validBase64 = .false. - if(verify(base64_str(l-1_pI64:),base64_encoding//'=',kind=pI64) /= 0_pI64) validBase64 = .false. + if (mod(l,4_pI64)/=0_pI64 .or. l < 4_pI64) validBase64 = .false. + if (verify(base64_str(:l-2_pI64),base64_encoding, kind=pI64) /= 0_pI64) validBase64 = .false. + if (verify(base64_str(l-1_pI64:),base64_encoding//'=',kind=pI64) /= 0_pI64) validBase64 = .false. end function validBase64 @@ -167,59 +167,59 @@ subroutine selfTest character(len=*), parameter :: zero_to_three = 'AAECAw==' ! https://en.wikipedia.org/wiki/Base64#Output_padding - if(base64_nChar(20_pI64) /= 28_pI64) error stop 'base64_nChar/20/28' - if(base64_nChar(19_pI64) /= 28_pI64) error stop 'base64_nChar/19/28' - if(base64_nChar(18_pI64) /= 24_pI64) error stop 'base64_nChar/18/24' - if(base64_nChar(17_pI64) /= 24_pI64) error stop 'base64_nChar/17/24' - if(base64_nChar(16_pI64) /= 24_pI64) error stop 'base64_nChar/16/24' + if (base64_nChar(20_pI64) /= 28_pI64) error stop 'base64_nChar/20/28' + if (base64_nChar(19_pI64) /= 28_pI64) error stop 'base64_nChar/19/28' + if (base64_nChar(18_pI64) /= 24_pI64) error stop 'base64_nChar/18/24' + if (base64_nChar(17_pI64) /= 24_pI64) error stop 'base64_nChar/17/24' + if (base64_nChar(16_pI64) /= 24_pI64) error stop 'base64_nChar/16/24' - if(base64_nByte(4_pI64) /= 3_pI64) error stop 'base64_nByte/4/3' - if(base64_nByte(8_pI64) /= 6_pI64) error stop 'base64_nByte/8/6' + if (base64_nByte(4_pI64) /= 3_pI64) error stop 'base64_nByte/4/3' + if (base64_nByte(8_pI64) /= 6_pI64) error stop 'base64_nByte/8/6' bytes = base64_to_bytes(zero_to_three) - if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes//' + if (any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes//' bytes = base64_to_bytes(zero_to_three,e=1_pI64) - if(any(bytes /= int([0],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes//1' + if (any(bytes /= int([0],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes//1' bytes = base64_to_bytes(zero_to_three,e=2_pI64) - if(any(bytes /= int([0,1],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes//2' + if (any(bytes /= int([0,1],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes//2' bytes = base64_to_bytes(zero_to_three,e=3_pI64) - if(any(bytes /= int([0,1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes//3' + if (any(bytes /= int([0,1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes//3' bytes = base64_to_bytes(zero_to_three,e=4_pI64) - if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes//4' + if (any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes//4' bytes = base64_to_bytes(zero_to_three,s=1_pI64) - if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes/1/' + if (any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes/1/' bytes = base64_to_bytes(zero_to_three,s=2_pI64) - if(any(bytes /= int([1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes/2/' + if (any(bytes /= int([1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes/2/' bytes = base64_to_bytes(zero_to_three,s=3_pI64) - if(any(bytes /= int([2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/3/' + if (any(bytes /= int([2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/3/' bytes = base64_to_bytes(zero_to_three,s=4_pI64) - if(any(bytes /= int([3],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/4/' + if (any(bytes /= int([3],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/4/' bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=1_pI64) - if(any(bytes /= int([0],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/1/1' + if (any(bytes /= int([0],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/1/1' bytes = base64_to_bytes(zero_to_three,s=2_pI64,e=2_pI64) - if(any(bytes /= int([1],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/2/2' + if (any(bytes /= int([1],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/2/2' bytes = base64_to_bytes(zero_to_three,s=3_pI64,e=3_pI64) - if(any(bytes /= int([2],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/3/3' + if (any(bytes /= int([2],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/3/3' bytes = base64_to_bytes(zero_to_three,s=4_pI64,e=4_pI64) - if(any(bytes /= int([3],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/4/4' + if (any(bytes /= int([3],C_SIGNED_CHAR)) .or. size(bytes) /= 1) error stop 'base64_to_bytes/4/4' bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=2_pI64) - if(any(bytes /= int([0,1],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/1/2' + if (any(bytes /= int([0,1],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/1/2' bytes = base64_to_bytes(zero_to_three,s=2_pI64,e=3_pI64) - if(any(bytes /= int([1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/2/3' + if (any(bytes /= int([1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/2/3' bytes = base64_to_bytes(zero_to_three,s=3_pI64,e=4_pI64) - if(any(bytes /= int([2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/3/4' + if (any(bytes /= int([2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 2) error stop 'base64_to_bytes/3/4' bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=3_pI64) - if(any(bytes /= int([0,1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes/1/3' + if (any(bytes /= int([0,1,2],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes/1/3' bytes = base64_to_bytes(zero_to_three,s=2_pI64,e=4_pI64) - if(any(bytes /= int([1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes/2/4' + if (any(bytes /= int([1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 3) error stop 'base64_to_bytes/2/4' bytes = base64_to_bytes(zero_to_three,s=1_pI64,e=4_pI64) - if(any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes/1/4' + if (any(bytes /= int([0,1,2,3],C_SIGNED_CHAR)) .or. size(bytes) /= 4) error stop 'base64_to_bytes/1/4' end subroutine selfTest diff --git a/src/grid/discretization_grid.f90 b/src/grid/discretization_grid.f90 index 158ee0a8d..999b8f460 100644 --- a/src/grid/discretization_grid.f90 +++ b/src/grid/discretization_grid.f90 @@ -334,7 +334,7 @@ function discretization_grid_getInitialCondition(label) result(ic) ic_global = VTI_readDataset_real(IO_read(CLI_geomFile),label) else allocate(ic_global(0)) ! needed for IntelMPI - endif + end if call MPI_Gather(product(cells(1:2))*cells3Offset, 1_MPI_INTEGER_KIND,MPI_INTEGER,displs,& 1_MPI_INTEGER_KIND,MPI_INTEGER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) diff --git a/src/grid/grid_damage_spectral.f90 b/src/grid/grid_damage_spectral.f90 index e2542d722..cc4cabd49 100644 --- a/src/grid/grid_damage_spectral.f90 +++ b/src/grid/grid_damage_spectral.f90 @@ -16,6 +16,9 @@ module grid_damage_spectral use prec use parallelization use IO + use CLI + use HDF5_utilities + use HDF5 use spectral_utilities use discretization_grid use homogenization @@ -59,13 +62,13 @@ module grid_damage_spectral public :: & grid_damage_spectral_init, & grid_damage_spectral_solution, & + grid_damage_spectral_restartWrite, & grid_damage_spectral_forward contains !-------------------------------------------------------------------------------------------------- !> @brief allocates all neccessary fields and fills them with data -! ToDo: Restart not implemented !-------------------------------------------------------------------------------------------------- subroutine grid_damage_spectral_init() @@ -76,6 +79,8 @@ subroutine grid_damage_spectral_init() Vec :: uBound, lBound integer(MPI_INTEGER_KIND) :: err_MPI PetscErrorCode :: err_PETSc + integer(HID_T) :: fileHandle, groupHandle + real(pReal), dimension(1,product(cells(1:2))*cells3) :: tempN type(tDict), pointer :: & num_grid, & num_generic @@ -167,6 +172,18 @@ subroutine grid_damage_spectral_init() CHKERRQ(err_PETSc) end if + restartRead: if (CLI_restartInc > 0) then + print'(/,1x,a,i0,a)', 'reading restart data of increment ', CLI_restartInc, ' from file' + + fileHandle = HDF5_openFile(getSolverJobName()//'_restart.hdf5','r') + groupHandle = HDF5_openGroup(fileHandle,'solver') + + call HDF5_read(tempN,groupHandle,'phi',.false.) + phi = reshape(tempN,[cells(1),cells(2),cells3]) + call HDF5_read(tempN,groupHandle,'phi_lastInc',.false.) + phi_lastInc = reshape(tempN,[cells(1),cells(2),cells3]) + end if restartRead + ce = 0 do k = 1, cells3; do j = 1, cells(2); do i = 1, cells(1) ce = ce + 1 @@ -285,6 +302,36 @@ subroutine grid_damage_spectral_forward(cutBack) end subroutine grid_damage_spectral_forward +!-------------------------------------------------------------------------------------------------- +!> @brief Write current solver and constitutive data for restart to file. +!-------------------------------------------------------------------------------------------------- +subroutine grid_damage_spectral_restartWrite + + PetscErrorCode :: err_PETSc + DM :: dm_local + integer(HID_T) :: fileHandle, groupHandle + PetscScalar, dimension(:,:,:), pointer :: phi + + call SNESGetDM(SNES_damage,dm_local,err_PETSc); + CHKERRQ(err_PETSc) + call DMDAVecGetArrayF90(dm_local,solution_vec,phi,err_PETSc); + CHKERRQ(err_PETSc) + + print'(1x,a)', 'writing damage solver data required for restart to file'; flush(IO_STDOUT) + + fileHandle = HDF5_openFile(getSolverJobName()//'_restart.hdf5','a') + groupHandle = HDF5_openGroup(fileHandle,'solver') + call HDF5_write(reshape(phi,[1,product(cells(1:2))*cells3]),groupHandle,'phi') + call HDF5_write(reshape(phi_lastInc,[1,product(cells(1:2))*cells3]),groupHandle,'phi_lastInc') + call HDF5_closeGroup(groupHandle) + call HDF5_closeFile(fileHandle) + + call DMDAVecRestoreArrayF90(dm_local,solution_vec,phi,err_PETSc); + CHKERRQ(err_PETSc) + +end subroutine grid_damage_spectral_restartWrite + + !-------------------------------------------------------------------------------------------------- !> @brief Construct the residual vector. !-------------------------------------------------------------------------------------------------- @@ -327,7 +374,7 @@ end subroutine formResidual !-------------------------------------------------------------------------------------------------- -!> @brief update reference viscosity and conductivity +!> @brief Update reference viscosity and conductivity. !-------------------------------------------------------------------------------------------------- subroutine updateReference() diff --git a/src/grid/grid_mech_FEM.f90 b/src/grid/grid_mech_FEM.f90 index f4f0a9fb8..3d2dea5a6 100644 --- a/src/grid/grid_mech_FEM.f90 +++ b/src/grid/grid_mech_FEM.f90 @@ -179,7 +179,7 @@ subroutine grid_mechanical_FEM_init localK = 0_pPetscInt localK(worldrank) = int(cells3,pPetscInt) call MPI_Allreduce(MPI_IN_PLACE,localK,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' call DMDACreate3d(PETSC_COMM_WORLD, & DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, & DMDA_STENCIL_BOX, & @@ -252,16 +252,16 @@ subroutine grid_mechanical_FEM_init call HDF5_read(P_aim,groupHandle,'P_aim',.false.) call MPI_Bcast(P_aim,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' call HDF5_read(F_aim,groupHandle,'F_aim',.false.) call MPI_Bcast(F_aim,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' call HDF5_read(F_aim_lastInc,groupHandle,'F_aim_lastInc',.false.) call MPI_Bcast(F_aim_lastInc,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' call HDF5_read(F_aimDot,groupHandle,'F_aimDot',.false.) call MPI_Bcast(F_aimDot,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' call HDF5_read(temp33n,groupHandle,'F') F = reshape(temp33n,[3,3,cells(1),cells(2),cells3]) call HDF5_read(temp33n,groupHandle,'F_lastInc') @@ -274,7 +274,7 @@ subroutine grid_mechanical_FEM_init elseif (CLI_restartInc == 0) then restartRead F_lastInc = spread(spread(spread(math_I3,3,cells(1)),4,cells(2)),5,cells3) ! initialize to identity F = spread(spread(spread(math_I3,3,cells(1)),4,cells(2)),5,cells3) - endif restartRead + end if restartRead homogenization_F0 = reshape(F_lastInc, [3,3,product(cells(1:2))*cells3]) ! set starting condition for homogenization_mechanical_response call utilities_updateCoords(F) @@ -290,15 +290,15 @@ subroutine grid_mechanical_FEM_init print'(1x,a,i0,a)', 'reading more restart data of increment ', CLI_restartInc, ' from file' call HDF5_read(C_volAvg,groupHandle,'C_volAvg',.false.) call MPI_Bcast(C_volAvg,81_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' call HDF5_read(C_volAvgLastInc,groupHandle,'C_volAvgLastInc',.false.) call MPI_Bcast(C_volAvgLastInc,81_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' call HDF5_closeGroup(groupHandle) call HDF5_closeFile(fileHandle) - endif restartRead2 + end if restartRead2 end subroutine grid_mechanical_FEM_init @@ -387,7 +387,7 @@ subroutine grid_mechanical_FEM_forward(cutBack,guess,Delta_t,Delta_t_old,t_remai elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed F_aimDot = F_aimDot & + merge(.0_pReal,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) - endif + end if if (guess) then call VecWAXPY(solution_rate,-1.0_pReal,solution_lastInc,solution_current,err_PETSc) @@ -397,14 +397,14 @@ subroutine grid_mechanical_FEM_forward(cutBack,guess,Delta_t,Delta_t_old,t_remai else call VecSet(solution_rate,0.0_pReal,err_PETSc) CHKERRQ(err_PETSc) - endif + end if call VecCopy(solution_current,solution_lastInc,err_PETSc) CHKERRQ(err_PETSc) F_lastInc = F homogenization_F0 = reshape(F, [3,3,product(cells(1:2))*cells3]) - endif + end if !-------------------------------------------------------------------------------------------------- ! update average and local deformation gradients @@ -477,7 +477,7 @@ subroutine grid_mechanical_FEM_restartWrite call HDF5_write(C_volAvgLastInc,groupHandle,'C_volAvgLastInc',.false.) call HDF5_closeGroup(groupHandle) call HDF5_closeFile(fileHandle) - endif + end if call DMDAVecRestoreArrayF90(mechanical_grid,solution_current,u,err_PETSc) CHKERRQ(err_PETSc) @@ -517,7 +517,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,e reason = -1 else reason = 0 - endif + end if print'(/,1x,a)', '... reporting .............................................................' print'(/,1x,a,f12.2,a,es8.2,a,es9.2,a)', 'error divergence = ', & @@ -567,7 +567,7 @@ subroutine formResidual(da_local,x_local, & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', & 'deformation gradient aim =', transpose(F_aim) flush(IO_STDOUT) - endif newIteration + end if newIteration !-------------------------------------------------------------------------------------------------- ! get deformation gradient @@ -578,9 +578,9 @@ subroutine formResidual(da_local,x_local, & do kk = -1, 0; do jj = -1, 0; do ii = -1, 0 ctr = ctr + 1 x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) - enddo; enddo; enddo + end do; end do; end do F(1:3,1:3,i,j,k-cells3Offset) = params%rotation_BC%rotate(F_aim,active=.true.) + transpose(matmul(BMat,x_elem)) - enddo; enddo; enddo + end do; end do; end do call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,err_PETSc) CHKERRQ(err_PETSc) @@ -590,7 +590,7 @@ subroutine formResidual(da_local,x_local, & P_av,C_volAvg,devNull, & F,params%Delta_t,params%rotation_BC) call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1_MPI_INTEGER_KIND,MPI_LOGICAL,MPI_LOR,MPI_COMM_WORLD,err_MPI) - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' !-------------------------------------------------------------------------------------------------- ! stress BC handling @@ -611,7 +611,7 @@ subroutine formResidual(da_local,x_local, & do kk = -1, 0; do jj = -1, 0; do ii = -1, 0 ctr = ctr + 1 x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) - enddo; enddo; enddo + end do; end do; end do ele = ele + 1 f_elem = matmul(transpose(BMat),transpose(P_current(1:3,1:3,i,j,k-cells3Offset)))*detJ + & matmul(HGMat,x_elem)*(homogenization_dPdF(1,1,1,1,ele) + & @@ -621,8 +621,8 @@ subroutine formResidual(da_local,x_local, & do kk = -1, 0; do jj = -1, 0; do ii = -1, 0 ctr = ctr + 1 r(0:2,i+ii,j+jj,k+kk) = r(0:2,i+ii,j+jj,k+kk) + f_elem(ctr,1:3) - enddo; enddo; enddo - enddo; enddo; enddo + end do; end do; end do + end do; end do; end do call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,err_PETSc) CHKERRQ(err_PETSc) call DMDAVecRestoreArrayF90(da_local,f_local,r,err_PETSc) @@ -696,7 +696,7 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc) col(MatStencil_j,ctr+16) = j+jj col(MatStencil_k,ctr+16) = k+kk col(MatStencil_c,ctr+16) = 2 - enddo; enddo; enddo + end do; end do; end do row = col ce = ce + 1 K_ele = 0.0_pReal @@ -715,7 +715,7 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc) shape=[3,3,3,3], order=[2,1,4,3]),shape=[9,9]),BMatFull))*detJ call MatSetValuesStencil(Jac,24_pPETScInt,row,24_pPetscInt,col,K_ele,ADD_VALUES,err_PETSc) CHKERRQ(err_PETSc) - enddo; enddo; enddo + end do; end do; end do call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,err_PETSc) CHKERRQ(err_PETSc) call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,err_PETSc) @@ -739,7 +739,7 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,err_PETSc) do k = cells3Offset+1, cells3Offset+cells3; do j = 1, cells(2); do i = 1, cells(1) ce = ce + 1 x_scal(0:2,i-1,j-1,k-1) = discretization_IPcoords(1:3,ce) - enddo; enddo; enddo + end do; end do; end do call DMDAVecRestoreArrayF90(da_local,coordinates,x_scal,err_PETSc) CHKERRQ(err_PETSc) ! initialize to undeformed coordinates (ToDo: use ip coordinates) call MatNullSpaceCreateRigidBody(coordinates,matnull,err_PETSc) diff --git a/src/grid/grid_thermal_spectral.f90 b/src/grid/grid_thermal_spectral.f90 index 063028ee1..8932a3adc 100644 --- a/src/grid/grid_thermal_spectral.f90 +++ b/src/grid/grid_thermal_spectral.f90 @@ -281,7 +281,7 @@ end subroutine grid_thermal_spectral_forward !-------------------------------------------------------------------------------------------------- -!> @brief Write current solver and constitutive data for restart to file +!> @brief Write current solver and constitutive data for restart to file. !-------------------------------------------------------------------------------------------------- subroutine grid_thermal_spectral_restartWrite @@ -313,7 +313,7 @@ end subroutine grid_thermal_spectral_restartWrite !-------------------------------------------------------------------------------------------------- -!> @brief forms the spectral thermal residual vector +!> @brief Construct the residual vector. !-------------------------------------------------------------------------------------------------- subroutine formResidual(residual_subdomain,x_scal,r,dummy,err_PETSc) @@ -354,7 +354,7 @@ end subroutine formResidual !-------------------------------------------------------------------------------------------------- -!> @brief update reference viscosity and conductivity +!> @brief Update reference viscosity and conductivity. !-------------------------------------------------------------------------------------------------- subroutine updateReference() diff --git a/src/grid/spectral_utilities.f90 b/src/grid/spectral_utilities.f90 index 7947dc788..22325c479 100644 --- a/src/grid/spectral_utilities.f90 +++ b/src/grid/spectral_utilities.f90 @@ -120,8 +120,8 @@ module spectral_utilities utilities_GreenConvolution, & utilities_divergenceRMS, & utilities_curlRMS, & - utilities_ScalarGradient, & - utilities_VectorDivergence, & + utilities_scalarGradient, & + utilities_vectorDivergence, & utilities_maskedCompliance, & utilities_constitutiveResponse, & utilities_calculateRate, & @@ -577,9 +577,6 @@ real(pReal) function utilities_divergenceRMS(tensorField) complex(pReal), dimension(3) :: rescaledGeom - print'(/,1x,a)', '... calculating divergence ................................................' - flush(IO_STDOUT) - tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = tensorField call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) @@ -628,9 +625,6 @@ real(pReal) function utilities_curlRMS(tensorField) complex(pReal), dimension(3) :: rescaledGeom - print'(/,1x,a)', '... calculating curl ......................................................' - flush(IO_STDOUT) - tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,1:cells(2),1:cells3) = 0.0_pReal tensorField_real(1:3,1:3,1:cells(1), 1:cells(2),1:cells3) = tensorField call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) @@ -757,7 +751,7 @@ end function utilities_maskedCompliance !-------------------------------------------------------------------------------------------------- !> @brief Calculate gradient of scalar field. !-------------------------------------------------------------------------------------------------- -function utilities_ScalarGradient(field) result(grad) +function utilities_scalarGradient(field) result(grad) real(pReal), intent(in), dimension( cells(1),cells(2),cells3) :: field real(pReal), dimension(3,cells(1),cells(2),cells3) :: grad @@ -769,18 +763,18 @@ function utilities_ScalarGradient(field) result(grad) scalarField_real(1:cells(1), 1:cells(2),1:cells3) = field call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) do j = 1, cells2; do k = 1, cells(3); do i = 1,cells1Red - vectorField_fourier(1:3,i,k,j) = scalarField_fourier(i,k,j)*xi1st(1:3,i,k,j) ! ToDo: no -conjg? + vectorField_fourier(1:3,i,k,j) = scalarField_fourier(i,k,j)*xi1st(1:3,i,k,j) end do; end do; end do call fftw_mpi_execute_dft_c2r(planVectorBack,vectorField_fourier,vectorField_real) grad = vectorField_real(1:3,1:cells(1),1:cells(2),1:cells3)*wgt -end function utilities_ScalarGradient +end function utilities_scalarGradient !-------------------------------------------------------------------------------------------------- !> @brief Calculate divergence of vector field. !-------------------------------------------------------------------------------------------------- -function utilities_VectorDivergence(field) result(div) +function utilities_vectorDivergence(field) result(div) real(pReal), intent(in), dimension(3,cells(1),cells(2),cells3) :: field real(pReal), dimension( cells(1),cells(2),cells3) :: div @@ -790,11 +784,11 @@ function utilities_VectorDivergence(field) result(div) vectorField_real(1:3,1:cells(1), 1:cells(2),1:cells3) = field call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier) scalarField_fourier(1:cells1Red,1:cells(3),1:cells2) = sum(vectorField_fourier(1:3,1:cells1Red,1:cells(3),1:cells2) & - *conjg(-xi1st),1) + *conjg(-xi1st),1) ! ToDo: use "xi1st" instead of "conjg(-xi1st)"? call fftw_mpi_execute_dft_c2r(planScalarBack,scalarField_fourier,scalarField_real) div = scalarField_real(1:cells(1),1:cells(2),1:cells3)*wgt -end function utilities_VectorDivergence +end function utilities_vectorDivergence !-------------------------------------------------------------------------------------------------- @@ -936,7 +930,7 @@ end function utilities_forwardField !-------------------------------------------------------------------------------------------------- -!> @brief calculates filter for fourier convolution depending on type given in numerics.config +!> @brief Calculate Filter for Fourier convolution. !> @details this is the full operator to calculate derivatives, i.e. 2 \pi i k for the ! standard approach !-------------------------------------------------------------------------------------------------- @@ -1133,43 +1127,116 @@ subroutine selfTest() real(pReal), allocatable, dimension(:,:,:,:,:) :: tensorField_real_ real(pReal), allocatable, dimension(:,:,:,:) :: vectorField_real_ real(pReal), allocatable, dimension(:,:,:) :: scalarField_real_ + real(pReal), dimension(3,3) :: tensorSum + real(pReal), dimension(3) :: vectorSum + real(pReal) :: scalarSum + real(pReal), dimension(3,3) :: r + integer(MPI_INTEGER_KIND) :: err_MPI call random_number(tensorField_real) tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal tensorField_real_ = tensorField_real call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) - if (worldsize==1) then - if (any(dNeq(sum(sum(sum(tensorField_real_,dim=5),dim=4),dim=3)/tensorField_fourier(:,:,1,1,1)%re,1.0_pReal,1.0e-12_pReal))) & - error stop 'tensorField avg' - endif + call MPI_Allreduce(sum(sum(sum(tensorField_real_,dim=5),dim=4),dim=3),tensorSum,9_MPI_INTEGER_KIND, & + MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (worldrank==0) then + if (any(dNeq(tensorSum/tensorField_fourier(:,:,1,1,1)%re,1.0_pReal,1.0e-12_pReal))) & + error stop 'mismatch avg tensorField FFT <-> real' + end if call fftw_mpi_execute_dft_c2r(planTensorBack,tensorField_fourier,tensorField_real) tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal - if (maxval(abs(tensorField_real_ - tensorField_real*wgt))>5.0e-15_pReal) error stop 'tensorField' + if (maxval(abs(tensorField_real_ - tensorField_real*wgt))>5.0e-15_pReal) & + error stop 'mismatch tensorField FFT/invFFT <-> real' call random_number(vectorField_real) vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal vectorField_real_ = vectorField_real call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier) - if (worldsize==1) then - if (any(dNeq(sum(sum(sum(vectorField_real_,dim=4),dim=3),dim=2)/vectorField_fourier(:,1,1,1)%re,1.0_pReal,1.0e-12_pReal))) & - error stop 'vector avg' - endif + call MPI_Allreduce(sum(sum(sum(vectorField_real_,dim=4),dim=3),dim=2),vectorSum,3_MPI_INTEGER_KIND, & + MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (worldrank==0) then + if (any(dNeq(vectorSum/vectorField_fourier(:,1,1,1)%re,1.0_pReal,1.0e-12_pReal))) & + error stop 'mismatch avg vectorField FFT <-> real' + end if call fftw_mpi_execute_dft_c2r(planVectorBack,vectorField_fourier,vectorField_real) vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal - if (maxval(abs(vectorField_real_ - vectorField_real*wgt))>5.0e-15_pReal) error stop 'vectorField' + if (maxval(abs(vectorField_real_ - vectorField_real*wgt))>5.0e-15_pReal) & + error stop 'mismatch vectorField FFT/invFFT <-> real' call random_number(scalarField_real) scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal scalarField_real_ = scalarField_real call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) - if (worldsize==1) then - if (dNeq(sum(sum(sum(scalarField_real_,dim=3),dim=2),dim=1)/scalarField_fourier(1,1,1)%re,1.0_pReal,1.0e-12_pReal)) & - error stop 'scalar avg' - endif + call MPI_Allreduce(sum(sum(sum(scalarField_real_,dim=3),dim=2),dim=1),scalarSum,1_MPI_INTEGER_KIND, & + MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI) + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (worldrank==0) then + if (dNeq(scalarSum/scalarField_fourier(1,1,1)%re,1.0_pReal,1.0e-12_pReal)) & + error stop 'mismatch avg scalarField FFT <-> real' + end if call fftw_mpi_execute_dft_c2r(planScalarBack,scalarField_fourier,scalarField_real) scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal - if (maxval(abs(scalarField_real_ - scalarField_real*wgt))>5.0e-15_pReal) error stop 'scalarField' + if (maxval(abs(scalarField_real_ - scalarField_real*wgt))>5.0e-15_pReal) & + error stop 'mismatch scalarField FFT/invFFT <-> real' + + call random_number(r) + call MPI_Bcast(r,9_MPI_INTEGER_KIND,MPI_DOUBLE,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + + scalarField_real_ = r(1,1) + if (maxval(abs(utilities_scalarGradient(scalarField_real_)))>5.0e-9_pReal) error stop 'non-zero grad(const)' + + vectorField_real_ = spread(spread(spread(r(1,:),2,cells(1)),3,cells(2)),4,cells3) + if (maxval(abs(utilities_vectorDivergence(vectorField_real_)))>5.0e-9_pReal) error stop 'non-zero div(const)' + + tensorField_real_ = spread(spread(spread(r,3,cells(1)),4,cells(2)),5,cells3) + if (utilities_divergenceRMS(tensorField_real_)>5.0e-14_pReal) error stop 'non-zero RMS div(const)' + if (utilities_curlRMS(tensorField_real_)>5.0e-14_pReal) error stop 'non-zero RMS curl(const)' + + if (cells(1) > 2 .and. spectral_derivative_ID == DERIVATIVE_CONTINUOUS_ID) then + scalarField_real_ = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) + vectorField_real_ = utilities_scalarGradient(scalarField_real_)/TAU*geomSize(1) + scalarField_real_ = -spread(spread(planeSine (cells(1)),2,cells(2)),3,cells3) + if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-14_pReal) error stop 'grad cosine' + scalarField_real_ = spread(spread(planeSine (cells(1)),2,cells(2)),3,cells3) + vectorField_real_ = utilities_scalarGradient(scalarField_real_)/TAU*geomSize(1) + scalarField_real_ = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) + if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-14_pReal) error stop 'grad sine' + + vectorField_real_(2:3,:,:,:) = 0.0_pReal + vectorField_real_(1,:,:,:) = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) + scalarField_real_ = utilities_vectorDivergence(vectorField_real_)/TAU*geomSize(1) + vectorField_real_(1,:,:,:) =-spread(spread(planeSine( cells(1)),2,cells(2)),3,cells3) + if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-14_pReal) error stop 'div cosine' + vectorField_real_(2:3,:,:,:) = 0.0_pReal + vectorField_real_(1,:,:,:) = spread(spread(planeSine( cells(1)),2,cells(2)),3,cells3) + scalarField_real_ = utilities_vectorDivergence(vectorField_real_)/TAU*geomSize(1) + vectorField_real_(1,:,:,:) = spread(spread(planeCosine(cells(1)),2,cells(2)),3,cells3) + if (maxval(abs(vectorField_real_(1,:,:,:) - scalarField_real_))>5.0e-14_pReal) error stop 'div sine' + end if + + contains + + function planeCosine(n) + integer, intent(in) :: n + real(pReal), dimension(n) :: planeCosine + + + planeCosine = cos(real(math_range(n),pReal)/real(n,pReal)*TAU-TAU/real(n*2,pReal)) + + end function planeCosine + + function planeSine(n) + integer, intent(in) :: n + real(pReal), dimension(n) :: planeSine + + + planeSine = sin(real(math_range(n),pReal)/real(n,pReal)*TAU-TAU/real(n*2,pReal)) + + end function planeSine end subroutine selfTest diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 6f6270403..3474e497b 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -245,8 +245,8 @@ subroutine homogenization_mechanical_response(Delta_t,cell_start,cell_end) call phase_restore(ce,.false.) ! wrong name (is more a forward function) - if(homogState(ho)%sizeState > 0) homogState(ho)%state(:,en) = homogState(ho)%state0(:,en) - if(damageState_h(ho)%sizeState > 0) damageState_h(ho)%state(:,en) = damageState_h(ho)%state0(:,en) + if (homogState(ho)%sizeState > 0) homogState(ho)%state(:,en) = homogState(ho)%state0(:,en) + if (damageState_h(ho)%sizeState > 0) damageState_h(ho)%state(:,en) = damageState_h(ho)%state0(:,en) call damage_partition(ce) doneAndHappy = [.false.,.true.] @@ -381,7 +381,7 @@ subroutine homogenization_forward do ho = 1, size(material_name_homogenization) homogState (ho)%state0 = homogState (ho)%state - if(damageState_h(ho)%sizeState > 0) & + if (damageState_h(ho)%sizeState > 0) & damageState_h(ho)%state0 = damageState_h(ho)%state end do @@ -406,6 +406,9 @@ subroutine homogenization_restartWrite(fileHandle) call HDF5_write(homogState(ho)%state,groupHandle(2),'omega_mechanical') ! ToDo: should be done by mech + if (damageState_h(ho)%sizeState > 0) & + call HDF5_write(damageState_h(ho)%state,groupHandle(2),'omega_damage') ! ToDo: should be done by mech + call HDF5_closeGroup(groupHandle(2)) end do @@ -433,6 +436,9 @@ subroutine homogenization_restartRead(fileHandle) call HDF5_read(homogState(ho)%state0,groupHandle(2),'omega_mechanical') ! ToDo: should be done by mech + if (damageState_h(ho)%sizeState > 0) & + call HDF5_read(damageState_h(ho)%state0,groupHandle(2),'omega_damage') ! ToDo: should be done by mech + call HDF5_closeGroup(groupHandle(2)) end do diff --git a/src/homogenization_damage.f90 b/src/homogenization_damage.f90 index dd438b3c4..f2b585a72 100644 --- a/src/homogenization_damage.f90 +++ b/src/homogenization_damage.f90 @@ -80,11 +80,15 @@ module subroutine damage_partition(ce) integer, intent(in) :: ce real(pReal) :: phi + integer :: co - if(damageState_h(material_homogenizationID(ce))%sizeState < 1) return + if (damageState_h(material_homogenizationID(ce))%sizeState < 1) return phi = damagestate_h(material_homogenizationID(ce))%state(1,material_homogenizationEntry(ce)) - call phase_set_phi(phi,1,ce) + do co = 1, homogenization_Nconstituents(material_homogenizationID(ce)) + call phase_set_phi(phi,co,ce) + end do + end subroutine damage_partition diff --git a/src/materialpoint.f90 b/src/materialpoint.f90 index 5b8b690e0..8ce0e15a1 100644 --- a/src/materialpoint.f90 +++ b/src/materialpoint.f90 @@ -18,6 +18,7 @@ module materialpoint use math use rotations use polynomials + use tables use lattice use material use phase @@ -40,37 +41,38 @@ contains !-------------------------------------------------------------------------------------------------- !> @brief Initialize all modules. !-------------------------------------------------------------------------------------------------- -subroutine materialpoint_initAll +subroutine materialpoint_initAll() - call parallelization_init - call CLI_init ! Spectral and FEM interface to commandline - call signals_init - call prec_init - call IO_init + call parallelization_init() + call CLI_init() ! grid and mesh commandline interface + call signals_init() + call prec_init() + call IO_init() #if defined(MESH) - call FEM_quadrature_init + call FEM_quadrature_init() #elif defined(GRID) - call base64_init + call base64_init() #endif - call YAML_types_init - call YAML_parse_init - call HDF5_utilities_init + call YAML_types_init() + call YAML_parse_init() + call HDF5_utilities_init() call results_init(restart=CLI_restartInc>0) - call config_init - call math_init - call rotations_init - call polynomials_init - call lattice_init + call config_init() + call math_init() + call rotations_init() + call polynomials_init() + call tables_init() + call lattice_init() #if defined(MESH) call discretization_mesh_init(restart=CLI_restartInc>0) #elif defined(GRID) call discretization_grid_init(restart=CLI_restartInc>0) #endif call material_init(restart=CLI_restartInc>0) - call phase_init - call homogenization_init - call materialpoint_init - call config_deallocate + call phase_init() + call homogenization_init() + call materialpoint_init() + call config_deallocate() end subroutine materialpoint_initAll @@ -78,7 +80,7 @@ end subroutine materialpoint_initAll !-------------------------------------------------------------------------------------------------- !> @brief Read restart information if needed. !-------------------------------------------------------------------------------------------------- -subroutine materialpoint_init +subroutine materialpoint_init() integer(HID_T) :: fileHandle @@ -95,7 +97,7 @@ subroutine materialpoint_init call phase_restartRead(fileHandle) call HDF5_closeFile(fileHandle) - endif + end if end subroutine materialpoint_init @@ -103,7 +105,7 @@ end subroutine materialpoint_init !-------------------------------------------------------------------------------------------------- !> @brief Write restart information. !-------------------------------------------------------------------------------------------------- -subroutine materialpoint_restartWrite +subroutine materialpoint_restartWrite() integer(HID_T) :: fileHandle @@ -123,10 +125,10 @@ end subroutine materialpoint_restartWrite !-------------------------------------------------------------------------------------------------- !> @brief Forward data for new time increment. !-------------------------------------------------------------------------------------------------- -subroutine materialpoint_forward +subroutine materialpoint_forward() - call homogenization_forward - call phase_forward + call homogenization_forward() + call phase_forward() end subroutine materialpoint_forward @@ -139,13 +141,13 @@ subroutine materialpoint_results(inc,time) integer, intent(in) :: inc real(pReal), intent(in) :: time - call results_openJobFile + call results_openJobFile() call results_addIncrement(inc,time) - call phase_results - call homogenization_results - call discretization_results - call results_finalizeIncrement - call results_closeJobFile + call phase_results() + call homogenization_results() + call discretization_results() + call results_finalizeIncrement() + call results_closeJobFile() end subroutine materialpoint_results diff --git a/src/mesh/DAMASK_mesh.f90 b/src/mesh/DAMASK_mesh.f90 index 08e2940b3..f10be4d0c 100644 --- a/src/mesh/DAMASK_mesh.f90 +++ b/src/mesh/DAMASK_mesh.f90 @@ -311,7 +311,7 @@ program DAMASK_mesh write(statUnit,*) totalIncsCounter, time, cutBackLevel, & solres%converged, solres%iterationsNeeded ! write statistics about accepted solution flush(statUnit) - endif + end if end do subStepLooping cutBackLevel = max(0, cutBackLevel - 1) ! try half number of subincs next inc diff --git a/src/mesh/FEM_quadrature.f90 b/src/mesh/FEM_quadrature.f90 index a2217847a..dde762eda 100644 --- a/src/mesh/FEM_quadrature.f90 +++ b/src/mesh/FEM_quadrature.f90 @@ -365,16 +365,16 @@ subroutine selfTest do o = lbound(FEM_quadrature_weights(d,:),1), ubound(FEM_quadrature_weights(d,:),1) if (dNeq(sum(FEM_quadrature_weights(d,o)%p),1.0_pReal,5e-15_pReal)) & error stop 'quadrature weights' - enddo - enddo + end do + end do do d = lbound(FEM_quadrature_points,1), ubound(FEM_quadrature_points,1) do o = lbound(FEM_quadrature_points(d,:),1), ubound(FEM_quadrature_points(d,:),1) n = size(FEM_quadrature_points(d,o)%p,1)/d if (any(dNeq(sum(reshape(FEM_quadrature_points(d,o)%p,[d,n]),2),-real(n,pReal)/w(d),1.e-14_pReal))) & error stop 'quadrature points' - enddo - enddo + end do + end do end subroutine selfTest diff --git a/src/mesh/FEM_utilities.f90 b/src/mesh/FEM_utilities.f90 index de924e9ec..5307fcb85 100644 --- a/src/mesh/FEM_utilities.f90 +++ b/src/mesh/FEM_utilities.f90 @@ -120,14 +120,14 @@ subroutine FEM_utilities_init debug_mesh => config_debug%get_dict('mesh',defaultVal=emptyDict) debugPETSc = debug_mesh%contains('PETSc') - if(debugPETSc) print'(3(/,1x,a),/)', & + if (debugPETSc) print'(3(/,1x,a),/)', & 'Initializing PETSc with debug options: ', & trim(PETScDebug), & 'add more using the "PETSc_options" keyword in numerics.yaml' flush(IO_STDOUT) call PetscOptionsClear(PETSC_NULL_OPTIONS,err_PETSc) CHKERRQ(err_PETSc) - if(debugPETSc) call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(PETSCDEBUG),err_PETSc) + if (debugPETSc) call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(PETSCDEBUG),err_PETSc) CHKERRQ(err_PETSc) call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-mechanical_snes_type newtonls & &-mechanical_snes_linesearch_type cp -mechanical_snes_ksp_ew & diff --git a/src/mesh/discretization_mesh.f90 b/src/mesh/discretization_mesh.f90 index c645edc95..abda549b7 100644 --- a/src/mesh/discretization_mesh.f90 +++ b/src/mesh/discretization_mesh.f90 @@ -140,7 +140,7 @@ subroutine discretization_mesh_init(restart) call DMClone(globalMesh,geomMesh,err_PETSc) else call DMPlexDistribute(globalMesh,0_pPETSCINT,sf,geomMesh,err_PETSc) - endif + end if CHKERRQ(err_PETSc) allocate(mesh_boundaries(mesh_Nboundaries), source = 0_pPETSCINT) @@ -154,7 +154,7 @@ subroutine discretization_mesh_init(restart) mesh_boundaries(1:nFaceSets) = pFaceSets CHKERRQ(err_PETSc) call ISRestoreIndicesF90(faceSetIS,pFaceSets,err_PETSc) - endif + end if call MPI_Bcast(mesh_boundaries,mesh_Nboundaries,MPI_INTEGER,0_MPI_INTEGER_KIND,MPI_COMM_WORLD,err_MPI) if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' @@ -182,7 +182,7 @@ subroutine discretization_mesh_init(restart) do j = 1, mesh_NcpElems call DMGetLabelValue(geomMesh,'Cell Sets',j-1,materialAt(j),err_PETSc) CHKERRQ(err_PETSc) - enddo + end do materialAt = materialAt + 1_pPETSCINT if (debug_element < 1 .or. debug_element > mesh_NcpElems) call IO_error(602,ext_msg='element') @@ -222,7 +222,7 @@ subroutine mesh_FEM_build_ipVolumes(dimPlex) call DMPlexComputeCellGeometryFVM(geomMesh,cell,vol,pCent,pNorm,err_PETSc) CHKERRQ(err_PETSc) mesh_ipVolume(:,cell+1) = vol/real(mesh_maxNips,pReal) - enddo + end do end subroutine mesh_FEM_build_ipVolumes @@ -258,11 +258,11 @@ subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints) do dirJ = 1_pPETSCINT, dimPlex mesh_ipCoordinates(dirI,qPt,cell+1) = mesh_ipCoordinates(dirI,qPt,cell+1) + & pCellJ((dirI-1)*dimPlex+dirJ)*(qPoints(qOffset+dirJ) + 1.0_pReal) - enddo - enddo + end do + end do qOffset = qOffset + dimPlex - enddo - enddo + end do + end do end subroutine mesh_FEM_build_ipCoordinates diff --git a/src/mesh/mesh_mech_FEM.f90 b/src/mesh/mesh_mech_FEM.f90 index 703098e44..f612968fe 100644 --- a/src/mesh/mesh_mech_FEM.f90 +++ b/src/mesh/mesh_mech_FEM.f90 @@ -199,11 +199,11 @@ subroutine FEM_mechanical_init(fieldBC) CHKERRQ(err_PETSc) call PetscSectionGetDof(section,cellStart,pnumDof(topologDim),err_PETSc) CHKERRQ(err_PETSc) - enddo + end do numBC = 0 do field = 1, dimPlex; do faceSet = 1, mesh_Nboundaries if (fieldBC%componentBC(field)%Mask(faceSet)) numBC = numBC + 1 - enddo; enddo + end do; end do allocate(pbcField(numBC), source=0_pPETSCINT) allocate(pbcComps(numBC)) allocate(pbcPoints(numBC)) @@ -229,9 +229,9 @@ subroutine FEM_mechanical_init(fieldBC) else call ISCreateGeneral(PETSC_COMM_WORLD,0_pPETSCINT,[0_pPETSCINT],PETSC_COPY_VALUES,pbcPoints(numBC),err_PETSc) CHKERRQ(err_PETSc) - endif - endif - enddo; enddo + end if + end if + end do; end do call DMPlexCreateSection(mechanical_mesh,nolabel,pNumComp,pNumDof, & numBC,pBcField,pBcComps,pBcPoints,PETSC_NULL_IS,section,err_PETSc) CHKERRQ(err_PETSc) @@ -240,7 +240,7 @@ subroutine FEM_mechanical_init(fieldBC) do faceSet = 1, numBC call ISDestroy(pbcPoints(faceSet),err_PETSc) CHKERRQ(err_PETSc) - enddo + end do !-------------------------------------------------------------------------------------------------- ! initialize solver specific parts of PETSc @@ -299,11 +299,11 @@ subroutine FEM_mechanical_init(fieldBC) call PetscQuadratureGetData(functional,dimPlex,nc,nNodalPoints,nodalPointsP,nodalWeightsP,err_PETSc) CHKERRQ(err_PETSc) x_scal(basis+1:basis+dimPlex) = pV0 + matmul(transpose(cellJMat),nodalPointsP + 1.0_pReal) - enddo + end do px_scal => x_scal call DMPlexVecSetClosure(mechanical_mesh,section,solution_local,cell,px_scal,5,err_PETSc) CHKERRQ(err_PETSc) - enddo + end do call utilities_constitutiveResponse(0.0_pReal,devNull,.true.) end subroutine FEM_mechanical_init @@ -348,7 +348,7 @@ type(tSolutionState) function FEM_mechanical_solution( & FEM_mechanical_solution%converged = .true. call SNESGetIterationNumber(mechanical_snes,FEM_mechanical_solution%iterationsNeeded,err_PETSc) CHKERRQ(err_PETSc) - endif + end if print'(/,1x,a)', '===========================================================================' flush(IO_STDOUT) @@ -409,9 +409,9 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc 0.0_pReal,params%fieldBC%componentBC(field)%Value(face),params%timeinc) call ISDestroy(bcPoints,err_PETSc) CHKERRQ(err_PETSc) - endif - endif - enddo; enddo + end if + end if + end do; end do !-------------------------------------------------------------------------------------------------- ! evaluate field derivatives @@ -433,10 +433,10 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = & matmul(IcellJMat,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex)) - enddo - enddo + end do + end do homogenization_F(1:dimPlex,1:dimPlex,m) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1]) - enddo + end do if (num%BBarStabilisation) then detFAvg = math_det33(sum(homogenization_F(1:3,1:3,cell*nQuadrature+1:(cell+1)*nQuadrature),dim=3)/real(nQuadrature,pReal)) do qPt = 0, nQuadrature-1 @@ -444,11 +444,11 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc homogenization_F(1:dimPlex,1:dimPlex,m) = homogenization_F(1:dimPlex,1:dimPlex,m) & * (detFAvg/math_det33(homogenization_F(1:3,1:3,m)))**(1.0_pReal/real(dimPlex,pReal)) - enddo - endif + end do + end if call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc) CHKERRQ(err_PETSc) - enddo + end do !-------------------------------------------------------------------------------------------------- ! evaluate constitutive response @@ -475,20 +475,20 @@ subroutine FEM_mechanical_formResidual(dm_local,xx_local,f_local,dummy,err_PETSc i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = & matmul(IcellJMat,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex)) - enddo - enddo + end do + end do f_scal = f_scal & + matmul(transpose(BMat), & reshape(transpose(homogenization_P(1:dimPlex,1:dimPlex,m)), & shape=[dimPlex*dimPlex]))*qWeights(qPt+1_pPETSCINT) - enddo + end do f_scal = f_scal*abs(detJ) pf_scal => f_scal call DMPlexVecSetClosure(dm_local,section,f_local,cell,pf_scal,ADD_VALUES,err_PETSc) CHKERRQ(err_PETSc) call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc) CHKERRQ(err_PETSc) - enddo + end do call DMRestoreLocalVector(dm_local,x_local,err_PETSc) CHKERRQ(err_PETSc) @@ -559,9 +559,9 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P 0.0_pReal,params%fieldBC%componentBC(field)%Value(face),params%timeinc) call ISDestroy(bcPoints,err_PETSc) CHKERRQ(err_PETSc) - endif - endif - enddo; enddo + end if + end if + end do; end do call DMPlexGetHeightStratum(dm_local,0_pPETSCINT,cellStart,cellEnd,err_PETSc) CHKERRQ(err_PETSc) do cell = cellStart, cellEnd-1 !< loop over all elements @@ -583,8 +583,8 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = & matmul(reshape(pInvcellJ,[dimPlex,dimPlex]),basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex)) - enddo - enddo + end do + end do MatA = matmul(reshape(reshape(homogenization_dPdF(1:dimPlex,1:dimPlex,1:dimPlex,1:dimPlex,m), & shape=[dimPlex,dimPlex,dimPlex,dimPlex], order=[2,1,4,3]), & shape=[dimPlex*dimPlex,dimPlex*dimPlex]),BMat)*qWeights(qPt+1_pPETSCINT) @@ -602,8 +602,8 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P BMatAvg = BMatAvg + BMat else K_eA = K_eA + matmul(transpose(BMat),MatA) - endif - enddo + end if + end do if (num%BBarStabilisation) then FInv = math_inv33(FAvg) K_e = K_eA*math_det33(FAvg/real(nQuadrature,pReal))**(1.0_pReal/real(dimPlex,pReal)) + & @@ -612,7 +612,7 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P K_eB)/real(dimPlex,pReal) else K_e = K_eA - endif + end if K_e = (K_e + eps*math_eye(int(cellDof))) * abs(detJ) #ifndef __INTEL_COMPILER pK_e(1:cellDOF**2) => K_e @@ -624,7 +624,7 @@ subroutine FEM_mechanical_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,err_P CHKERRQ(err_PETSc) call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc) CHKERRQ(err_PETSc) - enddo + end do call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,err_PETSc) CHKERRQ(err_PETSc) call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,err_PETSc) @@ -704,9 +704,9 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC) 0.0_pReal,fieldBC%componentBC(field)%Value(face),timeinc_old) call ISDestroy(bcPoints,err_PETSc) CHKERRQ(err_PETSc) - endif - endif - enddo; enddo + end if + end if + end do; end do call DMRestoreLocalVector(dm_local,x_local,err_PETSc) CHKERRQ(err_PETSc) @@ -716,7 +716,7 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC) CHKERRQ(err_PETSc) call VecScale(solution_rate,timeinc_old**(-1),err_PETSc) CHKERRQ(err_PETSc) - endif + end if call VecCopy(solution_rate,solution,err_PETSc) CHKERRQ(err_PETSc) call VecScale(solution,timeinc,err_PETSc) @@ -800,7 +800,7 @@ subroutine FEM_mechanical_updateCoords() call DMPlexGetPointLocal(dm_local, p, s, e, err_PETSc) CHKERRQ(err_PETSc) nodeCoords(1:dimPlex,p)=nodeCoords_linear(s+1:e) - enddo + end do call discretization_setNodeCoords(nodeCoords) call VecRestoreArrayF90(x_local,nodeCoords_linear,err_PETSc) @@ -827,9 +827,9 @@ subroutine FEM_mechanical_updateCoords() x_scal(nOffset+1:nOffset+dimPlex)) q = q+dimPlex nOffset = nOffset+dimPlex - enddo - enddo - enddo + end do + end do + end do call DMPlexVecRestoreClosure(dm_local,section,x_local,c,x_scal,err_PETSc) CHKERRQ(err_PETSc) end do diff --git a/src/parallelization.f90 b/src/parallelization.f90 index 2934cf65c..04a852a15 100644 --- a/src/parallelization.f90 +++ b/src/parallelization.f90 @@ -53,7 +53,7 @@ contains !-------------------------------------------------------------------------------------------------- !> @brief Initialize shared memory (openMP) and distributed memory (MPI) parallelization. !-------------------------------------------------------------------------------------------------- -subroutine parallelization_init +subroutine parallelization_init() integer(MPI_INTEGER_KIND) :: err_MPI, typeSize, version, subversion, devNull character(len=4) :: rank_str @@ -136,7 +136,7 @@ subroutine parallelization_init error stop 'Mismatch between MPI_DOUBLE and DAMASK pReal' !$ call get_environment_variable(name='OMP_NUM_THREADS',value=NumThreadsString,STATUS=got_env) -!$ if(got_env /= 0) then +!$ if (got_env /= 0) then !$ print'(1x,a)', 'Could not get $OMP_NUM_THREADS, using default' !$ OMP_NUM_THREADS = 4_pI32 !$ else diff --git a/src/phase.f90 b/src/phase.f90 index fdafd8f35..f7088b892 100644 --- a/src/phase.f90 +++ b/src/phase.f90 @@ -9,6 +9,7 @@ module phase use math use rotations use polynomials + use tables use IO use config use material @@ -160,6 +161,11 @@ module phase integer, intent(in) :: ph end subroutine thermal_restartWrite + module subroutine damage_restartWrite(groupHandle,ph) + integer(HID_T), intent(in) :: groupHandle + integer, intent(in) :: ph + end subroutine damage_restartWrite + module subroutine mechanical_restartRead(groupHandle,ph) integer(HID_T), intent(in) :: groupHandle integer, intent(in) :: ph @@ -170,6 +176,11 @@ module phase integer, intent(in) :: ph end subroutine thermal_restartRead + module subroutine damage_restartRead(groupHandle,ph) + integer(HID_T), intent(in) :: groupHandle + integer, intent(in) :: ph + end subroutine damage_restartRead + module function mechanical_S(ph,en) result(S) integer, intent(in) :: ph,en real(pReal), dimension(3,3) :: S @@ -674,6 +685,7 @@ subroutine phase_restartWrite(fileHandle) call mechanical_restartWrite(groupHandle(2),ph) call thermal_restartWrite(groupHandle(2),ph) + call damage_restartWrite(groupHandle(2),ph) call HDF5_closeGroup(groupHandle(2)) @@ -703,6 +715,7 @@ subroutine phase_restartRead(fileHandle) call mechanical_restartRead(groupHandle(2),ph) call thermal_restartRead(groupHandle(2),ph) + call damage_restartRead(groupHandle(2),ph) call HDF5_closeGroup(groupHandle(2)) diff --git a/src/phase_damage.f90 b/src/phase_damage.f90 index 0bf13fcae..ff262bc41 100644 --- a/src/phase_damage.f90 +++ b/src/phase_damage.f90 @@ -1,6 +1,6 @@ -!---------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- !> @brief internal microstructure state for all damage sources and kinematics constitutive models -!---------------------------------------------------------------------------------------------------- +!-------------------------------------------------------------------------------------------------- submodule(phase) damage type :: tDamageParameters @@ -310,6 +310,35 @@ function integrateDamageState(Delta_t,ph,en) result(broken) end function integrateDamageState +module subroutine damage_restartWrite(groupHandle,ph) + + integer(HID_T), intent(in) :: groupHandle + integer, intent(in) :: ph + + + select case(phase_damage(ph)) + case(DAMAGE_ISOBRITTLE_ID,DAMAGE_ANISOBRITTLE_ID) + call HDF5_write(damageState(ph)%state,groupHandle,'omega_damage') + end select + +end subroutine damage_restartWrite + + +module subroutine damage_restartRead(groupHandle,ph) + + integer(HID_T), intent(in) :: groupHandle + integer, intent(in) :: ph + + + select case(phase_damage(ph)) + case(DAMAGE_ISOBRITTLE_ID,DAMAGE_ANISOBRITTLE_ID) + call HDF5_read(damageState(ph)%state0,groupHandle,'omega_damage') + end select + + +end subroutine damage_restartRead + + !---------------------------------------------------------------------------------------------- !< @brief writes damage sources results to HDF5 output file !---------------------------------------------------------------------------------------------- diff --git a/src/phase_mechanical.f90 b/src/phase_mechanical.f90 index e062bd5c0..07aee02eb 100644 --- a/src/phase_mechanical.f90 +++ b/src/phase_mechanical.f90 @@ -596,7 +596,7 @@ function integrateStateFPI(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result(b dotState_last(1:sizeDotState,1) = dotState broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) - if(broken) exit iteration + if (broken) exit iteration dotState = plastic_dotState(Delta_t,ph,en) if (any(IEEE_is_NaN(dotState))) exit iteration @@ -677,7 +677,7 @@ function integrateStateEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en) result #endif broken = plastic_deltaState(ph,en) - if(broken) return + if (broken) return broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) @@ -720,10 +720,10 @@ function integrateStateAdaptiveEuler(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en #endif broken = plastic_deltaState(ph,en) - if(broken) return + if (broken) return broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) - if(broken) return + if (broken) return dotState = plastic_dotState(Delta_t,ph,en) if (any(IEEE_is_NaN(dotState))) return @@ -852,13 +852,13 @@ function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB) #endif broken = integrateStress(F_0+(F-F_0)*Delta_t*C(stage),subFp0,subFi0,Delta_t*C(stage), ph,en) - if(broken) exit + if (broken) exit dotState = plastic_dotState(Delta_t*C(stage), ph,en) if (any(IEEE_is_NaN(dotState))) exit end do - if(broken) return + if (broken) return plastic_RKdotState(1:sizeDotState,size(B)) = dotState @@ -869,15 +869,15 @@ function integrateStateRK(F_0,F,subFp0,subFi0,subState0,Delta_t,ph,en,A,B,C,DB) plasticState(ph)%state(1:sizeDotState,en) = IEEE_FMA(dotState,Delta_t,subState0) #endif - if(present(DB)) & + if (present(DB)) & broken = .not. converged(matmul(plastic_RKdotState(1:sizeDotState,1:size(DB)),DB) * Delta_t, & plasticState(ph)%state(1:sizeDotState,en), & plasticState(ph)%atol(1:sizeDotState)) - if(broken) return + if (broken) return broken = plastic_deltaState(ph,en) - if(broken) return + if (broken) return broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) diff --git a/src/phase_mechanical_eigen_cleavageopening.f90 b/src/phase_mechanical_eigen_cleavageopening.f90 index 1bf231c2c..780ed22b2 100644 --- a/src/phase_mechanical_eigen_cleavageopening.f90 +++ b/src/phase_mechanical_eigen_cleavageopening.f90 @@ -19,7 +19,7 @@ module function damage_anisobrittle_init() result(myKinematics) myKinematics = kinematics_active2('anisobrittle') - if(count(myKinematics) == 0) return + if (count(myKinematics) == 0) return print'(/,1x,a)', '<<<+- phase:mechanical:eigen:cleavageopening init -+>>>' print'(/,a,i2)', ' # phases: ',count(myKinematics); flush(IO_STDOUT) diff --git a/src/phase_mechanical_plastic_isotropic.f90 b/src/phase_mechanical_plastic_isotropic.f90 index e755c5bba..c897c6c6d 100644 --- a/src/phase_mechanical_plastic_isotropic.f90 +++ b/src/phase_mechanical_plastic_isotropic.f90 @@ -64,7 +64,7 @@ module function plastic_isotropic_init() result(myPlasticity) myPlasticity = plastic_active('isotropic') - if(count(myPlasticity) == 0) return + if (count(myPlasticity) == 0) return print'(/,1x,a)', '<<<+- phase:mechanical:plastic:isotropic init -+>>>' print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT) @@ -77,7 +77,7 @@ module function plastic_isotropic_init() result(myPlasticity) allocate(state(phases%length)) do ph = 1, phases%length - if(.not. myPlasticity(ph)) cycle + if (.not. myPlasticity(ph)) cycle associate(prm => param(ph), stt => state(ph)) diff --git a/src/phase_mechanical_plastic_kinehardening.f90 b/src/phase_mechanical_plastic_kinehardening.f90 index 47b6a777a..692501f42 100644 --- a/src/phase_mechanical_plastic_kinehardening.f90 +++ b/src/phase_mechanical_plastic_kinehardening.f90 @@ -86,7 +86,7 @@ module function plastic_kinehardening_init() result(myPlasticity) pl myPlasticity = plastic_active('kinehardening') - if(count(myPlasticity) == 0) return + if (count(myPlasticity) == 0) return print'(/,1x,a)', '<<<+- phase:mechanical:plastic:kinehardening init -+>>>' print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT) @@ -127,7 +127,7 @@ module function plastic_kinehardening_init() result(myPlasticity) if (phase_lattice(ph) == 'cI') then a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray) - if(size(a) > 0) prm%nonSchmidActive = .true. + if (size(a) > 0) prm%nonSchmidActive = .true. prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1) prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1) else @@ -189,7 +189,7 @@ module function plastic_kinehardening_init() result(myPlasticity) stt%xi => plasticState(ph)%state(startIndex:endIndex,:) stt%xi = spread(xi_0, 2, Nmembers) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) - if(any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_sl @@ -202,7 +202,7 @@ module function plastic_kinehardening_init() result(myPlasticity) idx_dot%gamma = [startIndex,endIndex] stt%gamma => plasticState(ph)%state(startIndex:endIndex,:) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal) - if(any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' o = plasticState(ph)%offsetDeltaState startIndex = endIndex + 1 diff --git a/src/phase_mechanical_plastic_nonlocal.f90 b/src/phase_mechanical_plastic_nonlocal.f90 index 9010ac1c7..77d73aae7 100644 --- a/src/phase_mechanical_plastic_nonlocal.f90 +++ b/src/phase_mechanical_plastic_nonlocal.f90 @@ -251,7 +251,7 @@ module function plastic_nonlocal_init() result(myPlasticity) if (phase_lattice(ph) == 'cI') then a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray) - if(size(a) > 0) prm%nonSchmidActive = .true. + if (size(a) > 0) prm%nonSchmidActive = .true. prm%P_nS_pos = lattice_nonSchmidMatrix(ini%N_sl,a,+1) prm%P_nS_neg = lattice_nonSchmidMatrix(ini%N_sl,a,-1) else @@ -416,7 +416,7 @@ module function plastic_nonlocal_init() result(myPlasticity) allocate(geom(ph)%IPcoordinates(3,Nmembers)) call storeGeometry(ph) - if(plasticState(ph)%nonlocal .and. .not. allocated(IPneighborhood)) & + if (plasticState(ph)%nonlocal .and. .not. allocated(IPneighborhood)) & call IO_error(212,ext_msg='IPneighborhood does not exist') st0%rho => plasticState(ph)%state0 (0*prm%sum_N_sl+1:10*prm%sum_N_sl,:) @@ -485,7 +485,7 @@ module function plastic_nonlocal_init() result(myPlasticity) dot%gamma => plasticState(ph)%dotState (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers) del%gamma => plasticState(ph)%deltaState (10*prm%sum_N_sl + 1:11*prm%sum_N_sl,1:Nmembers) plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl ) = pl%get_asFloat('atol_gamma', defaultVal = 1.0e-6_pReal) - if(any(plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl) < 0.0_pReal)) & + if (any(plasticState(ph)%atol(10*prm%sum_N_sl+1:11*prm%sum_N_sl) < 0.0_pReal)) & extmsg = trim(extmsg)//' atol_gamma' stt%rho_forest => plasticState(ph)%state (11*prm%sum_N_sl + 1:12*prm%sum_N_sl,1:Nmembers) @@ -518,7 +518,7 @@ module function plastic_nonlocal_init() result(myPlasticity) do ph = 1, phases%length - if(.not. myPlasticity(ph)) cycle + if (.not. myPlasticity(ph)) cycle phase => phases%get_dict(ph) Nmembers = count(material_phaseID == ph) @@ -1783,6 +1783,6 @@ subroutine storeGeometry(ph) end do end do -end subroutine +end subroutine storeGeometry end submodule nonlocal diff --git a/src/phase_mechanical_plastic_phenopowerlaw.f90 b/src/phase_mechanical_plastic_phenopowerlaw.f90 index 0fcdbea6a..04ddbe13c 100644 --- a/src/phase_mechanical_plastic_phenopowerlaw.f90 +++ b/src/phase_mechanical_plastic_phenopowerlaw.f90 @@ -100,7 +100,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) myPlasticity = plastic_active('phenopowerlaw') - if(count(myPlasticity) == 0) return + if (count(myPlasticity) == 0) return print'(/,1x,a)', '<<<+- phase:mechanical:plastic:phenopowerlaw init -+>>>' print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT) @@ -131,7 +131,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) if (phase_lattice(ph) == 'cI') then a = pl%get_as1dFloat('a_nonSchmid',defaultVal=emptyRealArray) - if(size(a) > 0) prm%nonSchmidActive = .true. + if (size(a) > 0) prm%nonSchmidActive = .true. prm%P_nS_pos = lattice_nonSchmidMatrix(N_sl,a,+1) prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1) else @@ -243,7 +243,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) stt%xi_sl => plasticState(ph)%state(startIndex:endIndex,:) stt%xi_sl = spread(xi_0_sl, 2, Nmembers) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) - if(any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_xi' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_tw @@ -257,7 +257,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity) idx_dot%gamma_sl = [startIndex,endIndex] stt%gamma_sl => plasticState(ph)%state(startIndex:endIndex,:) plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal) - if(any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' + if (any(plasticState(ph)%atol(startIndex:endIndex) < 0.0_pReal)) extmsg = trim(extmsg)//' atol_gamma' startIndex = endIndex + 1 endIndex = endIndex + prm%sum_N_tw diff --git a/src/phase_thermal_dissipation.f90 b/src/phase_thermal_dissipation.f90 index a08d396ec..5cd2d4d90 100644 --- a/src/phase_thermal_dissipation.f90 +++ b/src/phase_thermal_dissipation.f90 @@ -37,7 +37,7 @@ module function dissipation_init(source_length) result(mySources) mySources = thermal_active('dissipation',source_length) - if(count(mySources) == 0) return + if (count(mySources) == 0) return print'(/,1x,a)', '<<<+- phase:thermal:dissipation init -+>>>' print'(/,a,i2)', ' # phases: ',count(mySources); flush(IO_STDOUT) diff --git a/src/phase_thermal_externalheat.f90 b/src/phase_thermal_externalheat.f90 index 2d7f541ab..5970a5894 100644 --- a/src/phase_thermal_externalheat.f90 +++ b/src/phase_thermal_externalheat.f90 @@ -11,11 +11,7 @@ submodule(phase:thermal) externalheat source_thermal_externalheat_offset !< which source is my current thermal dissipation mechanism? type :: tParameters !< container type for internal constitutive parameters - real(pReal), dimension(:), allocatable :: & - t_n, & - f_T - integer :: & - nIntervals + type(tTable) :: f end type tParameters type(tParameters), dimension(:), allocatable :: param !< containers of constitutive parameters (len Ninstances) @@ -44,7 +40,7 @@ module function externalheat_init(source_length) result(mySources) mySources = thermal_active('externalheat',source_length) - if(count(mySources) == 0) return + if (count(mySources) == 0) return print'(/,1x,a)', '<<<+- phase:thermal:externalheat init -+>>>' print'(/,a,i2)', ' # phases: ',count(mySources); flush(IO_STDOUT) @@ -64,10 +60,7 @@ module function externalheat_init(source_length) result(mySources) associate(prm => param(ph)) src => sources%get_dict(so) - prm%t_n = src%get_as1dFloat('t_n') - prm%nIntervals = size(prm%t_n) - 1 - - prm%f_T = src%get_as1dFloat('f_T',requiredSize = size(prm%t_n)) + prm%f = table(src,'t','f') Nmembers = count(material_phaseID == ph) call phase_allocateState(thermalState(ph)%p(so),Nmembers,1,1,0) @@ -111,23 +104,13 @@ module function externalheat_f_T(ph,en) result(f_T) f_T integer :: & - so, interval - real(pReal) :: & - frac_time + so + so = source_thermal_externalheat_offset(ph) associate(prm => param(ph)) - do interval = 1, prm%nIntervals ! scan through all rate segments - frac_time = (thermalState(ph)%p(so)%state(1,en) - prm%t_n(interval)) & - / (prm%t_n(interval+1) - prm%t_n(interval)) ! fractional time within segment - if ( (frac_time < 0.0_pReal .and. interval == 1) & - .or. (frac_time >= 1.0_pReal .and. interval == prm%nIntervals) & - .or. (frac_time >= 0.0_pReal .and. frac_time < 1.0_pReal) ) & - f_T = prm%f_T(interval ) * (1.0_pReal - frac_time) + & - prm%f_T(interval+1) * frac_time ! interpolate heat rate between segment boundaries... - ! ...or extrapolate if outside of bounds - end do + f_T = prm%f%at(thermalState(ph)%p(so)%state(1,en)) end associate end function externalheat_f_T diff --git a/src/polynomials.f90 b/src/polynomials.f90 index 38e31eb55..2240616f7 100644 --- a/src/polynomials.f90 +++ b/src/polynomials.f90 @@ -1,6 +1,6 @@ !-------------------------------------------------------------------------------------------------- !> @author Martin Diehl, KU Leuven -!> @brief Polynomial representation for variable data +!> @brief Polynomial representation for variable data. !-------------------------------------------------------------------------------------------------- module polynomials use prec @@ -19,8 +19,8 @@ module polynomials end type tPolynomial interface polynomial - module procedure polynomial_from_dict module procedure polynomial_from_coef + module procedure polynomial_from_dict end interface polynomial public :: & @@ -43,7 +43,7 @@ end subroutine polynomials_init !-------------------------------------------------------------------------------------------------- -!> @brief Initialize a Polynomial from Coefficients. +!> @brief Initialize a polynomial from coefficients. !-------------------------------------------------------------------------------------------------- pure function polynomial_from_coef(coef,x_ref) result(p) @@ -59,7 +59,7 @@ end function polynomial_from_coef !-------------------------------------------------------------------------------------------------- -!> @brief Initialize a Polynomial from a Dictionary with Coefficients. +!> @brief Initialize a polynomial from a dictionary with coefficients. !-------------------------------------------------------------------------------------------------- function polynomial_from_dict(dict,y,x) result(p) @@ -93,7 +93,7 @@ end function polynomial_from_dict !-------------------------------------------------------------------------------------------------- -!> @brief Evaluate a Polynomial. +!> @brief Evaluate a polynomial. !> @details https://nvlpubs.nist.gov/nistpubs/jres/71b/jresv71bn1p11_a1b.pdf (eq. 1.2) !-------------------------------------------------------------------------------------------------- pure function eval(self,x) result(y) diff --git a/src/prec.f90 b/src/prec.f90 index 6a13889ba..1ae7ec62d 100644 --- a/src/prec.f90 +++ b/src/prec.f90 @@ -26,7 +26,7 @@ module prec PetscInt, private :: dummy_int integer, parameter :: pPETSCINT = kind(dummy_int) PetscScalar, private :: dummy_scalar - real(pReal), parameter :: pPETSCSCALAR = kind(dummy_scalar) + real(pReal), parameter, private :: pPETSCSCALAR = kind(dummy_scalar) #endif integer, parameter :: pSTRINGLEN = 256 !< default string length integer, parameter :: pPATHLEN = 4096 !< maximum length of a path name on linux @@ -254,8 +254,9 @@ subroutine selfTest() integer(pI64), dimension(1) :: i real(pReal), dimension(2) :: r + #ifdef PETSC - if (pReal /= pPETSCSCALAR) error stop 'PetSc and Fortran scalar datatypes do not match' + if (pReal /= pPETSCSCALAR) error stop 'PETSc and DAMASK scalar datatypes do not match' #endif realloc_lhs_test = [1,2] if (any(realloc_lhs_test/=[1,2])) error stop 'LHS allocation' diff --git a/src/results.f90 b/src/results.f90 index 17efc87e3..8cdc82c28 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -421,15 +421,15 @@ subroutine results_writeTensorDataset_real(dataset,group,label,description,SIuni real(pReal), dimension(:,:,:), allocatable :: dataset_transposed - if(present(transposed)) then + if (present(transposed)) then transposed_ = transposed else transposed_ = .true. end if groupHandle = results_openGroup(group) - if(transposed_) then - if(size(dataset,1) /= size(dataset,2)) error stop 'transpose non-symmetric tensor' + if (transposed_) then + if (size(dataset,1) /= size(dataset,2)) error stop 'transpose non-symmetric tensor' allocate(dataset_transposed,mold=dataset) do i=1,size(dataset_transposed,3) dataset_transposed(:,:,i) = transpose(dataset(:,:,i)) @@ -527,7 +527,7 @@ subroutine results_mapping_phase(ID,entry,label) writeSize(worldrank) = size(entry(1,:)) ! total number of entries of this process call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' #ifndef PETSC entryGlobal = int(entry -1,pI64) ! 0-based @@ -535,10 +535,10 @@ subroutine results_mapping_phase(ID,entry,label) !-------------------------------------------------------------------------------------------------- ! MPI settings and communication call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call MPI_Allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get output at each process - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' entryOffset = 0_pI64 do co = 1, size(ID,1) @@ -547,7 +547,7 @@ subroutine results_mapping_phase(ID,entry,label) end do end do call MPI_Allreduce(MPI_IN_PLACE,entryOffset,size(entryOffset),MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,err_MPI)! get offset at each process - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' entryOffset(:,worldrank) = sum(entryOffset(:,0:worldrank-1),2) do co = 1, size(ID,1) do ce = 1, size(ID,2) @@ -563,80 +563,80 @@ subroutine results_mapping_phase(ID,entry,label) !--------------------------------------------------------------------------------------------------- ! compound type: label(ID) + entry call H5Tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tget_size_f(dt_id, type_size_string, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND) call H5Tget_size_f(pI64_t, type_size_int, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! create memory types for each component of the compound type call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tcreate_f(H5T_COMPOUND_F, type_size_int, entry_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tinsert_f(entry_id, 'entry', 0_SIZE_T, pI64_t, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tclose_f(dt_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape = hyperslab) and in file (global shape) call H5Screate_simple_f(2,myShape,memspace_id,hdferr,myShape) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Screate_simple_f(2,totalShape,filespace_id,hdferr,totalShape) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! write the components of the compound type individually call H5Pset_preserve_f(plist_id, .true., hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' loc_id = results_openGroup('/cell_to') call H5Dcreate_f(loc_id, 'phase', dtype_id, filespace_id, dset_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dwrite_f(dset_id, label_id, reshape(label(pack(ID,.true.)),myShape), & myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dwrite_f(dset_id, entry_id, reshape(pack(entryGlobal,.true.),myShape), & myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! close all call HDF5_closeGroup(loc_id) call H5Pclose_f(plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(filespace_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(memspace_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dclose_f(dset_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tclose_f(dtype_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tclose_f(label_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tclose_f(entry_id, hdferr) call executionStamp('cell_to/phase','cell ID and constituent ID to phase results') @@ -683,7 +683,7 @@ subroutine results_mapping_homogenization(ID,entry,label) writeSize(worldrank) = size(entry) ! total number of entries of this process call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' #ifndef PETSC entryGlobal = int(entry -1,pI64) ! 0-based @@ -691,17 +691,17 @@ subroutine results_mapping_homogenization(ID,entry,label) !-------------------------------------------------------------------------------------------------- ! MPI settings and communication call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call MPI_Allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) ! get output at each process - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' entryOffset = 0_pI64 do ce = 1, size(ID,1) entryOffset(ID(ce),worldrank) = entryOffset(ID(ce),worldrank) +1_pI64 end do call MPI_Allreduce(MPI_IN_PLACE,entryOffset,size(entryOffset),MPI_INTEGER8,MPI_SUM,MPI_COMM_WORLD,err_MPI)! get offset at each process - if(err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' + if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error' entryOffset(:,worldrank) = sum(entryOffset(:,0:worldrank-1),2) do ce = 1, size(ID,1) entryGlobal(ce) = int(entry(ce),pI64) -1_pI64 + entryOffset(ID(ce),worldrank) @@ -715,82 +715,82 @@ subroutine results_mapping_homogenization(ID,entry,label) !--------------------------------------------------------------------------------------------------- ! compound type: label(ID) + entry call H5Tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tset_size_f(dt_id, int(len(label(1)),SIZE_T), hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tget_size_f(dt_id, type_size_string, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND) call H5Tget_size_f(pI64_t, type_size_int, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tinsert_f(dtype_id, 'label', 0_SIZE_T, dt_id,hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tinsert_f(dtype_id, 'entry', type_size_string, pI64_t, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! create memory types for each component of the compound type call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tinsert_f(label_id, 'label', 0_SIZE_T, dt_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tcreate_f(H5T_COMPOUND_F, type_size_int, entry_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tinsert_f(entry_id, 'entry', 0_SIZE_T, pI64_t, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tclose_f(dt_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape = hyperslab) and in file (global shape) call H5Screate_simple_f(1,myShape,memspace_id,hdferr,myShape) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Screate_simple_f(1,totalShape,filespace_id,hdferr,totalShape) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! write the components of the compound type individually call H5Pset_preserve_f(plist_id, .true., hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' loc_id = results_openGroup('/cell_to') call H5Dcreate_f(loc_id, 'homogenization', dtype_id, filespace_id, dset_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dwrite_f(dset_id, label_id, reshape(label(pack(ID,.true.)),myShape), & myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dwrite_f(dset_id, entry_id, reshape(pack(entryGlobal,.true.),myShape), & myShape, hdferr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' !-------------------------------------------------------------------------------------------------- ! close all call HDF5_closeGroup(loc_id) call H5Pclose_f(plist_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(filespace_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Sclose_f(memspace_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Dclose_f(dset_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tclose_f(dtype_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tclose_f(label_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call H5Tclose_f(entry_id, hdferr) - if(hdferr < 0) error stop 'HDF5 error' + if (hdferr < 0) error stop 'HDF5 error' call executionStamp('cell_to/homogenization','cell ID to homogenization results') diff --git a/src/rotations.f90 b/src/rotations.f90 index 5c8677c81..657480ef4 100644 --- a/src/rotations.f90 +++ b/src/rotations.f90 @@ -212,10 +212,10 @@ subroutine fromAxisAngle(self,ax,degrees,P) axis = ax(1:3) else axis = ax(1:3) * merge(-1.0_pReal,1.0_pReal,P == 1) - if(abs(P) /= 1) call IO_error(402,ext_msg='fromAxisAngle (P)') + if (abs(P) /= 1) call IO_error(402,ext_msg='fromAxisAngle (P)') end if - if(dNeq(norm2(axis),1.0_pReal) .or. angle < 0.0_pReal .or. angle > PI) & + if (dNeq(norm2(axis),1.0_pReal) .or. angle < 0.0_pReal .or. angle > PI) & call IO_error(402,ext_msg='fromAxisAngle') self%q = ax2qu([axis,angle]) @@ -513,11 +513,11 @@ pure function om2qu(om) result(qu) trace = math_trace33(om) - if(trace > 0.0_pReal) then + if (trace > 0.0_pReal) then s = 0.5_pReal / sqrt(trace+1.0_pReal) qu = [0.25_pReal/s, (om(3,2)-om(2,3))*s,(om(1,3)-om(3,1))*s,(om(2,1)-om(1,2))*s] else - if( om(1,1) > om(2,2) .and. om(1,1) > om(3,3) ) then + if ( om(1,1) > om(2,2) .and. om(1,1) > om(3,3) ) then s = 2.0_pReal * sqrt( 1.0_pReal + om(1,1) - om(2,2) - om(3,3)) qu = [ (om(3,2) - om(2,3)) /s,0.25_pReal * s,(om(1,2) + om(2,1)) / s,(om(1,3) + om(3,1)) / s] elseif (om(2,2) > om(3,3)) then @@ -528,7 +528,7 @@ pure function om2qu(om) result(qu) qu = [ (om(2,1) - om(1,2)) /s,(om(1,3) + om(3,1)) / s,(om(2,3) + om(3,2)) / s,0.25_pReal * s] end if end if - if(sign(1.0_pReal,qu(1))<0.0_pReal) qu =-1.0_pReal * qu + if (sign(1.0_pReal,qu(1))<0.0_pReal) qu =-1.0_pReal * qu qu(2:4) = merge(qu(2:4),qu(2:4)*P,dEq0(qu(2:4))) qu = qu/norm2(qu) @@ -619,7 +619,7 @@ pure function eu2qu(eu) result(qu) -P*sPhi*cos(ee(1)-ee(3)), & -P*sPhi*sin(ee(1)-ee(3)), & -P*cPhi*sin(ee(1)+ee(3))] - if(sign(1.0_pReal,qu(1)) < 0.0_pReal) qu = qu * (-1.0_pReal) + if (sign(1.0_pReal,qu(1)) < 0.0_pReal) qu = qu * (-1.0_pReal) end function eu2qu @@ -807,15 +807,15 @@ subroutine selfTest() do i = 1, 20 - if(i==1) then + if (i==1) then qu = [1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal] - elseif(i==2) then + elseif (i==2) then qu = [1.0_pReal,-0.0_pReal,-0.0_pReal,-0.0_pReal] - elseif(i==3) then + elseif (i==3) then qu = [0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal] - elseif(i==4) then + elseif (i==4) then qu = [0.0_pReal,0.0_pReal,1.0_pReal,0.0_pReal] - elseif(i==5) then + elseif (i==5) then qu = [0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal] else call random_number(x) @@ -825,20 +825,20 @@ subroutine selfTest() sin(TAU*x(2))*B,& cos(TAU*x(2))*B,& sin(TAU*x(1))*A] - if(qu(1)<0.0_pReal) qu = qu * (-1.0_pReal) + if (qu(1)<0.0_pReal) qu = qu * (-1.0_pReal) end if - if(.not. quaternion_equal(om2qu(qu2om(qu)),qu)) error stop 'om2qu2om' - if(.not. quaternion_equal(eu2qu(qu2eu(qu)),qu)) error stop 'eu2qu2eu' - if(.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) error stop 'ax2qu2ax' + if (.not. quaternion_equal(om2qu(qu2om(qu)),qu)) error stop 'om2qu2om' + if (.not. quaternion_equal(eu2qu(qu2eu(qu)),qu)) error stop 'eu2qu2eu' + if (.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) error stop 'ax2qu2ax' om = qu2om(qu) - if(.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) error stop 'eu2om2eu' - if(.not. quaternion_equal(om2qu(ax2om(om2ax(om))),qu)) error stop 'ax2om2ax' + if (.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) error stop 'eu2om2eu' + if (.not. quaternion_equal(om2qu(ax2om(om2ax(om))),qu)) error stop 'ax2om2ax' eu = qu2eu(qu) - if(.not. quaternion_equal(eu2qu(ax2eu(eu2ax(eu))),qu)) error stop 'ax2eu2ax' + if (.not. quaternion_equal(eu2qu(ax2eu(eu2ax(eu))),qu)) error stop 'ax2eu2ax' call R%fromMatrix(om) @@ -872,7 +872,7 @@ subroutine selfTest() logical :: ok ok = all(dEq(qu1,qu2,1.0e-7_pReal)) - if(dEq0(qu1(1),1.0e-12_pReal)) & + if (dEq0(qu1(1),1.0e-12_pReal)) & ok = ok .or. all(dEq(-1.0_pReal*qu1,qu2,1.0e-7_pReal)) end function quaternion_equal diff --git a/src/system_routines.f90 b/src/system_routines.f90 index 3ce6ba6ce..74aa4685b 100644 --- a/src/system_routines.f90 +++ b/src/system_routines.f90 @@ -119,7 +119,7 @@ function getCWD() call getCWD_C(getCWD_Cstring,stat) - if(stat == 0) then + if (stat == 0) then getCWD = c_f_string(getCWD_Cstring) else error stop 'invalid working directory' @@ -141,7 +141,7 @@ function getHostName() call getHostName_C(getHostName_Cstring,stat) - if(stat == 0) then + if (stat == 0) then getHostName = c_f_string(getHostName_Cstring) else getHostName = 'n/a (Error!)' @@ -163,7 +163,7 @@ function getUserName() call getUserName_C(getUserName_Cstring,stat) - if(stat == 0) then + if (stat == 0) then getUserName = c_f_string(getUserName_Cstring) else getUserName = 'n/a (Error!)' diff --git a/src/tables.f90 b/src/tables.f90 new file mode 100644 index 000000000..c62082705 --- /dev/null +++ b/src/tables.f90 @@ -0,0 +1,145 @@ +!-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, KU Leuven +!> @author Philip Eisenlohr, Michigan State University +!> @brief Tabular representation of variable data. +!-------------------------------------------------------------------------------------------------- +module tables + use prec + use IO + use YAML_parse + use YAML_types + + implicit none(type,external) + private + + type, public :: tTable + real(pReal), dimension(:), allocatable :: x,y + contains + procedure, public :: at => eval + end type tTable + + interface table + module procedure table_from_values + module procedure table_from_dict + end interface table + + public :: & + table, & + tables_init + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief Run self-test. +!-------------------------------------------------------------------------------------------------- +subroutine tables_init() + + print'(/,1x,a)', '<<<+- tables init -+>>>'; flush(IO_STDOUT) + + call selfTest() + +end subroutine tables_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief Initialize a table from values. +!-------------------------------------------------------------------------------------------------- +function table_from_values(x,y) result(t) + + real(pReal), dimension(:), intent(in) :: x,y + type(tTable) :: t + + + if (size(x) < 1) call IO_error(603,ext_msg='missing tabulated x data') + if (size(y) < 1) call IO_error(603,ext_msg='missing tabulated y data') + if (size(x) /= size(y)) call IO_error(603,ext_msg='shape mismatch in tabulated data') + if (size(x) /= 1) then + if (any(x(2:size(x))-x(1:size(x)-1) <= 0.0_pReal)) & + call IO_error(603,ext_msg='ordinate data does not increase monotonically') + end if + + t%x = x + t%y = y + +end function table_from_values + + +!-------------------------------------------------------------------------------------------------- +!> @brief Initialize a table from a dictionary with values. +!-------------------------------------------------------------------------------------------------- +function table_from_dict(dict,x_label,y_label) result(t) + + type(tDict), intent(in) :: dict + character(len=*), intent(in) :: x_label, y_label + type(tTable) :: t + + + t = tTable(dict%get_as1dFloat(x_label),dict%get_as1dFloat(y_label)) + +end function table_from_dict + + +!-------------------------------------------------------------------------------------------------- +!> @brief Linearly interpolate/extrapolate tabular data. +!-------------------------------------------------------------------------------------------------- +pure function eval(self,x) result(y) + + class(tTable), intent(in) :: self + real(pReal), intent(in) :: x + real(pReal) :: y + + integer :: i + + + if (size(self%x) == 1) then + y = self%y(1) + else + i = max(1,min(findloc(self%x @brief Check correctness of table functionality. +!-------------------------------------------------------------------------------------------------- +subroutine selfTest() + + type(tTable) :: t + real(pReal), dimension(*), parameter :: & + x = real([ 1., 2., 3., 4.],pReal), & + y = real([ 1., 3., 2.,-2.],pReal), & + x_eval = real([ 0.0, 0.5, 1.0, 1.5, 2.0, 2.5, 3.0, 3.5, 4.0, 4.5, 5.0],pReal), & + y_true = real([-1.0, 0.0, 1.0, 2.0, 3.0, 2.5 ,2.0, 0.0,-2.0,-4.0,-6.0],pReal) + integer :: i + type(tDict), pointer :: dict + type(tList), pointer :: l_x, l_y + real(pReal) :: r + + + call random_number(r) + t = table(real([0.],pReal),real([r],pReal)) + if (dNeq(r,t%at(r),1.0e-9_pReal)) error stop 'table eval/mono' + + r = r-0.5_pReal + t = table(x+r,y) + do i = 1, size(x_eval) + if (dNeq(y_true(i),t%at(x_eval(i)+r),1.0e-9_pReal)) error stop 'table eval/values' + end do + + l_x => YAML_parse_str_asList('[1, 2, 3, 4]'//IO_EOL) + l_y => YAML_parse_str_asList('[1, 3, 2,-2]'//IO_EOL) + allocate(dict) + call dict%set('t',l_x) + call dict%set('T',l_y) + t = table(dict,'t','T') + do i = 1, size(x_eval) + if (dNeq(y_true(i),t%at(x_eval(i)))) error stop 'table eval/dict' + end do + +end subroutine selfTest + +end module tables