223031012
/
DAMASK_EICMD
mirror of https://github.com/achalhp/DAMASK_EICMD.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/development' into 231-no-petscscalar-and-_range

This commit is contained in:
Martin Diehl 2022-12-10 14:46:56 +01:00
parent e8aeb4435d 353d55c9a7
commit e6c2e73e03
73 changed files with 4247 additions and 1233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -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

2
.gitlab-ci.yml
View File

@ -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"

2
PRIVATE

@ -1 +1 @@
Subproject commit ecfe3b3f057f4f81b3b1a12399bf238bc2546de7
Subproject commit e9254133c1e9ea3855a4fd17078d4c6f7d8728b1

2
VERSION
View File

@ -1 +1 @@
3.0.0-alpha7-171-g26ff1b895
3.0.0-alpha7-220-g85115d12f

4
examples/config/phase/thermal/source/externalheat_ramp-and-hold.yaml
View File

@ -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]

49
install/MarcMentat/2022.3/Marc_tools/comp_damask_hmp.patch vendored Normal file
View File

@ -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

49
install/MarcMentat/2022.3/Marc_tools/comp_damask_lmp.patch vendored Normal file
View File

@ -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

49
install/MarcMentat/2022.3/Marc_tools/comp_damask_mp.patch vendored Normal file
View File

@ -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

75
install/MarcMentat/2022.3/Marc_tools/include_linux64.patch vendored Normal file
View File

@ -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

517
install/MarcMentat/2022.3/Marc_tools/run_damask_hmp.patch vendored Normal file
View File

@ -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

517
install/MarcMentat/2022.3/Marc_tools/run_damask_lmp.patch vendored Normal file
View File

@ -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

517
install/MarcMentat/2022.3/Marc_tools/run_damask_mp.patch vendored Normal file
View File

@ -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

24
install/MarcMentat/2022.3/Mentat_bin/edit_window.patch vendored Normal file
View File

@ -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% $*

0
install/MarcMentat/2022.3/Mentat_bin/kill4.patch vendored Normal file
View File

0
install/MarcMentat/2022.3/Mentat_bin/kill5.patch vendored Normal file
View File

0
install/MarcMentat/2022.3/Mentat_bin/kill6.patch vendored Normal file
View File

38
install/MarcMentat/2022.3/Mentat_bin/submit4.patch vendored Normal file
View File

@ -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

38
install/MarcMentat/2022.3/Mentat_bin/submit5.patch vendored Normal file
View File

@ -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

38
install/MarcMentat/2022.3/Mentat_bin/submit6.patch vendored Normal file
View File

@ -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

158
install/MarcMentat/2022.3/Mentat_menus/job_run.ms.patch vendored Normal file
View File

@ -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 {

262
processing/mentat_pbcOnBoxMesh.py Executable file
View File

@ -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]))

16
processing/pre/mentat_spectralBox.py → processing/mentat_spectralBox.py
View File

@ -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)

262
processing/pre/mentat_pbcOnBoxMesh.py
View File

@ -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]))

18
python/damask/_config.py
View File

@ -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:

30
python/damask/_grid.py
View File

@ -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,

29
python/damask/_orientation.py
View File

@ -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

22
python/damask/grid_filters.py
View File

@ -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}')

3
python/tests/test_Config.py
View File

@ -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):

246
python/tests/test_Rotation.py
View File

@ -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<L:
i += 1
f = i if i == L else f
return Rotation.from_quaternion(set_of_quaternions.reshape((L//f,f,-1)))
####################################################################################################
# Code below available according to the following conditions
@ -691,117 +702,156 @@ class TestRotation:
def test_to_numpy(self):
r = Rotation.from_random(np.random.randint(0,10,4))
assert np.all(r.as_quaternion() == np.array(r))
assert (r.as_quaternion() == np.array(r)).all()
@pytest.mark.parametrize('degrees',[True,False])
def test_Eulers(self,set_of_rotations,degrees):
for rot in set_of_rotations:
m = rot.as_quaternion()
o = Rotation.from_Euler_angles(rot.as_Euler_angles(degrees),degrees).as_quaternion()
ok = np.allclose(m,o,atol=atol)
if np.isclose(rot.as_quaternion()[0],0.0,atol=atol):
ok |= np.allclose(m*-1.,o,atol=atol)
assert ok and np.isclose(np.linalg.norm(o),1.0), f'{m},{o},{rot.as_quaternion()}'
def test_bounds(self,multidim_rotations):
m = multidim_rotations
@pytest.mark.parametrize('P',[1,-1])
@pytest.mark.parametrize('normalize',[True,False])
@pytest.mark.parametrize('degrees',[True,False])
def test_axis_angle(self,set_of_rotations,degrees,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_Euler_angles()
o = Rotation.from_axis_angle(rot.as_axis_angle(degrees)*c,degrees,normalize,P).as_Euler_angles()
u = np.array([np.pi*2,np.pi,np.pi*2])
ok = np.allclose(m,o,atol=atol)
ok |= np.allclose(np.where(np.isclose(m,u),m-u,m),np.where(np.isclose(o,u),o-u,o),atol=atol)
if np.isclose(m[1],0.0,atol=atol) or np.isclose(m[1],np.pi,atol=atol):
sum_phi = np.unwrap([m[0]+m[2],o[0]+o[2]])
ok |= np.isclose(sum_phi[0],sum_phi[1],atol=atol)
assert ok and (np.zeros(3)-1.e-9 <= o).all() \
and (o <= np.array([np.pi*2.,np.pi,np.pi*2.])+1.e-9).all(), f'{m},{o},{rot.as_quaternion()}'
q = m.as_quaternion()
assert np.allclose(1.,np.linalg.norm(q,axis=-1))
def test_matrix(self,set_of_rotations):
for rot in set_of_rotations:
m = rot.as_axis_angle()
o = Rotation.from_axis_angle(rot.as_axis_angle()).as_axis_angle()
ok = np.allclose(m,o,atol=atol)
if np.isclose(m[3],np.pi,atol=atol):
ok |= np.allclose(m*np.array([-1.,-1.,-1.,1.]),o,atol=atol)
assert ok and np.isclose(np.linalg.norm(o[:3]),1.0) \
and o[3]<=np.pi+1.e-9, f'{m},{o},{rot.as_quaternion()}'
v = m.as_Rodrigues_vector(compact=False)
assert np.allclose(1.,np.linalg.norm(v[...,:3],axis=-1))
def test_parallel(self,set_of_rotations):
a = np.array([[1.0,0.0,0.0],
[0.0,1.0,0.0]])
for rot in set_of_rotations:
assert rot.allclose(Rotation.from_parallel(a,rot.broadcast_to((2,))@a))
v = m.as_axis_angle(degrees=False)
assert np.allclose(1.,np.linalg.norm(v[...,:3],axis=-1))
assert (v[...,3] >= 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),

4
src/CLI.f90
View File

@ -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)

262
src/HDF5_utilities.f90
View File

@ -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

2
src/IO.f90
View File

@ -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

39
src/Marc/DAMASK_Marc.f90
View File

@ -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

246
src/Marc/discretization_Marc.f90
View File

@ -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

466
src/Marc/include/concom2022.3 vendored Normal file
View File

@ -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/)
!!

73
src/Marc/include/creeps2022.3 vendored Normal file
View File

@ -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/)
!!

54
src/Marc/materialpoint_Marc.f90
View File

@ -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)

312
src/YAML_parse.f90
View File

@ -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

2
src/discretization.f90
View File

@ -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)

8
src/geometry_plastic_nonlocal.f90
View File

@ -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

68
src/grid/DAMASK_grid.f90
View File

@ -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

4
src/grid/VTI.f90
View File

@ -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
!--------------------------------------------------------------------------------------------------

84
src/grid/base64.f90
View File

@ -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

2
src/grid/discretization_grid.f90
View File

@ -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)

51
src/grid/grid_damage_spectral.f90
View File

@ -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()

48
src/grid/grid_mech_FEM.f90
View File

@ -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)

6
src/grid/grid_thermal_spectral.f90
View File

@ -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()

127
src/grid/spectral_utilities.f90
View File

@ -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

12
src/homogenization.f90
View File

@ -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

8
src/homogenization_damage.f90
View File

@ -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

66
src/materialpoint.f90
View File

@ -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

2
src/mesh/DAMASK_mesh.f90
View File

@ -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

8
src/mesh/FEM_quadrature.f90
View File

@ -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

4
src/mesh/FEM_utilities.f90
View File

@ -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 &

16
src/mesh/discretization_mesh.f90
View File

@ -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

78
src/mesh/mesh_mech_FEM.f90
View File

@ -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

4
src/parallelization.f90
View File

@ -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

13
src/phase.f90
View File

@ -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))

33
src/phase_damage.f90
View File

@ -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
!----------------------------------------------------------------------------------------------

18
src/phase_mechanical.f90
View File

@ -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)

2
src/phase_mechanical_eigen_cleavageopening.f90
View File

@ -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)

4
src/phase_mechanical_plastic_isotropic.f90
View File

@ -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))

8
src/phase_mechanical_plastic_kinehardening.f90
View File

@ -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

10
src/phase_mechanical_plastic_nonlocal.f90
View File

@ -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

8
src/phase_mechanical_plastic_phenopowerlaw.f90
View File

@ -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

2
src/phase_thermal_dissipation.f90
View File

@ -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)

29
src/phase_thermal_externalheat.f90
View File

@ -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

10
src/polynomials.f90
View File

@ -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)

5
src/prec.f90
View File

@ -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'

124
src/results.f90
View File

@ -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')

38
src/rotations.f90
View File

@ -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

6
src/system_routines.f90
View File

@ -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!)'

145
src/tables.f90 Normal file
View File

@ -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<x,.true.,dim=1,back=.true.),size(self%x)-1))
y = self%y(i) &
+ (x-self%x(i)) * (self%y(i+1)-self%y(i)) / (self%x(i+1)-self%x(i))
end if
end function eval
!--------------------------------------------------------------------------------------------------
!> @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