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 # ignore files from MSC.Marc in language statistics
install/MarcMentat/** linguist-vendored install/MarcMentat/** linguist-vendored
src/Marc/include/* 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 # ignore reference files for tests in language statistics
python/tests/reference/** linguist-vendored 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_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" PETSC_INTEL: "Libraries/PETSc/3.16.5/Intel-2022.0.1-IntelMPI-2021.5.0"
# ++++++++++++ MSC Marc +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ # ++++++++++++ MSC Marc +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
MSC: "FEM/MSC/2022.2" MSC: "FEM/MSC/2022.3"
IntelMarc: "Compiler/Intel/19.1.2 Libraries/IMKL/2020" IntelMarc: "Compiler/Intel/19.1.2 Libraries/IMKL/2020"
HDF5Marc: "HDF5/1.12.2/Intel-19.1.2" 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 type: externalheat
f_T: [1, 1, 0, 0] f: [1, 1, 0, 0]
t_n: [0, 500, 500.001, 1000] 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 import damask
scriptName = os.path.splitext(os.path.basename(__file__))[0] script_name = os.path.splitext(os.path.basename(__file__))[0]
scriptID = ' '.join([scriptName,damask.version]) script_id = ' '.join([script_name,damask.version])
#------------------------------------------------------------------------------------------------- #-------------------------------------------------------------------------------------------------
def outMentat(cmd,locals): def outMentat(cmd,locals):
@ -45,7 +45,7 @@ def output(cmds,locals,dest):
#------------------------------------------------------------------------------------------------- #-------------------------------------------------------------------------------------------------
def init(): def init():
return [ return [
"|"+' '.join([scriptID] + sys.argv[1:]), "|"+' '.join([script_id] + sys.argv[1:]),
"*draw_manual", # prevent redrawing in Mentat, should be much faster "*draw_manual", # prevent redrawing in Mentat, should be much faster
"*new_model yes", "*new_model yes",
"*reset", "*reset",
@ -170,7 +170,7 @@ def initial_conditions(material):
parser = OptionParser(usage='%prog options [file[s]]', description = """ parser = OptionParser(usage='%prog options [file[s]]', description = """
Generate MSC.Marc FE hexahedral mesh from geom file. Generate MSC.Marc FE hexahedral mesh from geom file.
""", version = scriptID) """, version = script_id)
parser.add_option('-p', '--port', parser.add_option('-p', '--port',
dest = 'port', dest = 'port',
@ -194,7 +194,7 @@ if options.port is not None:
if filenames == []: filenames = [None] if filenames == []: filenames = [None]
for name in filenames: 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) geom = damask.Grid.load(StringIO(''.join(sys.stdin.read())) if name is None else name)
material = geom.material.flatten(order='F') material = geom.material.flatten(order='F')
@ -211,11 +211,11 @@ for name in filenames:
'*draw_automatic', '*draw_automatic',
] ]
outputLocals = {} output_locals = {}
if options.port: if options.port:
py_mentat.py_connect('',options.port) py_mentat.py_connect('',options.port)
output(cmds,outputLocals,'Mentat') output(cmds,output_locals,'Mentat')
py_mentat.py_disconnect() py_mentat.py_disconnect()
else: else:
with sys.stdout if name is None else open(os.path.splitext(name)[0]+'.proc','w') as f: 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 import yaml
try: try:
from yaml import CSafeLoader as SafeLoader from yaml import CSafeLoader as SafeLoader
from yaml import CSafeDumper as SafeDumper
except ImportError: except ImportError:
from yaml import SafeLoader # type: ignore from yaml import SafeLoader # type: ignore
from yaml import SafeDumper # type: ignore
from ._typehints import FileHandle from ._typehints import FileHandle
from . import Rotation from . import Rotation
@ -17,20 +19,20 @@ from . import util
MyType = TypeVar('MyType', bound='Config') MyType = TypeVar('MyType', bound='Config')
class NiceDumper(yaml.SafeDumper): class NiceDumper(SafeDumper):
"""Make YAML readable for humans.""" """Make YAML readable for humans."""
def write_line_break(self, def write_line_break(self,
data: Optional[str] = None): data: Optional[str] = None):
super().write_line_break(data) super().write_line_break(data) # type: ignore
if len(self.indents) == 1: if len(self.indents) == 1: # type: ignore
super().write_line_break() super().write_line_break() # type: ignore
def increase_indent(self, def increase_indent(self,
flow: bool = False, flow: bool = False,
indentless: bool = False): indentless: bool = False):
return super().increase_indent(flow, False) return super().increase_indent(flow, False) # type: ignore
def represent_data(self, def represent_data(self,
data: Any): data: Any):
@ -41,8 +43,10 @@ class NiceDumper(yaml.SafeDumper):
return self.represent_data(data.tolist()) return self.represent_data(data.tolist())
if isinstance(data, Rotation): if isinstance(data, Rotation):
return self.represent_data(data.quaternion.tolist()) return self.represent_data(data.quaternion.tolist())
else: if hasattr(data, 'dtype'):
return super().represent_data(data) return self.represent_data(data.item())
return super().represent_data(data)
def ignore_aliases(self, def ignore_aliases(self,
data: Any) -> bool: data: Any) -> bool:

30
python/damask/_grid.py
View File

@ -19,6 +19,14 @@ from . import Rotation
from . import Table from . import Table
from . import Colormap from . import Colormap
from ._typehints import FloatSequence, IntSequence, IntCollection, NumpyRngSeed 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: class Grid:
""" """
@ -1129,7 +1137,7 @@ class Grid:
""" """
def most_frequent(stencil: np.ndarray, def most_frequent(stencil: np.ndarray,
selection: Union[None,set], selection: Union[None,set],
rng): rng: np.random.Generator):
me = stencil[stencil.size//2] me = stencil[stencil.size//2]
if selection is None or me in selection: if selection is None or me in selection:
unique, counts = np.unique(stencil,return_counts=True) unique, counts = np.unique(stencil,return_counts=True)
@ -1289,19 +1297,27 @@ class Grid:
Updated grid-based geometry. 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] me = stencil[stencil.size//2]
return np.any(stencil != me if selection is None else if selection is None:
np.in1d(stencil,np.array(list(selection - {me})))) 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) d = np.floor(distance).astype(np.int64)
ext = np.linspace(-d,d,1+2*d,dtype=float), ext = np.linspace(-d,d,1+2*d,dtype=float),
xx,yy,zz = np.meshgrid(ext,ext,ext) xx,yy,zz = np.meshgrid(ext,ext,ext)
footprint = xx**2+yy**2+zz**2 <= distance**2+distance*1e-8 footprint = xx**2+yy**2+zz**2 <= distance**2+distance*1e-8
offset_ = np.nanmax(self.material)+1 if offset is None else offset offset_ = np.nanmax(self.material)+1 if offset is None else offset
selection_ = None if selection is None else \ selection_ = None if selection is None else \
set(self.material.flatten()) - set(util.aslist(selection)) if invert_selection else \ np.array(list(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))))
mask = ndimage.generic_filter(self.material, mask = ndimage.generic_filter(self.material,
tainted_neighborhood, tainted_neighborhood,
footprint=footprint, footprint=footprint,

29
python/damask/_orientation.py
View File

@ -627,7 +627,7 @@ class Orientation(Rotation,Crystal):
weights : numpy.ndarray, shape (self.shape), optional weights : numpy.ndarray, shape (self.shape), optional
Relative weights of orientations. Relative weights of orientations.
return_cloud : bool, optional 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. Defaults to False.
Returns Returns
@ -635,7 +635,7 @@ class Orientation(Rotation,Crystal):
average : Orientation average : Orientation
Weighted average of original Orientation field. Weighted average of original Orientation field.
cloud : Orientations, conditional 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 References
---------- ----------
@ -660,7 +660,7 @@ class Orientation(Rotation,Crystal):
proper: bool = False, proper: bool = False,
return_operators: bool = False) -> np.ndarray: 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 Parameters
---------- ----------
@ -679,7 +679,7 @@ class Orientation(Rotation,Crystal):
------- -------
vector_SST : numpy.ndarray, shape (...,3) vector_SST : numpy.ndarray, shape (...,3)
Rotated vector falling into SST. 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. Index of symmetrically equivalent orientation that rotated vector to SST.
""" """
@ -749,12 +749,12 @@ class Orientation(Rotation,Crystal):
in_SST: bool = True, in_SST: bool = True,
proper: bool = False) -> np.ndarray: 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 Parameters
---------- ----------
vector : numpy.ndarray, shape (...,3) vector : numpy.ndarray, shape (...,3)
Vector to colorize. Lab frame vector to colorize.
Shape of vector blends with shape of own rotation array. 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. 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 in_SST : bool, optional
@ -771,13 +771,26 @@ class Orientation(Rotation,Crystal):
Examples 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 >>> import damask
>>> o = damask.Orientation(family='cubic') >>> o = damask.Orientation(family='cubic')
>>> o.IPF_color([0,0,1]) >>> o.IPF_color([0,0,1])
array([1., 0., 0.]) 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: if np.array(vector).shape[-1] != 3:
raise ValueError('input is not a field of three-dimensional vectors') 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) in_SST_ = np.all(components >= 0.0,axis=-1)
with np.errstate(invalid='ignore',divide='ignore'): 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.clip(rgb,0.,1.) # clip intensity
rgb /= np.max(rgb,axis=-1,keepdims=True) # normalize to (HS)V = 1 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 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 e[0, 2, 1] = e[2, 1, 0] = e[1, 0, 2] = -1.0
f_fourier = _np.fft.rfftn(f,axes=(0,1,2)) 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 curl_ = (_np.einsum('slm,ijkl,ijkm ->ijks' if n == 3 else
_np.einsum('slm,ijkl,ijknm->ijksn',e,k_s,f_fourier)*2.0j*_np.pi) # tensor, 3x3 -> 3x3 '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]) 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) k_s = _ks(size,f.shape[:3],True)
f_fourier = _np.fft.rfftn(f,axes=(0,1,2)) 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 divergence_ = (_np.einsum('ijkl,ijkl ->ijk' if n == 3 else
_np.einsum('ijkm,ijklm->ijkl',k_s,f_fourier)*2.0j*_np.pi) # tensor, 3x3 -> 3 '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, def gradient(size: _FloatSequence,
@ -124,17 +124,17 @@ def gradient(size: _FloatSequence,
Returns Returns
------- -------
∇ f : numpy.ndarray, shape (:,:,:,3) or (:,:,:,3,3) ∇ f : numpy.ndarray, shape (:,:,:,3) or (:,:,:,3,3)
Divergence of f. Gradient of f.
""" """
n = _np.prod(f.shape[3:]) n = _np.prod(f.shape[3:])
k_s = _ks(size,f.shape[:3],True) k_s = _ks(size,f.shape[:3],True)
f_fourier = _np.fft.rfftn(f,axes=(0,1,2)) 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 gradient_ = (_np.einsum('ijkl,ijkm->ijkm' if n == 1 else
_np.einsum('ijkl,ijkm->ijklm',f_fourier,k_s)*2.0j*_np.pi) # vector, 3 -> 3x3 '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, def coordinates0_point(cells: _IntSequence,
@ -296,8 +296,8 @@ def cellsSizeOrigin_coordinates0_point(coordinates0: _np.ndarray,
origin = mincorner - delta*.5 origin = mincorner - delta*.5
# 1D/2D: size/origin combination undefined, set origin to 0.0 # 1D/2D: size/origin combination undefined, set origin to 0.0
size [_np.where(cells==1)] = origin[_np.where(cells==1)]*2. size [_np.where(cells == 1)] = origin[_np.where(cells == 1)]*2.
origin[_np.where(cells==1)] = 0.0 origin[_np.where(cells == 1)] = 0.0
if cells.prod() != len(coordinates0): if cells.prod() != len(coordinates0):
raise ValueError(f'data count {len(coordinates0)} does not match cells {cells}') 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 assert Config.load(tmp_path/'config.yaml') == config
def test_numpy(self,tmp_path): 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): def test_abstract_is_valid(self):
with pytest.raises(NotImplementedError): 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 _rotation
from damask import grid_filters from damask import grid_filters
from damask import util from damask import util
from damask import tensor
n = 1000 n = 1000
atol=1.e-4 atol=1.e-4
@ -20,6 +21,16 @@ def ref_path(ref_path_base):
def set_of_rotations(set_of_quaternions): def set_of_rotations(set_of_quaternions):
return [Rotation.from_quaternion(s) for s in 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 # Code below available according to the following conditions
@ -691,117 +702,156 @@ class TestRotation:
def test_to_numpy(self): def test_to_numpy(self):
r = Rotation.from_random(np.random.randint(0,10,4)) 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_bounds(self,multidim_rotations):
def test_Eulers(self,set_of_rotations,degrees): m = multidim_rotations
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()}'
@pytest.mark.parametrize('P',[1,-1]) q = m.as_quaternion()
@pytest.mark.parametrize('normalize',[True,False]) assert np.allclose(1.,np.linalg.norm(q,axis=-1))
@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()}'
def test_matrix(self,set_of_rotations): v = m.as_Rodrigues_vector(compact=False)
for rot in set_of_rotations: assert np.allclose(1.,np.linalg.norm(v[...,:3],axis=-1))
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()}'
def test_parallel(self,set_of_rotations): v = m.as_axis_angle(degrees=False)
a = np.array([[1.0,0.0,0.0], assert np.allclose(1.,np.linalg.norm(v[...,:3],axis=-1))
[0.0,1.0,0.0]]) assert (v[...,3] >= 0.).all and (v < np.pi+1.e-9).all()
for rot in set_of_rotations:
assert rot.allclose(Rotation.from_parallel(a,rot.broadcast_to((2,))@a))
@pytest.mark.parametrize('P',[1,-1]) r = m.as_matrix()
@pytest.mark.parametrize('normalize',[True,False]) assert np.allclose(1.,np.linalg.det(r))
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}'
def test_Rodrigues_compact(self,set_of_rotations): e = m.as_Euler_angles(degrees=False)
for rot in set_of_rotations: assert (e >= 0.).all and (e < np.pi*np.array([2.,1.,2.])+1.e-9).all()
c = rot.as_Rodrigues_vector(compact=True)
r = rot.as_Rodrigues_vector(compact=False) c = m.as_cubochoric()
assert np.allclose(r[:3]*r[3], c, equal_nan=True) 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('accept_homomorph',[True,False])
@pytest.mark.parametrize('normalize',[True,False]) @pytest.mark.parametrize('normalize',[True,False])
def test_quaternion(self,set_of_rotations,P,accept_homomorph,normalize): @pytest.mark.parametrize('P',[1,-1])
c = np.array([1,P*-1,P*-1,P*-1]) * (-1 if accept_homomorph else 1) * (0.9 if normalize else 1.0) def test_quaternion(self,multidim_rotations,accept_homomorph,normalize,P):
for rot in set_of_rotations: c = np.array([1,-P,-P,-P]) * (-1 if accept_homomorph else 1) * (0.9 if normalize else 1.0)
m = rot.as_cubochoric() m = multidim_rotations
o = Rotation.from_quaternion(rot.as_quaternion()*c,accept_homomorph,normalize,P).as_cubochoric() o = Rotation.from_quaternion(m.as_quaternion()*c,
ok = np.allclose(m,o,atol=atol) accept_homomorph=accept_homomorph,
if np.count_nonzero(np.isclose(np.abs(o),np.pi**(2./3.)*.5)): normalize=normalize,
ok |= np.allclose(m*-1.,o,atol=atol) P=P)
assert ok and o.max() < np.pi**(2./3.)*0.5+1.e-9, f'{m},{o},{rot.as_quaternion()}' 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]) @pytest.mark.parametrize('reciprocal',[True,False])
def test_basis(self,set_of_rotations,reciprocal): def test_basis(self,multidim_rotations,reciprocal):
for rot in set_of_rotations: m = multidim_rotations
om = rot.as_matrix() + 0.1*np.eye(3) r = m.as_matrix()
rot = Rotation.from_basis(om,False,reciprocal=reciprocal) r = np.linalg.inv(tensor.transpose(r)/np.pi) if reciprocal else r
assert np.isclose(np.linalg.det(rot.as_matrix()),1.0) 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)]) @pytest.mark.parametrize('shape',[None,1,(4,4)])
def test_random(self,shape): def test_random(self,shape):
r = Rotation.from_random(shape) r = Rotation.from_random(shape)
if shape is None: assert r.shape == () if shape is None else (1,) if shape == 1 else shape
assert r.shape == ()
elif shape == 1:
assert r.shape == (1,)
else:
assert r.shape == shape
@pytest.mark.parametrize('shape',[None,5,(4,6)]) @pytest.mark.parametrize('shape',[None,5,(4,6)])
def test_equal(self,shape): def test_equal(self,shape):
@ -822,7 +872,7 @@ class TestRotation:
def test_equal_ambiguous(self): def test_equal_ambiguous(self):
qu = np.random.rand(10,4) qu = np.random.rand(10,4)
qu[:,0] = 0. 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() assert (Rotation(qu) == Rotation(-qu)).all()
def test_inversion(self): def test_inversion(self):
@ -947,13 +997,13 @@ class TestRotation:
p = np.random.rand(n,3) p = np.random.rand(n,3)
o = Rotation._get_pyramid_order(p,direction) o = Rotation._get_pyramid_order(p,direction)
for i,o_i in enumerate(o): 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): def test_pyramid_invariant(self):
a = np.random.rand(n,3) a = np.random.rand(n,3)
f = Rotation._get_pyramid_order(a,'forward') f = Rotation._get_pyramid_order(a,'forward')
b = Rotation._get_pyramid_order(a,'backward') 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), @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)) workingDirectory = trim(rectifyPath(workingDirectory))
error = setCWD(trim(workingDirectory)) error = setCWD(trim(workingDirectory))
if(error) then if (error) then
print*, 'ERROR: Invalid Working directory: '//trim(workingDirectory) print*, 'ERROR: Invalid Working directory: '//trim(workingDirectory)
call quit(1) call quit(1)
end if end if
@ -324,7 +324,7 @@ function rectifyPath(path)
end if end if
i = j+index(rectifyPath(j+1:l),'../') i = j+index(rectifyPath(j+1:l),'../')
end do end do
if(len_trim(rectifyPath) == 0) rectifyPath = '/' if (len_trim(rectifyPath) == 0) rectifyPath = '/'
rectifyPath = trim(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 end if
call H5Pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) 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 #ifdef PETSC
if (present(parallel)) then 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) call H5Pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr)
#endif #endif
end if end if
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
#endif #endif
if (m == 'w') then if (m == 'w') then
call H5Fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) call H5Fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
elseif(m == 'a') then elseif (m == 'a') then
call H5Fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) call H5Fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
elseif(m == 'r') then elseif (m == 'r') then
call H5Fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) 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 else
error stop 'unknown access mode' error stop 'unknown access mode'
end if end if
call H5Pclose_f(plist_id, hdferr) call H5Pclose_f(plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end function HDF5_openFile end function HDF5_openFile
@ -229,7 +229,7 @@ subroutine HDF5_closeFile(fileHandle)
integer :: hdferr integer :: hdferr
call H5Fclose_f(fileHandle,hdferr) call H5Fclose_f(fileHandle,hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine HDF5_closeFile end subroutine HDF5_closeFile
@ -248,19 +248,19 @@ integer(HID_T) function HDF5_addGroup(fileHandle,groupName)
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! creating a property list for data access properties ! creating a property list for data access properties
call H5Pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) 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 ! setting I/O mode to collective
#ifdef PETSC #ifdef PETSC
call H5Pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) 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 #endif
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! Create group ! Create group
call H5Gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) 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) 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 ! creating a property list for data access properties
call H5Pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) 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 ! setting I/O mode to collective
#ifdef PETSC #ifdef PETSC
call H5Pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) 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 #endif
!------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------
! opening the group ! opening the group
call H5Gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) 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) call H5Pclose_f(aplist_id,hdferr)
@ -313,7 +313,7 @@ subroutine HDF5_closeGroup(group_id)
integer :: hdferr integer :: hdferr
call H5Gclose_f(group_id, 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 end subroutine HDF5_closeGroup
@ -337,11 +337,11 @@ logical function HDF5_objectExists(loc_id,path)
end if end if
call H5Lexists_f(loc_id, p, HDF5_objectExists, hdferr) 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) 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 if
end function HDF5_objectExists end function HDF5_objectExists
@ -374,24 +374,24 @@ subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path)
ptr(1) = c_loc(attrValue_(1)) ptr(1) = c_loc(attrValue_(1))
call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) 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) 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 if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) 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 end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_STRING,space_id,attr_id,hdferr) 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 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) 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) 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 end subroutine HDF5_addAttribute_str
@ -419,24 +419,24 @@ subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path)
end if end if
call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) 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) 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 if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) 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 end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) 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) 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) 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) 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 end subroutine HDF5_addAttribute_int
@ -464,24 +464,24 @@ subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path)
end if end if
call H5Screate_f(H5S_SCALAR_F,space_id,hdferr) 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) 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 if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) 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 end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) 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) 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) 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) 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 end subroutine HDF5_addAttribute_real
@ -516,24 +516,24 @@ subroutine HDF5_addAttribute_str_array(loc_id,attrLabel,attrValue,path)
end do end do
call H5Screate_simple_f(1,shape(attrValue_,kind=HSIZE_T),space_id,hdferr,shape(attrValue_,kind=HSIZE_T)) 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) 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 if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) 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 end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_STRING,space_id,attr_id,hdferr) 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 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) 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) 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 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) array_size = size(attrValue,kind=HSIZE_T)
call H5Screate_simple_f(1, array_size, space_id, hdferr, array_size) 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) 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 if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) 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 end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) 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) 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) 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) 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 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) array_size = size(attrValue,kind=HSIZE_T)
call H5Screate_simple_f(1, array_size, space_id, hdferr, array_size) 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) 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 if (attrExists) then
call H5Adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) 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 end if
call H5Acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) 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) 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) 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) 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 end subroutine HDF5_addAttribute_real_array
@ -645,13 +645,13 @@ subroutine HDF5_setLink(loc_id,target_name,link_name)
logical :: linkExists logical :: linkExists
call H5Lexists_f(loc_id, link_name,linkExists, hdferr) 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 if (linkExists) then
call H5Ldelete_f(loc_id,link_name, hdferr) call H5Ldelete_f(loc_id,link_name, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call H5Lcreate_soft_f(target_name, loc_id, link_name, hdferr) 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 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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,& 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) 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) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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,& 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) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
end select end select
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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) dataset_ = trim(dataset)
call H5Tcopy_f(H5T_C_S1, filetype_id, hdferr) 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 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) 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) 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) call H5Pcreate_f(H5P_DATASET_CREATE_F, dcpl, hdferr)
if (hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
@ -1579,23 +1579,23 @@ subroutine HDF5_write_str(dataset,loc_id,datasetName)
end if end if
call H5Screate_simple_f(1, [1_HSIZE_T], space_id, hdferr) 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) 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) 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) 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) 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) 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) 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) 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 end subroutine HDF5_write_str
@ -1635,7 +1635,7 @@ subroutine HDF5_write_int1(dataset,loc_id,datasetName,parallel)
if (product(totalShape) /= 0) then if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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 if (product(totalShape) /= 0) then
call H5Dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& 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) 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 end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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,& 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) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id)
end select end select
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end if end if
call finalize_write(plist_id, dset_id, filespace_id, memspace_id) 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) ! creating a property list for transfer properties (is collective for MPI)
call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) 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 readSize = 0_MPI_INTEGER_KIND
@ -1986,7 +1986,7 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_
#ifdef PETSC #ifdef PETSC
if (parallel) then if (parallel) then
call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) 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 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' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
end if end if
@ -1997,35 +1997,35 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_
if (any(globalShape == 0)) then if (any(globalShape == 0)) then
call H5Pclose_f(plist_id, hdferr) call H5Pclose_f(plist_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
return return
end if end if
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! create dataspace in memory (local shape) ! create dataspace in memory (local shape)
call H5Screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) 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 ! creating a property list for IO and set it to collective
call H5Pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) 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 #ifdef PETSC
call H5Pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) 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 #endif
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! open the dataset in the file and get the space ID ! open the dataset in the file and get the space ID
call H5Dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_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) 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 ! select a hyperslab (the portion of the current process) in the file
call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) call H5Sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine initialize_read end subroutine initialize_read
@ -2039,15 +2039,15 @@ subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id
integer :: hdferr integer :: hdferr
call H5Pclose_f(plist_id, 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) 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) 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) 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) call H5Sclose_f(memspace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine finalize_read 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) ! creating a property list for transfer properties (is collective when writing in parallel)
call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) 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 #ifdef PETSC
if (parallel) then if (parallel) then
call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) 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 end if
#endif #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) ! create dataspace in memory (local shape) and in file (global shape)
call H5Screate_simple_f(size(myShape), myShape, memspace_id, hdferr, myShape) 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) 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) ! 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) 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) 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) call H5Pclose_f(dcpl , hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
contains contains
!------------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------------
@ -2170,13 +2170,13 @@ subroutine finalize_write(plist_id, dset_id, filespace_id, memspace_id)
integer :: hdferr integer :: hdferr
call H5Pclose_f(plist_id, 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) 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) 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) call H5Sclose_f(memspace_id, hdferr)
if(hdferr < 0) error stop 'HDF5 error' if (hdferr < 0) error stop 'HDF5 error'
end subroutine finalize_write 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 ! user errors
case (602) case (602)
msg = 'invalid selection for debug' msg = 'invalid selection for debug'
case (603)
msg = 'invalid data for table'
!------------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------------
! errors related to YAML data ! 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 if (ierr /= 0) then
print*, 'working directory "'//trim(wd)//'" does not exist' print*, 'working directory "'//trim(wd)//'" does not exist'
call quit(1) call quit(1)
endif end if
symmetricSolver = solverIsSymmetric() symmetricSolver = solverIsSymmetric()
end subroutine DAMASK_interface_init end subroutine DAMASK_interface_init
@ -105,14 +105,14 @@ logical function solverIsSymmetric()
status='old', position='rewind', action='read',iostat=myStat) status='old', position='rewind', action='read',iostat=myStat)
do do
read (fileUnit,'(A)',END=100) line 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 read (fileUnit,'(A)',END=100) line ! next line
s = verify(line, ' ') ! start of first chunk s = verify(line, ' ') ! start of first chunk
s = s + verify(line(s+1:),' ') ! start of second chunk s = s + verify(line(s+1:),' ') ! start of second chunk
e = s + scan (line(s+1:),' ') ! end of second chunk e = s + scan (line(s+1:),' ') ! end of second chunk
solverIsSymmetric = line(s:e) /= '1' solverIsSymmetric = line(s:e) /= '1'
endif end if
enddo end do
100 close(fileUnit) 100 close(fileUnit)
contains contains
@ -134,7 +134,7 @@ logical function solverIsSymmetric()
lc(i:i) = string(i:i) lc(i:i) = string(i:i)
n = index(UPPER,lc(i:i)) n = index(UPPER,lc(i:i))
if (n/=0) lc(i:i) = LOWER(n:n) if (n/=0) lc(i:i) = LOWER(n:n)
enddo end do
end function lc end function lc
end function solverIsSymmetric end function solverIsSymmetric
@ -153,6 +153,7 @@ end module DAMASK_interface
#include "../math.f90" #include "../math.f90"
#include "../rotations.f90" #include "../rotations.f90"
#include "../polynomials.f90" #include "../polynomials.f90"
#include "../tables.f90"
#include "../lattice.f90" #include "../lattice.f90"
#include "element.f90" #include "element.f90"
#include "../geometry_plastic_nonlocal.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 :: & type(tList), pointer :: &
debug_Marc ! pointer to Marc debug options 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,/,i8,i8,i2)', ' MSC.Marc information on shape of element(2), IP:', m, nn
print'(a,2(i1))', ' Jacobian: ', ngens,ngens print'(a,2(i1))', ' Jacobian: ', ngens,ngens
print'(a,i1)', ' Direct stress: ', ndi 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) transpose(ffn)
write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' Deformation gradient at t=n+1:', & write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' Deformation gradient at t=n+1:', &
transpose(ffn1) transpose(ffn1)
endif end if
defaultNumThreadsInt = omp_get_num_threads() ! remember number of threads set by Marc defaultNumThreadsInt = omp_get_num_threads() ! remember number of threads set by Marc
call omp_set_num_threads(1_pI32) ! no openMP 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 call materialpoint_initAll
debug_Marc => config_debug%get_list('Marc',defaultVal=emptyList) debug_Marc => config_debug%get_list('Marc',defaultVal=emptyList)
debug_basic = debug_Marc%contains('basic') debug_basic = debug_Marc%contains('basic')
endif end if
computationMode = 0 ! save initialization value, since it does not result in any calculation computationMode = 0 ! save initialization value, since it does not result in any calculation
if (lovl == 4 ) then ! jacobian requested by marc 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. lastIncConverged = .true.
outdatedByNewInc = .true. outdatedByNewInc = .true.
print'(a,i6,1x,i2)', '<< HYPELA2 >> new increment..! ',m(1),nn print'(a,i6,1x,i2)', '<< HYPELA2 >> new increment..! ',m(1),nn
endif end if
else if ( timinc < theDelta ) then ! >> cutBack << else if ( timinc < theDelta ) then ! >> cutBack <<
lastIncConverged = .false. lastIncConverged = .false.
outdatedByNewInc = .false. outdatedByNewInc = .false.
terminallyIll = .false. terminallyIll = .false.
cycleCounter = -1 ! first calc step increments this to cycle = 0 cycleCounter = -1 ! first calc step increments this to cycle = 0
print'(a,i6,1x,i2)', '<< HYPELA2 >> cutback detected..! ',m(1),nn print'(a,i6,1x,i2)', '<< HYPELA2 >> cutback detected..! ',m(1),nn
endif ! convergence treatment end end if ! convergence treatment end
flush(6) flush(6)
if (lastLovl /= lovl) then if (lastLovl /= lovl) then
cycleCounter = cycleCounter + 1 cycleCounter = cycleCounter + 1
!mesh_cellnode = mesh_build_cellnodes() ! update cell node coordinates !mesh_cellnode = mesh_build_cellnodes() ! update cell node coordinates
!call mesh_build_ipCoordinates() ! update ip coordinates !call mesh_build_ipCoordinates() ! update ip coordinates
endif end if
if (outdatedByNewInc) then if (outdatedByNewInc) then
computationMode = ior(computationMode,materialpoint_AGERESULTS) computationMode = ior(computationMode,materialpoint_AGERESULTS)
outdatedByNewInc = .false. outdatedByNewInc = .false.
endif end if
if (lastIncConverged) then if (lastIncConverged) then
computationMode = ior(computationMode,materialpoint_BACKUPJACOBIAN) computationMode = ior(computationMode,materialpoint_BACKUPJACOBIAN)
lastIncConverged = .false. lastIncConverged = .false.
endif end if
theTime = cptim theTime = cptim
theDelta = timinc theDelta = timinc
theInc = inc theInc = inc
endif end if
lastLovl = lovl lastLovl = lovl
call materialpoint_general(computationMode,ffn,ffn1,t(1),timinc,int(m(1)),int(nn),stress,ddsdde) 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) d = ddsdde(1:ngens,1:ngens)
s = stress(1:ndi+nshear) s = stress(1:ndi+nshear)
g = 0.0_pReal 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 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) do n = lbound(discretization_Marc_FEM2DAMASK_node,1), ubound(discretization_Marc_FEM2DAMASK_node,1)
if (discretization_Marc_FEM2DAMASK_node(n) /= -1) then if (discretization_Marc_FEM2DAMASK_node(n) /= -1) then
call nodvar(1,n,d_n(1:3,discretization_Marc_FEM2DAMASK_node(n)),nqncomp,nqdatatype) 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 if (nqncomp == 2) d_n(3,discretization_Marc_FEM2DAMASK_node(n)) = 0.0_pReal
endif end if
enddo end do
call discretization_Marc_UpdateNodeAndIpCoords(d_n) call discretization_Marc_UpdateNodeAndIpCoords(d_n)
call materialpoint_results(int(inc),cptim) call materialpoint_results(int(inc),cptim)
inc_written = int(inc) inc_written = int(inc)
endif end if
end subroutine uedinc 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) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 2) cycle if (chunkPos(1) < 2) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'version') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'version') then
fileFormat = IO_intValue(fileContent(l),chunkPos,2) fileFormat = IO_intValue(fileContent(l),chunkPos,2)
exit exit
endif end if
enddo end do
end subroutine inputRead_fileFormat end subroutine inputRead_fileFormat
@ -297,13 +297,13 @@ subroutine inputRead_tableStyles(initialcond,hypoelastic,fileContent)
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 6) cycle if (chunkPos(1) < 6) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'table') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'table') then
initialcond = IO_intValue(fileContent(l),chunkPos,4) initialcond = IO_intValue(fileContent(l),chunkPos,4)
hypoelastic = IO_intValue(fileContent(l),chunkPos,5) hypoelastic = IO_intValue(fileContent(l),chunkPos,5)
exit exit
endif end if
enddo end do
end subroutine inputRead_tableStyles end subroutine inputRead_tableStyles
@ -324,23 +324,23 @@ subroutine inputRead_matNumber(matNumber, &
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'hypoelastic') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'hypoelastic') then
if (len_trim(fileContent(l+1))/=0) then if (len_trim(fileContent(l+1))/=0) then
chunkPos = IO_stringPos(fileContent(l+1)) chunkPos = IO_stringPos(fileContent(l+1))
data_blocks = IO_intValue(fileContent(l+1),chunkPos,1) data_blocks = IO_intValue(fileContent(l+1),chunkPos,1)
else else
data_blocks = 1 data_blocks = 1
endif end if
allocate(matNumber(data_blocks), source = 0) allocate(matNumber(data_blocks), source = 0)
do i = 0, data_blocks - 1 do i = 0, data_blocks - 1
j = i*(2+tableStyle) + 1 j = i*(2+tableStyle) + 1
chunkPos = IO_stringPos(fileContent(l+1+j)) chunkPos = IO_stringPos(fileContent(l+1+j))
matNumber(i+1) = IO_intValue(fileContent(l+1+j),chunkPos,1) matNumber(i+1) = IO_intValue(fileContent(l+1+j),chunkPos,1)
enddo end do
exit exit
endif end if
enddo end do
end subroutine inputRead_matNumber end subroutine inputRead_matNumber
@ -362,14 +362,14 @@ subroutine inputRead_NnodesAndElements(nNodes,nElems,&
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) 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 if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'sizing') then
nElems = IO_IntValue (fileContent(l),chunkPos,3) 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)) chunkPos = IO_stringPos(fileContent(l+1))
nNodes = IO_IntValue (fileContent(l+1),chunkPos,2) nNodes = IO_IntValue (fileContent(l+1),chunkPos,2)
endif end if
enddo end do
end subroutine inputRead_NnodesAndElements end subroutine inputRead_NnodesAndElements
@ -392,13 +392,13 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,&
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 2) cycle if (chunkPos(1) < 2) cycle
if(IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'define' .and. & if (IO_lc(IO_StringValue(fileContent(l),chunkPos,1)) == 'define' .and. &
IO_lc(IO_StringValue(fileContent(l),chunkPos,2)) == 'element') then IO_lc(IO_StringValue(fileContent(l),chunkPos,2)) == 'element') then
nElemSets = nElemSets + 1 nElemSets = nElemSets + 1
chunkPos = IO_stringPos(fileContent(l+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) & elemInCurrentSet = 1 + abs( IO_intValue(fileContent(l+1),chunkPos,3) &
-IO_intValue(fileContent(l+1),chunkPos,1)) -IO_intValue(fileContent(l+1),chunkPos,1))
else else
@ -408,15 +408,15 @@ subroutine inputRead_NelemSets(nElemSets,maxNelemInSet,&
i = i + 1 i = i + 1
chunkPos = IO_stringPos(fileContent(l+i)) chunkPos = IO_stringPos(fileContent(l+i))
elemInCurrentSet = elemInCurrentSet + chunkPos(1) - 1 ! add line's count when assuming 'c' 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 elemInCurrentSet = elemInCurrentSet + 1 ! data ended
exit exit
endif end if
enddo end do
endif end if
maxNelemInSet = max(maxNelemInSet, elemInCurrentSet) maxNelemInSet = max(maxNelemInSet, elemInCurrentSet)
endif end if
enddo end do
end subroutine inputRead_NelemSets end subroutine inputRead_NelemSets
@ -442,14 +442,14 @@ subroutine inputRead_mapElemSets(nameElemSet,mapElemSet,&
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 2) cycle if (chunkPos(1) < 2) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'define' .and. & if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'define' .and. &
IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'element') then IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'element') then
elemSet = elemSet+1 elemSet = elemSet+1
nameElemSet(elemSet) = trim(IO_stringValue(fileContent(l),chunkPos,4)) nameElemSet(elemSet) = trim(IO_stringValue(fileContent(l),chunkPos,4))
mapElemSet(:,elemSet) = continuousIntValues(fileContent(l+1:),size(mapElemSet,1)-1,nameElemSet,mapElemSet,size(nameElemSet)) mapElemSet(:,elemSet) = continuousIntValues(fileContent(l+1:),size(mapElemSet,1)-1,nameElemSet,mapElemSet,size(nameElemSet))
endif end if
enddo end do
end subroutine inputRead_mapElemSets end subroutine inputRead_mapElemSets
@ -473,8 +473,8 @@ subroutine inputRead_mapElems(FEM2DAMASK, &
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then
j = 0 j = 0
do i = 1,nElems do i = 1,nElems
chunkPos = IO_stringPos(fileContent(l+1+i+j)) chunkPos = IO_stringPos(fileContent(l+1+i+j))
@ -484,17 +484,17 @@ subroutine inputRead_mapElems(FEM2DAMASK, &
j = j + 1 j = j + 1
chunkPos = IO_stringPos(fileContent(l+1+i+j)) chunkPos = IO_stringPos(fileContent(l+1+i+j))
nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1)
enddo end do
enddo end do
exit exit
endif end if
enddo end do
call math_sort(map_unsorted) call math_sort(map_unsorted)
allocate(FEM2DAMASK(minval(map_unsorted(1,:)):maxval(map_unsorted(1,:))),source=-1) allocate(FEM2DAMASK(minval(map_unsorted(1,:)):maxval(map_unsorted(1,:))),source=-1)
do i = 1, nElems do i = 1, nElems
FEM2DAMASK(map_unsorted(1,i)) = map_unsorted(2,i) FEM2DAMASK(map_unsorted(1,i)) = map_unsorted(2,i)
enddo end do
end subroutine inputRead_mapElems end subroutine inputRead_mapElems
@ -517,21 +517,21 @@ subroutine inputRead_mapNodes(FEM2DAMASK, &
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then
chunkPos = [1,1,10] chunkPos = [1,1,10]
do i = 1,nNodes do i = 1,nNodes
map_unsorted(:,i) = [IO_intValue(fileContent(l+1+i),chunkPos,1),i] map_unsorted(:,i) = [IO_intValue(fileContent(l+1+i),chunkPos,1),i]
enddo end do
exit exit
endif end if
enddo end do
call math_sort(map_unsorted) call math_sort(map_unsorted)
allocate(FEM2DAMASK(minval(map_unsorted(1,:)):maxval(map_unsorted(1,:))),source=-1) allocate(FEM2DAMASK(minval(map_unsorted(1,:)):maxval(map_unsorted(1,:))),source=-1)
do i = 1, nNodes do i = 1, nNodes
FEM2DAMASK(map_unsorted(1,i)) = map_unsorted(2,i) FEM2DAMASK(map_unsorted(1,i)) = map_unsorted(2,i)
enddo end do
end subroutine inputRead_mapNodes end subroutine inputRead_mapNodes
@ -554,16 +554,16 @@ subroutine inputRead_elemNodes(nodes, &
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'coordinates') then
chunkPos = [4,1,10,11,30,31,50,51,70] chunkPos = [4,1,10,11,30,31,50,51,70]
do i=1,nNode do i=1,nNode
m = discretization_Marc_FEM2DAMASK_node(IO_intValue(fileContent(l+1+i),chunkPos,1)) 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)] nodes(1:3,m) = [(mesh_unitlength * IO_floatValue(fileContent(l+1+i),chunkPos,j+1),j=1,3)]
enddo end do
exit exit
endif end if
enddo end do
end subroutine inputRead_elemNodes end subroutine inputRead_elemNodes
@ -585,8 +585,8 @@ subroutine inputRead_elemType(elem, &
t = -1 t = -1
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then
j = 0 j = 0
do i=1,nElem ! read all elements do i=1,nElem ! read all elements
chunkPos = IO_stringPos(fileContent(l+1+i+j)) chunkPos = IO_stringPos(fileContent(l+1+i+j))
@ -596,17 +596,17 @@ subroutine inputRead_elemType(elem, &
else else
t_ = mapElemtype(IO_stringValue(fileContent(l+1+i+j),chunkPos,2)) 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) 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) remainingChunks = elem%nNodes - (chunkPos(1) - 2)
do while(remainingChunks > 0) do while(remainingChunks > 0)
j = j + 1 j = j + 1
chunkPos = IO_stringPos(fileContent(l+1+i+j)) chunkPos = IO_stringPos(fileContent(l+1+i+j))
remainingChunks = remainingChunks - chunkPos(1) remainingChunks = remainingChunks - chunkPos(1)
enddo end do
enddo end do
exit exit
endif end if
enddo end do
contains contains
@ -676,8 +676,8 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent)
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 1) cycle if (chunkPos(1) < 1) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'connectivity') then
j = 0 j = 0
do i = 1,nElem do i = 1,nElem
chunkPos = IO_stringPos(fileContent(l+1+i+j)) chunkPos = IO_stringPos(fileContent(l+1+i+j))
@ -686,7 +686,7 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent)
do k = 1,chunkPos(1)-2 do k = 1,chunkPos(1)-2
inputRead_connectivityElem(k,e) = & inputRead_connectivityElem(k,e) = &
discretization_Marc_FEM2DAMASK_node(IO_IntValue(fileContent(l+1+i+j),chunkPos,k+2)) discretization_Marc_FEM2DAMASK_node(IO_IntValue(fileContent(l+1+i+j),chunkPos,k+2))
enddo end do
nNodesAlreadyRead = chunkPos(1) - 2 nNodesAlreadyRead = chunkPos(1) - 2
do while(nNodesAlreadyRead < nNodes) ! read on if not all nodes in one line do while(nNodesAlreadyRead < nNodes) ! read on if not all nodes in one line
j = j + 1 j = j + 1
@ -694,14 +694,14 @@ function inputRead_connectivityElem(nElem,nNodes,fileContent)
do k = 1,chunkPos(1) do k = 1,chunkPos(1)
inputRead_connectivityElem(nNodesAlreadyRead+k,e) = & inputRead_connectivityElem(nNodesAlreadyRead+k,e) = &
discretization_Marc_FEM2DAMASK_node(IO_IntValue(fileContent(l+1+i+j),chunkPos,k)) discretization_Marc_FEM2DAMASK_node(IO_IntValue(fileContent(l+1+i+j),chunkPos,k))
enddo end do
nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1)
enddo end do
endif end if
enddo end do
exit exit
endif end if
enddo end do
end function inputRead_connectivityElem end function inputRead_connectivityElem
@ -733,8 +733,8 @@ subroutine inputRead_material(materialAt,&
do l = 1, size(fileContent) do l = 1, size(fileContent)
chunkPos = IO_stringPos(fileContent(l)) chunkPos = IO_stringPos(fileContent(l))
if(chunkPos(1) < 2) cycle if (chunkPos(1) < 2) cycle
if(IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'initial' .and. & if (IO_lc(IO_stringValue(fileContent(l),chunkPos,1)) == 'initial' .and. &
IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'state') then IO_lc(IO_stringValue(fileContent(l),chunkPos,2)) == 'state') then
k = merge(2,1,initialcondTableStyle == 2) k = merge(2,1,initialcondTableStyle == 2)
chunkPos = IO_stringPos(fileContent(l+k)) chunkPos = IO_stringPos(fileContent(l+k))
@ -749,14 +749,14 @@ subroutine inputRead_material(materialAt,&
do i = 1,contInts(1) do i = 1,contInts(1)
e = discretization_Marc_FEM2DAMASK_elem(contInts(1+i)) e = discretization_Marc_FEM2DAMASK_elem(contInts(1+i))
materialAt(e) = ID + 1 materialAt(e) = ID + 1
enddo end do
if (initialcondTableStyle == 0) m = m + 1 if (initialcondTableStyle == 0) m = m + 1
enddo end do
endif end if
endif end if
enddo end do
if(any(materialAt < 1)) call IO_error(180) if (any(materialAt < 1)) call IO_error(180)
end subroutine inputRead_material end subroutine inputRead_material
@ -791,9 +791,9 @@ pure subroutine buildCells(connectivity,definition, &
do c = 1, elem%NcellNodes do c = 1, elem%NcellNodes
realNode: if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == 1) then realNode: if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == 1) then
where(connectivity(:,:,e) == -c) connectivity(:,:,e) = connectivity_elem(c,e) where(connectivity(:,:,e) == -c) connectivity(:,:,e) = connectivity_elem(c,e)
endif realNode end if realNode
enddo end do
enddo end do
nCellNode = maxval(connectivity_elem) nCellNode = maxval(connectivity_elem)
@ -806,7 +806,7 @@ pure subroutine buildCells(connectivity,definition, &
do c = 1, elem%NcellNodes do c = 1, elem%NcellNodes
if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == nParentNodes) & if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == nParentNodes) &
candidates_local = [candidates_local,c] candidates_local = [candidates_local,c]
enddo end do
s = size(candidates_local) s = size(candidates_local)
if (allocated(candidates_global)) deallocate(candidates_global) 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' if (elem%cellNodeParentNodeWeights(j,c) /= 0) then ! real node 'j' partly defines cell node 'c'
p = p + 1 p = p + 1
parentsAndWeights(p,1:2) = [connectivity_elem(j,e),elem%cellNodeParentNodeWeights(j,c)] parentsAndWeights(p,1:2) = [connectivity_elem(j,e),elem%cellNodeParentNodeWeights(j,c)]
endif end if
enddo end do
! store (and order) real node IDs and their weights together with the element number and local ID ! store (and order) real node IDs and their weights together with the element number and local ID
do p = 1, nParentNodes do p = 1, nParentNodes
m = maxloc(parentsAndWeights(:,1),1) 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] candidates_global(nParentNodes*2+1:nParentNodes*2+2,candidateID) = [e,c]
parentsAndWeights(m,1) = -huge(parentsAndWeights(m,1)) ! out of the competition parentsAndWeights(m,1) = -huge(parentsAndWeights(m,1)) ! out of the competition
enddo end do
enddo end do
enddo end do
! sort according to real node IDs + weight (from left to right) ! sort according to real node IDs + weight (from left to right)
call math_sort(candidates_global,sortDim=1) ! sort according to first column 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) do while (n+j<= size(candidates_local)*Nelem)
if (candidates_global(p-1,n+j)/=candidates_global(p-1,n)) exit if (candidates_global(p-1,n+j)/=candidates_global(p-1,n)) exit
j = j + 1 j = j + 1
enddo end do
e = n+j-1 e = n+j-1
if (any(candidates_global(p,n:e)/=candidates_global(p,n))) & if (any(candidates_global(p,n:e)/=candidates_global(p,n))) &
call math_sort(candidates_global(:,n:e),sortDim=p) call math_sort(candidates_global(:,n:e),sortDim=p)
n = e+1 n = e+1
enddo end do
enddo end do
i = uniqueRows(candidates_global(1:2*nParentNodes,:)) i = uniqueRows(candidates_global(1:2*nParentNodes,:))
allocate(definition(nParentNodes-1)%parents(i,nParentNodes)) allocate(definition(nParentNodes-1)%parents(i,nParentNodes))
@ -876,15 +876,15 @@ pure subroutine buildCells(connectivity,definition, &
end where end where
j = j+1 j = j+1
enddo end do
nCellNode = nCellNode + 1 nCellNode = nCellNode + 1
definition(nParentNodes-1)%parents(i,:) = parentsAndWeights(:,1) definition(nParentNodes-1)%parents(i,:) = parentsAndWeights(:,1)
definition(nParentNodes-1)%weights(i,:) = parentsAndWeights(:,2) definition(nParentNodes-1)%weights(i,:) = parentsAndWeights(:,2)
i = i + 1 i = i + 1
n = n+j n = n+j
enddo end do
enddo end do
contains contains
!------------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------------
@ -906,10 +906,10 @@ pure subroutine buildCells(connectivity,definition, &
do while (r+d<= size(A,2)) do while (r+d<= size(A,2))
if (any(A(:,r)/=A(:,r+d))) exit if (any(A(:,r)/=A(:,r+d))) exit
d = d+1 d = d+1
enddo end do
u = u+1 u = u+1
r = r+d r = r+d
enddo end do
end function uniqueRows end function uniqueRows
@ -939,10 +939,10 @@ pure function buildCellNodes(node_elem)
buildCellNodes(:,n) = buildCellNodes(:,n) & buildCellNodes(:,n) = buildCellNodes(:,n) &
+ buildCellNodes(:,cellNodeDefinition(i)%parents(j,k)) & + buildCellNodes(:,cellNodeDefinition(i)%parents(j,k)) &
* real(cellNodeDefinition(i)%weights(j,k),pReal) * real(cellNodeDefinition(i)%weights(j,k),pReal)
enddo end do
buildCellNodes(:,n) = buildCellNodes(:,n)/real(sum(cellNodeDefinition(i)%weights(j,:)),pReal) buildCellNodes(:,n) = buildCellNodes(:,n)/real(sum(cellNodeDefinition(i)%weights(j,:)),pReal)
enddo end do
enddo end do
end function buildCellNodes end function buildCellNodes
@ -970,9 +970,9 @@ pure function buildIPcoordinates(node_cell)
do n = 1, size(connectivity_cell_reshaped,1) do n = 1, size(connectivity_cell_reshaped,1)
buildIPcoordinates(:,i) = buildIPcoordinates(:,i) & buildIPcoordinates(:,i) = buildIPcoordinates(:,i) &
+ node_cell(:,connectivity_cell_reshaped(n,i)) + node_cell(:,connectivity_cell_reshaped(n,i))
enddo end do
buildIPcoordinates(:,i) = buildIPcoordinates(:,i)/real(size(connectivity_cell_reshaped,1),pReal) buildIPcoordinates(:,i) = buildIPcoordinates(:,i)/real(size(connectivity_cell_reshaped,1),pReal)
enddo end do
end function buildIPcoordinates end function buildIPcoordinates
@ -1031,8 +1031,8 @@ pure function IPvolume(elem,node)
+ dot_product((x7-x1), math_cross((x5-x0), (x7-x4)+(x3-x0))) + dot_product((x7-x1), math_cross((x5-x0), (x7-x4)+(x3-x0)))
IPvolume(i,e) = IPvolume(i,e)/12.0_pReal IPvolume(i,e) = IPvolume(i,e)/12.0_pReal
end select end select
enddo end do
enddo end do
end function IPvolume 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) & 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), & + 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 nodePos(1:3,mod(n+1,m)+1) - nodePos(1:3,n)) * 0.5_pReal
enddo end do
end select end select
enddo end do
enddo end do
enddo end do
end function IPareaNormal end function IPareaNormal
@ -1109,10 +1109,10 @@ function IPneighborhood(elem)
do n = 1, size(face_unordered) do n = 1, size(face_unordered)
face(n,c) = minval(face_unordered) face(n,c) = minval(face_unordered)
face_unordered(minloc(face_unordered)) = huge(face_unordered) face_unordered(minloc(face_unordered)) = huge(face_unordered)
enddo end do
face(n:n+3,c) = [e,i,f] face(n:n+3,c) = [e,i,f]
enddo end do
enddo; enddo end do; end do
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! sort face definitions ! sort face definitions
@ -1122,20 +1122,20 @@ function IPneighborhood(elem)
e = 1 e = 1
do while (e < size(face,2)) do while (e < size(face,2))
e = e + 1 e = e + 1
if(any(face(:c,s) /= face(:c,e))) then if (any(face(:c,s) /= face(:c,e))) then
if(e-1/=s) call math_sort(face(:,s:e-1),sortDim=c) if (e-1/=s) call math_sort(face(:,s:e-1),sortDim=c)
s = e s = e
endif end if
enddo end do
enddo end do
IPneighborhood = 0 IPneighborhood = 0
do c=1, size(face,2) - 1 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+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) IPneighborhood(:,face(n+2,c+0),face(n+1,c+0),face(n+0,c+0)) = face(n:n+3,c+1)
endif end if
enddo end do
end function IPneighborhood 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 if (IO_stringValue(fileContent(l),chunkPos,1) == lookupName(i)) then ! found matching name
continuousIntValues = lookupMap(:,i) ! return resp. entity list continuousIntValues = lookupMap(:,i) ! return resp. entity list
exit exit
endif end if
enddo end do
exit exit
elseif(containsRange(fileContent(l),chunkPos)) then elseif (containsRange(fileContent(l),chunkPos)) then
first = IO_intValue(fileContent(l),chunkPos,1) first = IO_intValue(fileContent(l),chunkPos,1)
last = IO_intValue(fileContent(l),chunkPos,3) last = IO_intValue(fileContent(l),chunkPos,3)
do i = first, last, sign(1,last-first) do i = first, last, sign(1,last-first)
continuousIntValues(1) = continuousIntValues(1) + 1 continuousIntValues(1) = continuousIntValues(1) + 1
continuousIntValues(1+continuousIntValues(1)) = i continuousIntValues(1+continuousIntValues(1)) = i
enddo end do
exit exit
else else
do i = 1,chunkPos(1)-1 ! interpret up to second to last value do i = 1,chunkPos(1)-1 ! interpret up to second to last value
continuousIntValues(1) = continuousIntValues(1) + 1 continuousIntValues(1) = continuousIntValues(1) + 1
continuousIntValues(1+continuousIntValues(1)) = IO_intValue(fileContent(l),chunkPos,i) 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 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) + 1
continuousIntValues(1+continuousIntValues(1)) = IO_intValue(fileContent(l),chunkPos,chunkPos(1)) continuousIntValues(1+continuousIntValues(1)) = IO_intValue(fileContent(l),chunkPos,chunkPos(1))
exit exit
endif end if
endif end if
enddo end do
end function continuousIntValues end function continuousIntValues
@ -1208,9 +1208,9 @@ logical function containsRange(str,chunkPos)
containsRange = .False. containsRange = .False.
if(chunkPos(1) == 3) then if (chunkPos(1) == 3) then
if(IO_lc(IO_stringValue(str,chunkPos,2)) == 'to') containsRange = .True. if (IO_lc(IO_stringValue(str,chunkPos,2)) == 'to') containsRange = .True.
endif end if
end function containsRange 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 math
use rotations use rotations
use polynomials use polynomials
use tables
use lattice use lattice
use material use material
use phase use phase
@ -72,26 +73,27 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Initialize all modules. !> @brief Initialize all modules.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_initAll subroutine materialpoint_initAll()
call DAMASK_interface_init call DAMASK_interface_init()
call prec_init call prec_init()
call IO_init call IO_init()
call YAML_types_init call YAML_types_init()
call YAML_parse_init call YAML_parse_init()
call HDF5_utilities_init call HDF5_utilities_init()
call results_init(.false.) call results_init(.false.)
call config_init call config_init()
call math_init call math_init()
call rotations_init call rotations_init()
call polynomials_init call polynomials_init()
call lattice_init call tables_init()
call discretization_Marc_init call lattice_init()
call discretization_Marc_init()
call material_init(.false.) call material_init(.false.)
call phase_init call phase_init()
call homogenization_init call homogenization_init()
call materialpoint_init call materialpoint_init()
call config_deallocate call config_deallocate()
end subroutine materialpoint_initAll end subroutine materialpoint_initAll
@ -99,7 +101,7 @@ end subroutine materialpoint_initAll
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief allocate the arrays defined in module materialpoint and initialize them !> @brief allocate the arrays defined in module materialpoint and initialize them
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_init subroutine materialpoint_init()
type(tList), pointer :: & type(tList), pointer :: &
debug_materialpoint debug_materialpoint
@ -121,12 +123,12 @@ subroutine materialpoint_init
debugmaterialpoint%element = config_debug%get_asInt('element',defaultVal = 1) debugmaterialpoint%element = config_debug%get_asInt('element',defaultVal = 1)
debugmaterialpoint%ip = config_debug%get_asInt('integrationpoint',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_cs: ', shape(materialpoint_cs)
print'(a32,1x,6(i8,1x))', 'materialpoint_dcsdE: ', shape(materialpoint_dcsdE) print'(a32,1x,6(i8,1x))', 'materialpoint_dcsdE: ', shape(materialpoint_dcsdE)
print'(a32,1x,6(i8,1x),/)', 'materialpoint_dcsdE_knownGood: ', shape(materialpoint_dcsdE_knownGood) print'(a32,1x,6(i8,1x),/)', 'materialpoint_dcsdE_knownGood: ', shape(materialpoint_dcsdE_knownGood)
flush(IO_STDOUT) flush(IO_STDOUT)
endif end if
end subroutine materialpoint_init end subroutine materialpoint_init
@ -171,7 +173,7 @@ subroutine materialpoint_general(mode, ffn, ffn1, temperature_inp, dt, elFE, ip,
if (terminallyIll) & if (terminallyIll) &
print'(a,/)', '# --- terminallyIll --- #' print'(a,/)', '# --- terminallyIll --- #'
print'(a,/)', '#############################################'; flush (6) print'(a,/)', '#############################################'; flush (6)
endif end if
if (iand(mode, materialpoint_BACKUPJACOBIAN) /= 0) & if (iand(mode, materialpoint_BACKUPJACOBIAN) /= 0) &
materialpoint_dcsde_knownGood = materialpoint_dcsde 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) & - 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) & + 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)) + 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) & 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)) 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.) materialpoint_dcsde(1:6,1:6,ip,elCP) = math_sym3333to66(J_inverse * H_sym,weighted=.false.)
endif terminalIllness end if terminalIllness
endif validCalculation end if validCalculation
if (debugmaterialpoint%extensive & if (debugmaterialpoint%extensive &
.and. ((debugmaterialpoint%element == elCP .and. debugmaterialpoint%ip == ip) .or. .not. debugmaterialpoint%selective)) then .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)/))', & 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 '<< materialpoint >> Jacobian/GPa at elFE ip ', elFE, ip, transpose(materialpoint_dcsdE(1:6,1:6,ip,elCP))*1.0e-9_pReal
flush(IO_STDOUT) flush(IO_STDOUT)
endif end if
endif end if
if (all(abs(materialpoint_dcsdE(1:6,1:6,ip,elCP)) < 1e-10_pReal)) & 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) 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. !> @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) 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. !> @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) 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:),':') d = s + scan(flow_string(s+1:),':')
e = d + find_end(flow_string(d+1:),'}') e = d + find_end(flow_string(d+1:),'}')
key = trim(adjustl(flow_string(s+1: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) myVal => parse_flow(flow_string(d+1:e-1)) ! parse items (recursively)
select type (node) select type (node)
@ -143,7 +145,7 @@ recursive function parse_flow(YAML_flow) result(node)
allocate(tScalar::node) allocate(tScalar::node)
select type (node) select type (node)
class is (tScalar) class is (tScalar)
if(quotedString(flow_string)) then if (quotedString(flow_string)) then
node = trim(adjustl(flow_string(2:len(flow_string)-1))) node = trim(adjustl(flow_string(2:len(flow_string)-1)))
else else
node = trim(adjustl(flow_string)) node = trim(adjustl(flow_string))
@ -198,7 +200,7 @@ logical function quotedString(line)
if (scan(line(:1),IO_QUOTES) == 1) then if (scan(line(:1),IO_QUOTES) == 1) then
quotedString = .true. 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 if
end function quotedString end function quotedString
@ -245,7 +247,7 @@ integer function indentDepth(line,offset)
integer, optional,intent(in) :: offset integer, optional,intent(in) :: offset
indentDepth = verify(line,IO_WHITESPACE) -1 indentDepth = verify(line,IO_WHITESPACE) -1
if(present(offset)) indentDepth = indentDepth + offset if (present(offset)) indentDepth = indentDepth + offset
end function indentDepth end function indentDepth
@ -285,7 +287,7 @@ logical function isListItem(line)
character(len=*), intent(in) :: line character(len=*), intent(in) :: line
isListItem = .false. 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 isListItem = scan(trim(adjustl(line)),' ') == 2
else else
isListItem = trim(adjustl(line)) == '-' isListItem = trim(adjustl(line)) == '-'
@ -302,8 +304,8 @@ logical function isKeyValue(line)
character(len=*), intent(in) :: line character(len=*), intent(in) :: line
isKeyValue = .false. isKeyValue = .false.
if( .not. isKey(line) .and. index(IO_rmComment(line),':') > 0 .and. .not. isFlow(line)) then if ( .not. isKey(line) .and. index(IO_rmComment(line),':') > 0 .and. .not. isFlow(line)) then
if(index(IO_rmComment(line),': ') > 0) isKeyValue = .true. if (index(IO_rmComment(line),': ') > 0) isKeyValue = .true.
end if end if
end function isKeyValue end function isKeyValue
@ -317,7 +319,7 @@ logical function isKey(line)
character(len=*), intent(in) :: line character(len=*), intent(in) :: line
if(len(IO_rmComment(line)) == 0) then if (len(IO_rmComment(line)) == 0) then
isKey = .false. isKey = .false.
else else
isKey = index(IO_rmComment(line),':',back=.false.) == len(IO_rmComment(line)) .and. & 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. empty = .true.
do while(empty .and. len_trim(blck(s_blck:)) /= 0) 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 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 do
end subroutine skip_empty_lines end subroutine skip_empty_lines
@ -372,10 +374,10 @@ subroutine skip_file_header(blck,s_blck)
character(len=:), allocatable :: line character(len=:), allocatable :: line
line = IO_rmComment(blck(s_blck:s_blck + index(blck(s_blck:),IO_EOL) - 2)) 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) s_blck = s_blck + index(blck(s_blck:),IO_EOL)
call skip_empty_lines(blck,s_blck) 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) s_blck = s_blck + index(blck(s_blck:),IO_EOL)
else else
call IO_error(708,ext_msg = line) call IO_error(708,ext_msg = line)
@ -400,8 +402,8 @@ logical function flow_is_closed(str,e_char)
flow_is_closed = .false. flow_is_closed = .false.
N_sq = 0 N_sq = 0
N_cu = 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) do i = 1, len_trim(line)
flow_is_closed = (N_sq==0 .and. N_cu==0 .and. scan(line(i:i),e_char) == 1) 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:)) indent_next = indentDepth(blck(s_blck:))
end do end do
if(scan(inline,",") > 0) inline = '"'//inline//'"' if (scan(inline,",") > 0) inline = '"'//inline//'"'
end subroutine list_item_inline end subroutine list_item_inline
@ -483,19 +485,19 @@ recursive subroutine line_isFlow(flow,s_flow,line)
list_chunk, & list_chunk, &
dict_chunk dict_chunk
if(index(adjustl(line),'[') == 1) then if (index(adjustl(line),'[') == 1) then
s = index(line,'[') s = index(line,'[')
flow(s_flow:s_flow) = '[' flow(s_flow:s_flow) = '['
s_flow = s_flow +1 s_flow = s_flow +1
do while(s < len_trim(line)) do while(s < len_trim(line))
list_chunk = s + find_end(line(s+1:),']') 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) = '{' flow(s_flow:s_flow) = '{'
s_flow = s_flow +1 s_flow = s_flow +1
call keyValue_toFlow(flow,s_flow,line(s+1:list_chunk-1)) call keyValue_toFlow(flow,s_flow,line(s+1:list_chunk-1))
flow(s_flow:s_flow) = '}' flow(s_flow:s_flow) = '}'
s_flow = s_flow +1 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)) call line_isFlow(flow,s_flow,line(s+1:list_chunk-1))
else else
call line_toFlow(flow,s_flow,line(s+1:list_chunk-1)) 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) = ']' flow(s_flow:s_flow) = ']'
s_flow = s_flow+1 s_flow = s_flow+1
elseif(index(adjustl(line),'{') == 1) then elseif (index(adjustl(line),'{') == 1) then
s = index(line,'{') s = index(line,'{')
flow(s_flow:s_flow) = '{' flow(s_flow:s_flow) = '{'
s_flow = s_flow +1 s_flow = s_flow +1
do while(s < len_trim(line)) do while(s < len_trim(line))
dict_chunk = s + find_end(line(s+1:),'}') 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)) call keyValue_toFlow(flow,s_flow,line(s+1:dict_chunk-1))
flow(s_flow:s_flow+1) = ', ' flow(s_flow:s_flow+1) = ', '
s_flow = s_flow +2 s_flow = s_flow +2
s = s + find_end(line(s+1:),'}') s = s + find_end(line(s+1:),'}')
end do end do
s_flow = s_flow -1 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) = '}' flow(s_flow:s_flow) = '}'
s_flow = s_flow +1 s_flow = s_flow +1
else else
@ -549,8 +551,8 @@ recursive subroutine keyValue_toFlow(flow,s_flow,line)
offset_value offset_value
col_pos = index(line,':') col_pos = index(line,':')
if(line(col_pos+1:col_pos+1) /= ' ') call IO_error(704,ext_msg=line) if (line(col_pos+1:col_pos+1) /= ' ') call IO_error(704,ext_msg=line)
if(isFlow(line(col_pos+1:))) then if (isFlow(line(col_pos+1:))) then
d_flow = len_trim(adjustl(line(:col_pos))) d_flow = len_trim(adjustl(line(:col_pos)))
flow(s_flow:s_flow+d_flow+1) = 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 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)) do while (s_blck <= len_trim(blck))
e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2
line = IO_rmComment(blck(s_blck:e_blck)) line = IO_rmComment(blck(s_blck:e_blck))
if(trim(line) == '---' .or. trim(line) == '...') then if (trim(line) == '---' .or. trim(line) == '...') then
exit exit
elseif (len_trim(line) == 0) then elseif (len_trim(line) == 0) then
s_blck = e_blck + 2 ! forward to next line s_blck = e_blck + 2 ! forward to next line
cycle cycle
elseif(indentDepth(line,offset) > indent) then elseif (indentDepth(line,offset) > indent) then
call decide(blck,flow,s_blck,s_flow,offset) call decide(blck,flow,s_blck,s_flow,offset)
offset = 0 offset = 0
flow(s_flow:s_flow+1) = ', ' flow(s_flow:s_flow+1) = ', '
s_flow = s_flow + 2 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 offset = 0
exit ! job done (lower level) exit ! job done (lower level)
else 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 s_blck = e_blck + 2
call skip_empty_lines(blck,s_blck) call skip_empty_lines(blck,s_blck)
e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2
line = IO_rmComment(blck(s_blck:e_blck)) line = IO_rmComment(blck(s_blck:e_blck))
if(trim(line) == '---') call IO_error(707,ext_msg=line) if (trim(line) == '---') call IO_error(707,ext_msg=line)
if(indentDepth(line) < indent .or. indentDepth(line) == indent) & if (indentDepth(line) < indent .or. indentDepth(line) == indent) &
call IO_error(701,ext_msg=line) call IO_error(701,ext_msg=line)
if(isScalar(line)) then if (isScalar(line)) then
call line_toFlow(flow,s_flow,line) call line_toFlow(flow,s_flow,line)
s_blck = e_blck +2 s_blck = e_blck +2
offset = 0 offset = 0
elseif(isFlow(line)) then elseif (isFlow(line)) then
if(isFlowList(line)) then if (isFlowList(line)) then
call remove_line_break(blck,s_blck,']',flow_line) call remove_line_break(blck,s_blck,']',flow_line)
else else
call remove_line_break(blck,s_blck,'}',flow_line) 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 end if
else ! list item in the same line else ! list item in the same line
line = line(indentDepth(line)+3:) line = line(indentDepth(line)+3:)
if(isScalar(line)) then if (isScalar(line)) then
call list_item_inline(blck,s_blck,inline,offset) call list_item_inline(blck,s_blck,inline,offset)
offset = 0 offset = 0
call line_toFlow(flow,s_flow,inline) call line_toFlow(flow,s_flow,inline)
elseif(isFlow(line)) then elseif (isFlow(line)) then
s_blck = s_blck + index(blck(s_blck:),'-') 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) call remove_line_break(blck,s_blck,']',flow_line)
else else
call remove_line_break(blck,s_blck,'}',flow_line) 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
end if end if
if(isScalar(line) .or. isFlow(line)) then if (isScalar(line) .or. isFlow(line)) then
flow(s_flow:s_flow+1) = ', ' flow(s_flow:s_flow+1) = ', '
s_flow = s_flow + 2 s_flow = s_flow + 2
end if end if
@ -702,33 +704,33 @@ recursive subroutine dct(blck,flow,s_blck,s_flow,offset)
do while (s_blck <= len_trim(blck)) do while (s_blck <= len_trim(blck))
e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2
line = IO_rmComment(blck(s_blck:e_blck)) line = IO_rmComment(blck(s_blck:e_blck))
if(trim(line) == '---' .or. trim(line) == '...') then if (trim(line) == '---' .or. trim(line) == '...') then
exit exit
elseif (len_trim(line) == 0) then elseif (len_trim(line) == 0) then
s_blck = e_blck + 2 ! forward to next line s_blck = e_blck + 2 ! forward to next line
cycle cycle
elseif(indentDepth(line,offset) < indent) then elseif (indentDepth(line,offset) < indent) then
if(isScalar(line) .or. isFlow(line) .and. previous_isKey) & if (isScalar(line) .or. isFlow(line) .and. previous_isKey) &
call IO_error(701,ext_msg=line) call IO_error(701,ext_msg=line)
offset = 0 offset = 0
exit ! job done (lower level) 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 offset = 0
call decide(blck,flow,s_blck,s_flow,offset) call decide(blck,flow,s_blck,s_flow,offset)
else else
if(isScalar(line)) call IO_error(701,ext_msg=line) if (isScalar(line)) call IO_error(701,ext_msg=line)
if(isFlow(line)) call IO_error(702,ext_msg=line) if (isFlow(line)) call IO_error(702,ext_msg=line)
line = line(indentDepth(line)+1:) line = line(indentDepth(line)+1:)
if(previous_isKey) then if (previous_isKey) then
flow(s_flow-1:s_flow) = ', ' flow(s_flow-1:s_flow) = ', '
s_flow = s_flow + 1 s_flow = s_flow + 1
end if end if
if(isKeyValue(line)) then if (isKeyValue(line)) then
col_pos = index(line,':') col_pos = index(line,':')
if(isFlow(line(col_pos+1:))) then if (isFlow(line(col_pos+1:))) then
if(isFlowList(line(col_pos+1:))) then if (isFlowList(line(col_pos+1:))) then
call remove_line_break(blck,s_blck,']',flow_line) call remove_line_break(blck,s_blck,']',flow_line)
else else
call remove_line_break(blck,s_blck,'}',flow_line) 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
end if end if
if(isScalar(line) .or. isKeyValue(line)) then if (isScalar(line) .or. isKeyValue(line)) then
flow(s_flow:s_flow) = ',' flow(s_flow:s_flow) = ','
s_flow = s_flow + 1 s_flow = s_flow + 1
previous_isKey = .false. 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) 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 integer :: e_blck
character(len=:), allocatable :: line,flow_line 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) call skip_empty_lines(blck,s_blck)
e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2 e_blck = s_blck + index(blck(s_blck:),IO_EOL) - 2
line = IO_rmComment(blck(s_blck:e_blck)) 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 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 s_blck = e_blck +2
call decide(blck,flow,s_blck,s_flow,offset) call decide(blck,flow,s_blck,s_flow,offset)
elseif (isListItem(line)) then 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) call lst(blck,flow,s_blck,s_flow,offset)
flow(s_flow:s_flow) = ']' flow(s_flow:s_flow) = ']'
s_flow = s_flow + 1 s_flow = s_flow + 1
elseif(isKey(line) .or. isKeyValue(line)) then elseif (isKey(line) .or. isKeyValue(line)) then
flow(s_flow:s_flow) = '{' flow(s_flow:s_flow) = '{'
s_flow = s_flow + 1 s_flow = s_flow + 1
call dct(blck,flow,s_blck,s_flow,offset) call dct(blck,flow,s_blck,s_flow,offset)
flow(s_flow:s_flow) = '}' flow(s_flow:s_flow) = '}'
s_flow = s_flow + 1 s_flow = s_flow + 1
elseif(isFlow(line)) then elseif (isFlow(line)) then
if(isFlowList(line)) then if (isFlowList(line)) then
call remove_line_break(blck,s_blck,']',flow_line) call remove_line_break(blck,s_blck,']',flow_line)
else else
call remove_line_break(blck,s_blck,'}',flow_line) 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 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) function to_flow(blck)
@ -833,18 +836,18 @@ function to_flow(blck)
s_blck = 1 s_blck = 1
offset = 0 offset = 0
if(len_trim(blck) /= 0) then if (len_trim(blck) /= 0) then
call skip_empty_lines(blck,s_blck) call skip_empty_lines(blck,s_blck)
call skip_file_header(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)) 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) call decide(blck,to_flow,s_blck,s_flow,offset)
end if end if
line = IO_rmComment(blck(s_blck:s_blck+index(blck(s_blck:),IO_EOL)-2)) 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)) to_flow = trim(to_flow(:s_flow-1))
end_line = index(to_flow,IO_EOL) 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 end function to_flow
@ -852,7 +855,7 @@ end function to_flow
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Check correctness of some YAML functions. !> @brief Check correctness of some YAML functions.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine selfTest subroutine selfTest()
if (indentDepth(' a') /= 1) error stop 'indentDepth' if (indentDepth(' a') /= 1) error stop 'indentDepth'
if (indentDepth('a') /= 0) 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 (.not. isKey(' a: #')) error stop 'isKey' if (.not. isKey(' a: #')) error stop 'isKey'
if( 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:b}')) error stop 'isScalar' if ( isScalar('{a:b}')) error stop 'isScalar'
if( isScalar('- a:')) error stop 'isScalar' if ( isScalar('- a:')) error stop 'isScalar'
if(.not. isScalar(' a')) error stop 'isScalar' if (.not. isScalar(' a')) error stop 'isScalar'
basic_list: block basic_list: block
character(len=*), parameter :: block_list = & character(len=*), parameter :: block_list = &
" - Casablanca"//IO_EOL//& " - Casablanca"//IO_EOL//&
" - North by Northwest"//IO_EOL " - North by Northwest"//IO_EOL
character(len=*), parameter :: block_list_newline = & character(len=*), parameter :: block_list_newline = &
" -"//IO_EOL//& " -"//IO_EOL//&
" Casablanca"//IO_EOL//& " Casablanca"//IO_EOL//&
" -"//IO_EOL//& " -"//IO_EOL//&
" North by Northwest"//IO_EOL " North by Northwest"//IO_EOL
character(len=*), parameter :: flow_list = & character(len=*), parameter :: flow_list = &
"[Casablanca, North by Northwest]" "[Casablanca, North by Northwest]"
if (.not. to_flow(block_list) == 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' if (.not. to_flow(block_list_newline) == flow_list) error stop 'to_flow'
end block basic_list end block basic_list
basic_dict: block basic_dict: block
character(len=*), parameter :: block_dict = & character(len=*), parameter :: block_dict = &
" aa: Casablanca"//IO_EOL//& " aa: Casablanca"//IO_EOL//&
" bb: North by Northwest"//IO_EOL " bb: North by Northwest"//IO_EOL
character(len=*), parameter :: block_dict_newline = & character(len=*), parameter :: block_dict_newline = &
" aa:"//IO_EOL//& " aa:"//IO_EOL//&
" Casablanca"//IO_EOL//& " Casablanca"//IO_EOL//&
" bb:"//IO_EOL//& " bb:"//IO_EOL//&
" North by Northwest"//IO_EOL " North by Northwest"//IO_EOL
character(len=*), parameter :: flow_dict = & character(len=*), parameter :: flow_dict = &
"{aa: Casablanca, bb: North by Northwest}" "{aa: Casablanca, bb: North by Northwest}"
if (.not. to_flow(block_dict) == 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' if (.not. to_flow(block_dict_newline) == flow_dict) error stop 'to_flow'
end block basic_dict end block basic_dict
only_flow: block only_flow: block
character(len=*), parameter :: flow_dict = & character(len=*), parameter :: flow_dict = &
" {a: [b,c: {d: e}, f: g, e]}"//IO_EOL " {a: [b,c: {d: e}, f: g, e]}"//IO_EOL
character(len=*), parameter :: flow_list = & character(len=*), parameter :: flow_list = &
" [a,b: c, d,e: {f: g}]"//IO_EOL " [a,b: c, d,e: {f: g}]"//IO_EOL
character(len=*), parameter :: flow_1 = & character(len=*), parameter :: flow_1 = &
"{a: [b, {c: {d: e}}, {f: g}, e]}" "{a: [b, {c: {d: e}}, {f: g}, e]}"
character(len=*), parameter :: flow_2 = & character(len=*), parameter :: flow_2 = &
"[a, {b: c}, d, {e: {f: g}}]" "[a, {b: c}, d, {e: {f: g}}]"
if (.not. to_flow(flow_dict) == flow_1) 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' if (.not. to_flow(flow_list) == flow_2) error stop 'to_flow'
end block only_flow end block only_flow
basic_flow: block basic_flow: block
character(len=*), parameter :: flow_braces = & character(len=*), parameter :: flow_braces = &
" source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]"//IO_EOL " source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]"//IO_EOL
character(len=*), parameter :: flow_mixed_braces = & character(len=*), parameter :: flow_mixed_braces = &
" source: [param: 1, {param: 2}, param: 3, {param: 4}]"//IO_EOL " source: [param: 1, {param: 2}, param: 3, {param: 4}]"//IO_EOL
character(len=*), parameter :: flow = & character(len=*), parameter :: flow = &
"{source: [{param: 1}, {param: 2}, {param: 3}, {param: 4}]}" "{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_braces) == flow) error stop 'to_flow'
if (.not. to_flow(flow_mixed_braces) == flow) error stop 'to_flow' if (.not. to_flow(flow_mixed_braces) == flow) error stop 'to_flow'
end block basic_flow end block basic_flow
multi_line_flow1: block multi_line_flow1: block
character(len=*), parameter :: flow_multi = & character(len=*), parameter :: flow_multi = &
'%YAML 1.1'//IO_EOL//& '%YAML 1.1'//IO_EOL//&
'---'//IO_EOL//& '---'//IO_EOL//&
'a: ["b",'//IO_EOL//& 'a: ["b",'//IO_EOL//&
'c: '//IO_EOL//& 'c: '//IO_EOL//&
'"d", "e"]'//IO_EOL '"d", "e"]'//IO_EOL
character(len=*), parameter :: flow = & character(len=*), parameter :: flow = &
'{a: ["b", {c: "d"}, "e"]}' '{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 end block multi_line_flow1
multi_line_flow2: block multi_line_flow2: block
character(len=*), parameter :: flow_multi = & character(len=*), parameter :: flow_multi = &
"%YAML 1.1"//IO_EOL//& "%YAML 1.1"//IO_EOL//&
"---"//IO_EOL//& "---"//IO_EOL//&
"-"//IO_EOL//& "-"//IO_EOL//&
" a: {b:"//IO_EOL//& " a: {b:"//IO_EOL//&
"[c,"//IO_EOL//& "[c,"//IO_EOL//&
"d"//IO_EOL//& "d"//IO_EOL//&
"e, f]}"//IO_EOL "e, f]}"//IO_EOL
character(len=*), parameter :: flow = & character(len=*), parameter :: flow = &
"[{a: {b: [c, d e, f]}}]" "[{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 end block multi_line_flow2
basic_mixed: block basic_mixed: block
character(len=*), parameter :: block_flow = & character(len=*), parameter :: block_flow = &
"%YAML 1.1"//IO_EOL//& "%YAML 1.1"//IO_EOL//&
" "//IO_EOL//& " "//IO_EOL//&
" "//IO_EOL//& " "//IO_EOL//&
"---"//IO_EOL//& "---"//IO_EOL//&
" aa:"//IO_EOL//& " aa:"//IO_EOL//&
" - "//IO_EOL//& " - "//IO_EOL//&
" "//IO_EOL//& " "//IO_EOL//&
" "//IO_EOL//& " "//IO_EOL//&
" param_1: [a: b, c, {d: {e: [f: g, h]}}]"//IO_EOL//& " param_1: [a: b, c, {d: {e: [f: g, h]}}]"//IO_EOL//&
" - c:d"//IO_EOL//& " - c:d"//IO_EOL//&
" e.f,"//IO_EOL//& " e.f,"//IO_EOL//&
" bb:"//IO_EOL//& " bb:"//IO_EOL//&
" "//IO_EOL//& " "//IO_EOL//&
" - "//IO_EOL//& " - "//IO_EOL//&
" {param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}"//IO_EOL//& " {param_1: [{a: b}, c, {d: {e: [{f: g}, h]}}]}"//IO_EOL//&
"..."//IO_EOL "..."//IO_EOL
character(len=*), parameter :: mixed_flow = & 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]}}]}]}' '{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 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 end subroutine selfTest
#endif #endif

2
src/discretization.f90
View File

@ -64,7 +64,7 @@ subroutine discretization_init(materialAt,&
discretization_NodeCoords0 = NodeCoords0 discretization_NodeCoords0 = NodeCoords0
discretization_NodeCoords = NodeCoords0 discretization_NodeCoords = NodeCoords0
if(present(sharedNodesBegin)) then if (present(sharedNodesBegin)) then
discretization_sharedNodesBegin = sharedNodesBegin discretization_sharedNodesBegin = sharedNodesBegin
else else
discretization_sharedNodesBegin = size(discretization_NodeCoords0,2) 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 subroutine geometry_plastic_nonlocal_disable
if(allocated(geometry_plastic_nonlocal_IPneighborhood)) & if (allocated(geometry_plastic_nonlocal_IPneighborhood)) &
deallocate(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) deallocate(geometry_plastic_nonlocal_IPvolume0)
if(allocated(geometry_plastic_nonlocal_IParea0)) & if (allocated(geometry_plastic_nonlocal_IParea0)) &
deallocate(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) deallocate(geometry_plastic_nonlocal_IPareaNormal0)
end subroutine geometry_plastic_nonlocal_disable 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_openJobFile(parallel=.false.)
call results_writeDataset_str(fileContent,'setup',fname,'load case definition (grid solver)') call results_writeDataset_str(fileContent,'setup',fname,'load case definition (grid solver)')
call results_closeJobFile call results_closeJobFile
endif end if
call parallelization_bcast_str(fileContent) call parallelization_bcast_str(fileContent)
config_load => YAML_parse_str_asDict(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 thermalActive: if (solver%get_asString('thermal',defaultVal = 'n/a') == 'spectral') then
field = field + 1 field = field + 1
ID(field) = FIELD_THERMAL_ID ID(field) = FIELD_THERMAL_ID
endif thermalActive end if thermalActive
damageActive: if (solver%get_asString('damage',defaultVal = 'n/a') == 'spectral') then damageActive: if (solver%get_asString('damage',defaultVal = 'n/a') == 'spectral') then
field = field + 1 field = field + 1
ID(field) = FIELD_DAMAGE_ID ID(field) = FIELD_DAMAGE_ID
endif damageActive end if damageActive
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -235,7 +235,7 @@ program DAMASK_grid
#endif #endif
end select 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.) 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') 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') step_discretization => load_step%get_dict('discretization')
@ -264,9 +264,9 @@ program DAMASK_grid
write(IO_STDOUT,'(2x,12a)',advance='no') ' x ' write(IO_STDOUT,'(2x,12a)',advance='no') ' x '
else else
write(IO_STDOUT,'(2x,f12.7)',advance='no') loadCases(l)%deformation%values(i,j) write(IO_STDOUT,'(2x,f12.7)',advance='no') loadCases(l)%deformation%values(i,j)
endif end if
enddo; write(IO_STDOUT,'(/)',advance='no') end do; write(IO_STDOUT,'(/)',advance='no')
enddo end do
if (any(loadCases(l)%stress%mask .eqv. loadCases(l)%deformation%mask)) errorID = 831 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))) & 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 errorID = 838 ! no rotation is allowed by stress BC
@ -280,10 +280,10 @@ program DAMASK_grid
write(IO_STDOUT,'(2x,12a)',advance='no') ' x ' write(IO_STDOUT,'(2x,12a)',advance='no') ' x '
else else
write(IO_STDOUT,'(2x,f12.4)',advance='no') loadCases(l)%stress%values(i,j)*1e-6_pReal write(IO_STDOUT,'(2x,f12.4)',advance='no') loadCases(l)%stress%values(i,j)*1e-6_pReal
endif end if
enddo; write(IO_STDOUT,'(/)',advance='no') end do; write(IO_STDOUT,'(/)',advance='no')
enddo end do
endif end if
if (any(dNeq(loadCases(l)%rot%asMatrix(), math_I3))) & if (any(dNeq(loadCases(l)%rot%asMatrix(), math_I3))) &
write(IO_STDOUT,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'R:',& write(IO_STDOUT,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'R:',&
transpose(loadCases(l)%rot%asMatrix()) transpose(loadCases(l)%rot%asMatrix())
@ -298,7 +298,7 @@ program DAMASK_grid
print'(2x,a)', 'r: 1 (constant step width)' print'(2x,a)', 'r: 1 (constant step width)'
else else
print'(2x,a,1x,f0.3)', 'r:', loadCases(l)%r 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,f0.3)', 't:', loadCases(l)%t
print'(2x,a,1x,i0)', 'N:', loadCases(l)%N print'(2x,a,1x,i0)', 'N:', loadCases(l)%N
if (loadCases(l)%f_out < huge(0)) & 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) if (errorID > 0) call IO_error(errorID,label1='line',ID1=l)
endif reportAndCheck end if reportAndCheck
enddo end do
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! doing initialization depending on active solvers ! doing initialization depending on active solvers
@ -337,14 +337,14 @@ program DAMASK_grid
else writeHeader else writeHeader
open(newunit=statUnit,file=trim(getSolverJobName())//& open(newunit=statUnit,file=trim(getSolverJobName())//&
'.sta',form='FORMATTED', position='APPEND', status='OLD') '.sta',form='FORMATTED', position='APPEND', status='OLD')
endif writeHeader end if writeHeader
endif end if
writeUndeformed: if (CLI_restartInc < 1) then writeUndeformed: if (CLI_restartInc < 1) then
print'(/,1x,a)', '... writing initial configuration to file .................................' print'(/,1x,a)', '... writing initial configuration to file .................................'
flush(IO_STDOUT) flush(IO_STDOUT)
call materialpoint_results(0,0.0_pReal) call materialpoint_results(0,0.0_pReal)
endif writeUndeformed end if writeUndeformed
loadCaseLooping: do l = 1, size(loadCases) loadCaseLooping: do l = 1, size(loadCases)
t_0 = t ! load case start time t_0 = t ! load case start time
@ -361,7 +361,7 @@ program DAMASK_grid
else else
Delta_t = loadCases(l)%t * (loadCases(l)%r**(inc-1)-loadCases(l)%r**inc) & Delta_t = loadCases(l)%t * (loadCases(l)%r**(inc-1)-loadCases(l)%r**inc) &
/ (1.0_pReal-loadCases(l)%r**loadCases(l)%N) / (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 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? 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_THERMAL_ID); call grid_thermal_spectral_forward(cutBack)
case(FIELD_DAMAGE_ID); call grid_damage_spectral_forward(cutBack) case(FIELD_DAMAGE_ID); call grid_damage_spectral_forward(cutBack)
end select end select
enddo end do
if (.not. cutBack) call materialpoint_forward if (.not. cutBack) call materialpoint_forward
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -422,12 +422,12 @@ program DAMASK_grid
if (.not. solres(field)%converged) exit ! no solution found if (.not. solres(field)%converged) exit ! no solution found
enddo end do
stagIter = stagIter + 1 stagIter = stagIter + 1
stagIterate = stagIter < stagItMax & stagIterate = stagIter < stagItMax &
.and. all(solres(:)%converged) & .and. all(solres(:)%converged) &
.and. .not. all(solres(:)%stagConverged) ! stationary with respect to staggered iteration .and. .not. all(solres(:)%stagConverged) ! stationary with respect to staggered iteration
enddo end do
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! check solution for either advance or retry ! check solution for either advance or retry
@ -442,7 +442,7 @@ program DAMASK_grid
write(statUnit,*) totalIncsCounter, t, cutBackLevel, & write(statUnit,*) totalIncsCounter, t, cutBackLevel, &
solres(1)%converged, solres(1)%iterationsNeeded solres(1)%converged, solres(1)%iterationsNeeded
flush(statUnit) flush(statUnit)
endif end if
elseif (cutBackLevel < maxCutBack) then ! further cutbacking tolerated? elseif (cutBackLevel < maxCutBack) then ! further cutbacking tolerated?
cutBack = .true. cutBack = .true.
stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator
@ -453,9 +453,9 @@ program DAMASK_grid
else ! no more options to continue else ! no more options to continue
if (worldrank == 0) close(statUnit) if (worldrank == 0) close(statUnit)
call IO_error(950) call IO_error(950)
endif end if
enddo subStepLooping end do subStepLooping
cutBackLevel = max(0, cutBackLevel - 1) ! try half number of subincs next inc 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' print'(/,1x,a,i0,a)', 'increment ', totalIncsCounter, ' converged'
else else
print'(/,1x,a,i0,a)', 'increment ', totalIncsCounter, ' NOT converged' 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) 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' 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 ...............................................' print'(/,1x,a)', '... writing results to file ...............................................'
flush(IO_STDOUT) flush(IO_STDOUT)
call materialpoint_results(totalIncsCounter,t) call materialpoint_results(totalIncsCounter,t)
endif end if
if (signal) call signals_setSIGUSR1(.false.) 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) 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' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
@ -482,19 +482,21 @@ program DAMASK_grid
call mechanical_restartWrite call mechanical_restartWrite
case(FIELD_THERMAL_ID) case(FIELD_THERMAL_ID)
call grid_thermal_spectral_restartWrite call grid_thermal_spectral_restartWrite
case(FIELD_DAMAGE_ID)
call grid_damage_spectral_restartWrite
end select end select
end do end do
call materialpoint_restartWrite call materialpoint_restartWrite
endif end if
if (signal) call signals_setSIGUSR2(.false.) 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) 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 (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
if (signal) exit loadCaseLooping 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 do j = 1,3
mask(i,j) = row%get_asString(j) == 'x' mask(i,j) = row%get_asString(j) == 'x'
if (.not. mask(i,j)) values(i,j) = row%get_asFloat(j) if (.not. mask(i,j)) values(i,j) = row%get_asFloat(j)
enddo end do
enddo end do
end subroutine end subroutine getMaskedTensor
end program DAMASK_grid 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') temp = getXMLValue(header,'Origin')
o = [(IO_floatValue(temp,IO_stringPos(temp),i),i=1,3)] 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 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(pI64) :: s_bytes, e_bytes, s_str, e_str
integer(C_SIGNED_CHAR), dimension(:), allocatable :: bytes 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 (present(s)) then
if(s<1_pI64) call IO_error(114, ext_msg='s out of range') 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_str = ((s-1_pI64)/3_pI64)*4_pI64 + 1_pI64
s_bytes = mod(s-1_pI64,3_pI64) + 1_pI64 s_bytes = mod(s-1_pI64,3_pI64) + 1_pI64
else else
s_str = 1_pI64 s_str = 1_pI64
s_bytes = 1_pI64 s_bytes = 1_pI64
endif end if
if(present(e)) then if (present(e)) then
if(e>base64_nByte(len(base64_str,kind=pI64))) call IO_error(114, ext_msg='e out of range') 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_str = ((e-1_pI64)/3_pI64)*4_pI64 + 4_pI64
e_bytes = e - base64_nByte(s_str) e_bytes = e - base64_nByte(s_str)
else else
e_str = len(base64_str,kind=pI64) e_str = len(base64_str,kind=pI64)
e_bytes = base64_nByte(len(base64_str,kind=pI64)) - base64_nByte(s_str) 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-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 if (base64_str(e_str-1_pI64:e_str-1_pI64) == '=') e_bytes = e_bytes - 1_pI64
endif end if
bytes = decodeBase64(base64_str(s_str:e_str)) bytes = decodeBase64(base64_str(s_str:e_str))
bytes = bytes(s_bytes:e_bytes) 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 while(c < len(base64_str,kind=pI64))
do p=0_pI64,3_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) charPos(p) = int(index(base64_encoding,base64_str(c+p:c+p))-1,C_SIGNED_CHAR)
else else
charPos(p) = 0_C_SIGNED_CHAR charPos(p) = 0_C_SIGNED_CHAR
endif end if
enddo end do
call mvbits(charPos(0),0,6,bytes(b+0),2) call mvbits(charPos(0),0,6,bytes(b+0),2)
call mvbits(charPos(1),4,2,bytes(b+0),0) 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) call mvbits(charPos(3),0,6,bytes(b+2),0)
b = b+3_pI64 b = b+3_pI64
c = c+4_pI64 c = c+4_pI64
enddo end do
end function decodeBase64 end function decodeBase64
@ -151,9 +151,9 @@ pure logical function validBase64(base64_str)
l = len(base64_str,pI64) l = len(base64_str,pI64)
validBase64 = .true. validBase64 = .true.
if(mod(l,4_pI64)/=0_pI64 .or. l < 4_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-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 (verify(base64_str(l-1_pI64:),base64_encoding//'=',kind=pI64) /= 0_pI64) validBase64 = .false.
end function validBase64 end function validBase64
@ -167,59 +167,59 @@ subroutine selfTest
character(len=*), parameter :: zero_to_three = 'AAECAw==' character(len=*), parameter :: zero_to_three = 'AAECAw=='
! https://en.wikipedia.org/wiki/Base64#Output_padding ! https://en.wikipedia.org/wiki/Base64#Output_padding
if(base64_nChar(20_pI64) /= 28_pI64) error stop 'base64_nChar/20/28' 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(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(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(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(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(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(8_pI64) /= 6_pI64) error stop 'base64_nByte/8/6'
bytes = base64_to_bytes(zero_to_three) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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 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) ic_global = VTI_readDataset_real(IO_read(CLI_geomFile),label)
else else
allocate(ic_global(0)) ! needed for IntelMPI 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,& 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) 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 prec
use parallelization use parallelization
use IO use IO
use CLI
use HDF5_utilities
use HDF5
use spectral_utilities use spectral_utilities
use discretization_grid use discretization_grid
use homogenization use homogenization
@ -59,13 +62,13 @@ module grid_damage_spectral
public :: & public :: &
grid_damage_spectral_init, & grid_damage_spectral_init, &
grid_damage_spectral_solution, & grid_damage_spectral_solution, &
grid_damage_spectral_restartWrite, &
grid_damage_spectral_forward grid_damage_spectral_forward
contains contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief allocates all neccessary fields and fills them with data !> @brief allocates all neccessary fields and fills them with data
! ToDo: Restart not implemented
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine grid_damage_spectral_init() subroutine grid_damage_spectral_init()
@ -76,6 +79,8 @@ subroutine grid_damage_spectral_init()
Vec :: uBound, lBound Vec :: uBound, lBound
integer(MPI_INTEGER_KIND) :: err_MPI integer(MPI_INTEGER_KIND) :: err_MPI
PetscErrorCode :: err_PETSc PetscErrorCode :: err_PETSc
integer(HID_T) :: fileHandle, groupHandle
real(pReal), dimension(1,product(cells(1:2))*cells3) :: tempN
type(tDict), pointer :: & type(tDict), pointer :: &
num_grid, & num_grid, &
num_generic num_generic
@ -167,6 +172,18 @@ subroutine grid_damage_spectral_init()
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
end if 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 ce = 0
do k = 1, cells3; do j = 1, cells(2); do i = 1, cells(1) do k = 1, cells3; do j = 1, cells(2); do i = 1, cells(1)
ce = ce + 1 ce = ce + 1
@ -285,6 +302,36 @@ subroutine grid_damage_spectral_forward(cutBack)
end subroutine grid_damage_spectral_forward 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. !> @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() subroutine updateReference()

48
src/grid/grid_mech_FEM.f90
View File

@ -179,7 +179,7 @@ subroutine grid_mechanical_FEM_init
localK = 0_pPetscInt localK = 0_pPetscInt
localK(worldrank) = int(cells3,pPetscInt) localK(worldrank) = int(cells3,pPetscInt)
call MPI_Allreduce(MPI_IN_PLACE,localK,worldsize,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,err_MPI) 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, & call DMDACreate3d(PETSC_COMM_WORLD, &
DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, & DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, &
DMDA_STENCIL_BOX, & DMDA_STENCIL_BOX, &
@ -252,16 +252,16 @@ subroutine grid_mechanical_FEM_init
call HDF5_read(P_aim,groupHandle,'P_aim',.false.) 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) 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 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) 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 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) 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 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) 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') call HDF5_read(temp33n,groupHandle,'F')
F = reshape(temp33n,[3,3,cells(1),cells(2),cells3]) F = reshape(temp33n,[3,3,cells(1),cells(2),cells3])
call HDF5_read(temp33n,groupHandle,'F_lastInc') call HDF5_read(temp33n,groupHandle,'F_lastInc')
@ -274,7 +274,7 @@ subroutine grid_mechanical_FEM_init
elseif (CLI_restartInc == 0) then restartRead 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_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) 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 homogenization_F0 = reshape(F_lastInc, [3,3,product(cells(1:2))*cells3]) ! set starting condition for homogenization_mechanical_response
call utilities_updateCoords(F) 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' 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 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) 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 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) 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_closeGroup(groupHandle)
call HDF5_closeFile(fileHandle) call HDF5_closeFile(fileHandle)
endif restartRead2 end if restartRead2
end subroutine grid_mechanical_FEM_init 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 elseif (deformation_BC%myType=='F') then ! aim at end of load case is prescribed
F_aimDot = F_aimDot & F_aimDot = F_aimDot &
+ merge(.0_pReal,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask) + merge(.0_pReal,(deformation_BC%values - F_aim_lastInc)/t_remaining,deformation_BC%mask)
endif end if
if (guess) then if (guess) then
call VecWAXPY(solution_rate,-1.0_pReal,solution_lastInc,solution_current,err_PETSc) 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 else
call VecSet(solution_rate,0.0_pReal,err_PETSc) call VecSet(solution_rate,0.0_pReal,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
endif end if
call VecCopy(solution_current,solution_lastInc,err_PETSc) call VecCopy(solution_current,solution_lastInc,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
F_lastInc = F F_lastInc = F
homogenization_F0 = reshape(F, [3,3,product(cells(1:2))*cells3]) homogenization_F0 = reshape(F, [3,3,product(cells(1:2))*cells3])
endif end if
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! update average and local deformation gradients ! 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_write(C_volAvgLastInc,groupHandle,'C_volAvgLastInc',.false.)
call HDF5_closeGroup(groupHandle) call HDF5_closeGroup(groupHandle)
call HDF5_closeFile(fileHandle) call HDF5_closeFile(fileHandle)
endif end if
call DMDAVecRestoreArrayF90(mechanical_grid,solution_current,u,err_PETSc) call DMDAVecRestoreArrayF90(mechanical_grid,solution_current,u,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -517,7 +517,7 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,e
reason = -1 reason = -1
else else
reason = 0 reason = 0
endif end if
print'(/,1x,a)', '... reporting .............................................................' print'(/,1x,a)', '... reporting .............................................................'
print'(/,1x,a,f12.2,a,es8.2,a,es9.2,a)', 'error divergence = ', & 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))', & print'(/,1x,a,/,2(3(f12.7,1x)/),3(f12.7,1x))', &
'deformation gradient aim =', transpose(F_aim) 'deformation gradient aim =', transpose(F_aim)
flush(IO_STDOUT) flush(IO_STDOUT)
endif newIteration end if newIteration
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! get deformation gradient ! 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 do kk = -1, 0; do jj = -1, 0; do ii = -1, 0
ctr = ctr + 1 ctr = ctr + 1
x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) 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)) 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) call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -590,7 +590,7 @@ subroutine formResidual(da_local,x_local, &
P_av,C_volAvg,devNull, & P_av,C_volAvg,devNull, &
F,params%Delta_t,params%rotation_BC) 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) 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 ! 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 do kk = -1, 0; do jj = -1, 0; do ii = -1, 0
ctr = ctr + 1 ctr = ctr + 1
x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) 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 ele = ele + 1
f_elem = matmul(transpose(BMat),transpose(P_current(1:3,1:3,i,j,k-cells3Offset)))*detJ + & 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) + & 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 do kk = -1, 0; do jj = -1, 0; do ii = -1, 0
ctr = ctr + 1 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) 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 end do; end do; end do
enddo; enddo; enddo end do; end do; end do
call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,err_PETSc) call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMDAVecRestoreArrayF90(da_local,f_local,r,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_j,ctr+16) = j+jj
col(MatStencil_k,ctr+16) = k+kk col(MatStencil_k,ctr+16) = k+kk
col(MatStencil_c,ctr+16) = 2 col(MatStencil_c,ctr+16) = 2
enddo; enddo; enddo end do; end do; end do
row = col row = col
ce = ce + 1 ce = ce + 1
K_ele = 0.0_pReal 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 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) call MatSetValuesStencil(Jac,24_pPETScInt,row,24_pPetscInt,col,K_ele,ADD_VALUES,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
enddo; enddo; enddo end do; end do; end do
call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,err_PETSc) call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,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) do k = cells3Offset+1, cells3Offset+cells3; do j = 1, cells(2); do i = 1, cells(1)
ce = ce + 1 ce = ce + 1
x_scal(0:2,i-1,j-1,k-1) = discretization_IPcoords(1:3,ce) 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) call DMDAVecRestoreArrayF90(da_local,coordinates,x_scal,err_PETSc)
CHKERRQ(err_PETSc) ! initialize to undeformed coordinates (ToDo: use ip coordinates) CHKERRQ(err_PETSc) ! initialize to undeformed coordinates (ToDo: use ip coordinates)
call MatNullSpaceCreateRigidBody(coordinates,matnull,err_PETSc) 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 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) 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() subroutine updateReference()

127
src/grid/spectral_utilities.f90
View File

@ -120,8 +120,8 @@ module spectral_utilities
utilities_GreenConvolution, & utilities_GreenConvolution, &
utilities_divergenceRMS, & utilities_divergenceRMS, &
utilities_curlRMS, & utilities_curlRMS, &
utilities_ScalarGradient, & utilities_scalarGradient, &
utilities_VectorDivergence, & utilities_vectorDivergence, &
utilities_maskedCompliance, & utilities_maskedCompliance, &
utilities_constitutiveResponse, & utilities_constitutiveResponse, &
utilities_calculateRate, & utilities_calculateRate, &
@ -577,9 +577,6 @@ real(pReal) function utilities_divergenceRMS(tensorField)
complex(pReal), dimension(3) :: rescaledGeom 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,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 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) 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 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,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 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) 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. !> @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), intent(in), dimension( cells(1),cells(2),cells3) :: field
real(pReal), dimension(3,cells(1),cells(2),cells3) :: grad 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 scalarField_real(1:cells(1), 1:cells(2),1:cells3) = field
call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier)
do j = 1, cells2; do k = 1, cells(3); do i = 1,cells1Red 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 end do; end do; end do
call fftw_mpi_execute_dft_c2r(planVectorBack,vectorField_fourier,vectorField_real) 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 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. !> @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), intent(in), dimension(3,cells(1),cells(2),cells3) :: field
real(pReal), dimension( cells(1),cells(2),cells3) :: div 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 vectorField_real(1:3,1:cells(1), 1:cells(2),1:cells3) = field
call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier) 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) & 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) call fftw_mpi_execute_dft_c2r(planScalarBack,scalarField_fourier,scalarField_real)
div = scalarField_real(1:cells(1),1:cells(2),1:cells3)*wgt 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 !> @details this is the full operator to calculate derivatives, i.e. 2 \pi i k for the
! standard approach ! standard approach
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
@ -1133,43 +1127,116 @@ subroutine selfTest()
real(pReal), allocatable, dimension(:,:,:,:,:) :: tensorField_real_ real(pReal), allocatable, dimension(:,:,:,:,:) :: tensorField_real_
real(pReal), allocatable, dimension(:,:,:,:) :: vectorField_real_ real(pReal), allocatable, dimension(:,:,:,:) :: vectorField_real_
real(pReal), allocatable, dimension(:,:,:) :: scalarField_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) call random_number(tensorField_real)
tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal tensorField_real(1:3,1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
tensorField_real_ = tensorField_real tensorField_real_ = tensorField_real
call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier)
if (worldsize==1) then call MPI_Allreduce(sum(sum(sum(tensorField_real_,dim=5),dim=4),dim=3),tensorSum,9_MPI_INTEGER_KIND, &
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))) & MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
error stop 'tensorField avg' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
endif 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) 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 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) call random_number(vectorField_real)
vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
vectorField_real_ = vectorField_real vectorField_real_ = vectorField_real
call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier) call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier)
if (worldsize==1) then call MPI_Allreduce(sum(sum(sum(vectorField_real_,dim=4),dim=3),dim=2),vectorSum,3_MPI_INTEGER_KIND, &
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))) & MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
error stop 'vector avg' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
endif 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) call fftw_mpi_execute_dft_c2r(planVectorBack,vectorField_fourier,vectorField_real)
vectorField_real(1:3,cells(1)+1:cells1Red*2,:,:) = 0.0_pReal 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) call random_number(scalarField_real)
scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal
scalarField_real_ = scalarField_real scalarField_real_ = scalarField_real
call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier)
if (worldsize==1) then call MPI_Allreduce(sum(sum(sum(scalarField_real_,dim=3),dim=2),dim=1),scalarSum,1_MPI_INTEGER_KIND, &
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)) & MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,err_MPI)
error stop 'scalar avg' if (err_MPI /= 0_MPI_INTEGER_KIND) error stop 'MPI error'
endif 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) call fftw_mpi_execute_dft_c2r(planScalarBack,scalarField_fourier,scalarField_real)
scalarField_real(cells(1)+1:cells1Red*2,:,:) = 0.0_pReal 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 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) 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 (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 (damageState_h(ho)%sizeState > 0) damageState_h(ho)%state(:,en) = damageState_h(ho)%state0(:,en)
call damage_partition(ce) call damage_partition(ce)
doneAndHappy = [.false.,.true.] doneAndHappy = [.false.,.true.]
@ -381,7 +381,7 @@ subroutine homogenization_forward
do ho = 1, size(material_name_homogenization) do ho = 1, size(material_name_homogenization)
homogState (ho)%state0 = homogState (ho)%state 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 damageState_h(ho)%state0 = damageState_h(ho)%state
end do 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 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)) call HDF5_closeGroup(groupHandle(2))
end do 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 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)) call HDF5_closeGroup(groupHandle(2))
end do end do

8
src/homogenization_damage.f90
View File

@ -80,11 +80,15 @@ module subroutine damage_partition(ce)
integer, intent(in) :: ce integer, intent(in) :: ce
real(pReal) :: phi 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)) 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 end subroutine damage_partition

66
src/materialpoint.f90
View File

@ -18,6 +18,7 @@ module materialpoint
use math use math
use rotations use rotations
use polynomials use polynomials
use tables
use lattice use lattice
use material use material
use phase use phase
@ -40,37 +41,38 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Initialize all modules. !> @brief Initialize all modules.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_initAll subroutine materialpoint_initAll()
call parallelization_init call parallelization_init()
call CLI_init ! Spectral and FEM interface to commandline call CLI_init() ! grid and mesh commandline interface
call signals_init call signals_init()
call prec_init call prec_init()
call IO_init call IO_init()
#if defined(MESH) #if defined(MESH)
call FEM_quadrature_init call FEM_quadrature_init()
#elif defined(GRID) #elif defined(GRID)
call base64_init call base64_init()
#endif #endif
call YAML_types_init call YAML_types_init()
call YAML_parse_init call YAML_parse_init()
call HDF5_utilities_init call HDF5_utilities_init()
call results_init(restart=CLI_restartInc>0) call results_init(restart=CLI_restartInc>0)
call config_init call config_init()
call math_init call math_init()
call rotations_init call rotations_init()
call polynomials_init call polynomials_init()
call lattice_init call tables_init()
call lattice_init()
#if defined(MESH) #if defined(MESH)
call discretization_mesh_init(restart=CLI_restartInc>0) call discretization_mesh_init(restart=CLI_restartInc>0)
#elif defined(GRID) #elif defined(GRID)
call discretization_grid_init(restart=CLI_restartInc>0) call discretization_grid_init(restart=CLI_restartInc>0)
#endif #endif
call material_init(restart=CLI_restartInc>0) call material_init(restart=CLI_restartInc>0)
call phase_init call phase_init()
call homogenization_init call homogenization_init()
call materialpoint_init call materialpoint_init()
call config_deallocate call config_deallocate()
end subroutine materialpoint_initAll end subroutine materialpoint_initAll
@ -78,7 +80,7 @@ end subroutine materialpoint_initAll
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Read restart information if needed. !> @brief Read restart information if needed.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_init subroutine materialpoint_init()
integer(HID_T) :: fileHandle integer(HID_T) :: fileHandle
@ -95,7 +97,7 @@ subroutine materialpoint_init
call phase_restartRead(fileHandle) call phase_restartRead(fileHandle)
call HDF5_closeFile(fileHandle) call HDF5_closeFile(fileHandle)
endif end if
end subroutine materialpoint_init end subroutine materialpoint_init
@ -103,7 +105,7 @@ end subroutine materialpoint_init
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Write restart information. !> @brief Write restart information.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_restartWrite subroutine materialpoint_restartWrite()
integer(HID_T) :: fileHandle integer(HID_T) :: fileHandle
@ -123,10 +125,10 @@ end subroutine materialpoint_restartWrite
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Forward data for new time increment. !> @brief Forward data for new time increment.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
subroutine materialpoint_forward subroutine materialpoint_forward()
call homogenization_forward call homogenization_forward()
call phase_forward call phase_forward()
end subroutine materialpoint_forward end subroutine materialpoint_forward
@ -139,13 +141,13 @@ subroutine materialpoint_results(inc,time)
integer, intent(in) :: inc integer, intent(in) :: inc
real(pReal), intent(in) :: time real(pReal), intent(in) :: time
call results_openJobFile call results_openJobFile()
call results_addIncrement(inc,time) call results_addIncrement(inc,time)
call phase_results call phase_results()
call homogenization_results call homogenization_results()
call discretization_results call discretization_results()
call results_finalizeIncrement call results_finalizeIncrement()
call results_closeJobFile call results_closeJobFile()
end subroutine materialpoint_results end subroutine materialpoint_results

2
src/mesh/DAMASK_mesh.f90
View File

@ -311,7 +311,7 @@ program DAMASK_mesh
write(statUnit,*) totalIncsCounter, time, cutBackLevel, & write(statUnit,*) totalIncsCounter, time, cutBackLevel, &
solres%converged, solres%iterationsNeeded ! write statistics about accepted solution solres%converged, solres%iterationsNeeded ! write statistics about accepted solution
flush(statUnit) flush(statUnit)
endif end if
end do subStepLooping end do subStepLooping
cutBackLevel = max(0, cutBackLevel - 1) ! try half number of subincs next inc 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) 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)) & if (dNeq(sum(FEM_quadrature_weights(d,o)%p),1.0_pReal,5e-15_pReal)) &
error stop 'quadrature weights' error stop 'quadrature weights'
enddo end do
enddo end do
do d = lbound(FEM_quadrature_points,1), ubound(FEM_quadrature_points,1) 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) do o = lbound(FEM_quadrature_points(d,:),1), ubound(FEM_quadrature_points(d,:),1)
n = size(FEM_quadrature_points(d,o)%p,1)/d 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))) & 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' error stop 'quadrature points'
enddo end do
enddo end do
end subroutine selfTest 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) debug_mesh => config_debug%get_dict('mesh',defaultVal=emptyDict)
debugPETSc = debug_mesh%contains('PETSc') debugPETSc = debug_mesh%contains('PETSc')
if(debugPETSc) print'(3(/,1x,a),/)', & if (debugPETSc) print'(3(/,1x,a),/)', &
'Initializing PETSc with debug options: ', & 'Initializing PETSc with debug options: ', &
trim(PETScDebug), & trim(PETScDebug), &
'add more using the "PETSc_options" keyword in numerics.yaml' 'add more using the "PETSc_options" keyword in numerics.yaml'
flush(IO_STDOUT) flush(IO_STDOUT)
call PetscOptionsClear(PETSC_NULL_OPTIONS,err_PETSc) call PetscOptionsClear(PETSC_NULL_OPTIONS,err_PETSc)
CHKERRQ(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) CHKERRQ(err_PETSc)
call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-mechanical_snes_type newtonls & call PetscOptionsInsertString(PETSC_NULL_OPTIONS,'-mechanical_snes_type newtonls &
&-mechanical_snes_linesearch_type cp -mechanical_snes_ksp_ew & &-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) call DMClone(globalMesh,geomMesh,err_PETSc)
else else
call DMPlexDistribute(globalMesh,0_pPETSCINT,sf,geomMesh,err_PETSc) call DMPlexDistribute(globalMesh,0_pPETSCINT,sf,geomMesh,err_PETSc)
endif end if
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
allocate(mesh_boundaries(mesh_Nboundaries), source = 0_pPETSCINT) allocate(mesh_boundaries(mesh_Nboundaries), source = 0_pPETSCINT)
@ -154,7 +154,7 @@ subroutine discretization_mesh_init(restart)
mesh_boundaries(1:nFaceSets) = pFaceSets mesh_boundaries(1:nFaceSets) = pFaceSets
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call ISRestoreIndicesF90(faceSetIS,pFaceSets,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) 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' 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 do j = 1, mesh_NcpElems
call DMGetLabelValue(geomMesh,'Cell Sets',j-1,materialAt(j),err_PETSc) call DMGetLabelValue(geomMesh,'Cell Sets',j-1,materialAt(j),err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
enddo end do
materialAt = materialAt + 1_pPETSCINT materialAt = materialAt + 1_pPETSCINT
if (debug_element < 1 .or. debug_element > mesh_NcpElems) call IO_error(602,ext_msg='element') 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) call DMPlexComputeCellGeometryFVM(geomMesh,cell,vol,pCent,pNorm,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
mesh_ipVolume(:,cell+1) = vol/real(mesh_maxNips,pReal) mesh_ipVolume(:,cell+1) = vol/real(mesh_maxNips,pReal)
enddo end do
end subroutine mesh_FEM_build_ipVolumes end subroutine mesh_FEM_build_ipVolumes
@ -258,11 +258,11 @@ subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints)
do dirJ = 1_pPETSCINT, dimPlex do dirJ = 1_pPETSCINT, dimPlex
mesh_ipCoordinates(dirI,qPt,cell+1) = mesh_ipCoordinates(dirI,qPt,cell+1) + & mesh_ipCoordinates(dirI,qPt,cell+1) = mesh_ipCoordinates(dirI,qPt,cell+1) + &
pCellJ((dirI-1)*dimPlex+dirJ)*(qPoints(qOffset+dirJ) + 1.0_pReal) pCellJ((dirI-1)*dimPlex+dirJ)*(qPoints(qOffset+dirJ) + 1.0_pReal)
enddo end do
enddo end do
qOffset = qOffset + dimPlex qOffset = qOffset + dimPlex
enddo end do
enddo end do
end subroutine mesh_FEM_build_ipCoordinates 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) CHKERRQ(err_PETSc)
call PetscSectionGetDof(section,cellStart,pnumDof(topologDim),err_PETSc) call PetscSectionGetDof(section,cellStart,pnumDof(topologDim),err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
enddo end do
numBC = 0 numBC = 0
do field = 1, dimPlex; do faceSet = 1, mesh_Nboundaries do field = 1, dimPlex; do faceSet = 1, mesh_Nboundaries
if (fieldBC%componentBC(field)%Mask(faceSet)) numBC = numBC + 1 if (fieldBC%componentBC(field)%Mask(faceSet)) numBC = numBC + 1
enddo; enddo end do; end do
allocate(pbcField(numBC), source=0_pPETSCINT) allocate(pbcField(numBC), source=0_pPETSCINT)
allocate(pbcComps(numBC)) allocate(pbcComps(numBC))
allocate(pbcPoints(numBC)) allocate(pbcPoints(numBC))
@ -229,9 +229,9 @@ subroutine FEM_mechanical_init(fieldBC)
else else
call ISCreateGeneral(PETSC_COMM_WORLD,0_pPETSCINT,[0_pPETSCINT],PETSC_COPY_VALUES,pbcPoints(numBC),err_PETSc) call ISCreateGeneral(PETSC_COMM_WORLD,0_pPETSCINT,[0_pPETSCINT],PETSC_COPY_VALUES,pbcPoints(numBC),err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
endif end if
endif end if
enddo; enddo end do; end do
call DMPlexCreateSection(mechanical_mesh,nolabel,pNumComp,pNumDof, & call DMPlexCreateSection(mechanical_mesh,nolabel,pNumComp,pNumDof, &
numBC,pBcField,pBcComps,pBcPoints,PETSC_NULL_IS,section,err_PETSc) numBC,pBcField,pBcComps,pBcPoints,PETSC_NULL_IS,section,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -240,7 +240,7 @@ subroutine FEM_mechanical_init(fieldBC)
do faceSet = 1, numBC do faceSet = 1, numBC
call ISDestroy(pbcPoints(faceSet),err_PETSc) call ISDestroy(pbcPoints(faceSet),err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
enddo end do
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! initialize solver specific parts of PETSc ! 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) call PetscQuadratureGetData(functional,dimPlex,nc,nNodalPoints,nodalPointsP,nodalWeightsP,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
x_scal(basis+1:basis+dimPlex) = pV0 + matmul(transpose(cellJMat),nodalPointsP + 1.0_pReal) x_scal(basis+1:basis+dimPlex) = pV0 + matmul(transpose(cellJMat),nodalPointsP + 1.0_pReal)
enddo end do
px_scal => x_scal px_scal => x_scal
call DMPlexVecSetClosure(mechanical_mesh,section,solution_local,cell,px_scal,5,err_PETSc) call DMPlexVecSetClosure(mechanical_mesh,section,solution_local,cell,px_scal,5,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
enddo end do
call utilities_constitutiveResponse(0.0_pReal,devNull,.true.) call utilities_constitutiveResponse(0.0_pReal,devNull,.true.)
end subroutine FEM_mechanical_init end subroutine FEM_mechanical_init
@ -348,7 +348,7 @@ type(tSolutionState) function FEM_mechanical_solution( &
FEM_mechanical_solution%converged = .true. FEM_mechanical_solution%converged = .true.
call SNESGetIterationNumber(mechanical_snes,FEM_mechanical_solution%iterationsNeeded,err_PETSc) call SNESGetIterationNumber(mechanical_snes,FEM_mechanical_solution%iterationsNeeded,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
endif end if
print'(/,1x,a)', '===========================================================================' print'(/,1x,a)', '==========================================================================='
flush(IO_STDOUT) 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) 0.0_pReal,params%fieldBC%componentBC(field)%Value(face),params%timeinc)
call ISDestroy(bcPoints,err_PETSc) call ISDestroy(bcPoints,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
endif end if
endif end if
enddo; enddo end do; end do
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! evaluate field derivatives ! 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 i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = & 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)) matmul(IcellJMat,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
enddo end do
enddo end do
homogenization_F(1:dimPlex,1:dimPlex,m) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1]) 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 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)) 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 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) & 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)) * (detFAvg/math_det33(homogenization_F(1:3,1:3,m)))**(1.0_pReal/real(dimPlex,pReal))
enddo end do
endif end if
call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc) call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
enddo end do
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! evaluate constitutive response ! 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 i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = & 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)) matmul(IcellJMat,basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
enddo end do
enddo end do
f_scal = f_scal & f_scal = f_scal &
+ matmul(transpose(BMat), & + matmul(transpose(BMat), &
reshape(transpose(homogenization_P(1:dimPlex,1:dimPlex,m)), & reshape(transpose(homogenization_P(1:dimPlex,1:dimPlex,m)), &
shape=[dimPlex*dimPlex]))*qWeights(qPt+1_pPETSCINT) shape=[dimPlex*dimPlex]))*qWeights(qPt+1_pPETSCINT)
enddo end do
f_scal = f_scal*abs(detJ) f_scal = f_scal*abs(detJ)
pf_scal => f_scal pf_scal => f_scal
call DMPlexVecSetClosure(dm_local,section,f_local,cell,pf_scal,ADD_VALUES,err_PETSc) call DMPlexVecSetClosure(dm_local,section,f_local,cell,pf_scal,ADD_VALUES,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc) call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
enddo end do
call DMRestoreLocalVector(dm_local,x_local,err_PETSc) call DMRestoreLocalVector(dm_local,x_local,err_PETSc)
CHKERRQ(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) 0.0_pReal,params%fieldBC%componentBC(field)%Value(face),params%timeinc)
call ISDestroy(bcPoints,err_PETSc) call ISDestroy(bcPoints,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
endif end if
endif end if
enddo; enddo end do; end do
call DMPlexGetHeightStratum(dm_local,0_pPETSCINT,cellStart,cellEnd,err_PETSc) call DMPlexGetHeightStratum(dm_local,0_pPETSCINT,cellStart,cellEnd,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
do cell = cellStart, cellEnd-1 !< loop over all elements 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 i = ((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp
BMat(comp*dimPlex+1_pPETSCINT:(comp+1_pPETSCINT)*dimPlex,basis*dimPlex+comp+1_pPETSCINT) = & 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)) matmul(reshape(pInvcellJ,[dimPlex,dimPlex]),basisFieldDer(i*dimPlex+1_pPETSCINT:(i+1_pPETSCINT)*dimPlex))
enddo end do
enddo end do
MatA = matmul(reshape(reshape(homogenization_dPdF(1:dimPlex,1:dimPlex,1:dimPlex,1:dimPlex,m), & 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], order=[2,1,4,3]), &
shape=[dimPlex*dimPlex,dimPlex*dimPlex]),BMat)*qWeights(qPt+1_pPETSCINT) 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 BMatAvg = BMatAvg + BMat
else else
K_eA = K_eA + matmul(transpose(BMat),MatA) K_eA = K_eA + matmul(transpose(BMat),MatA)
endif end if
enddo end do
if (num%BBarStabilisation) then if (num%BBarStabilisation) then
FInv = math_inv33(FAvg) FInv = math_inv33(FAvg)
K_e = K_eA*math_det33(FAvg/real(nQuadrature,pReal))**(1.0_pReal/real(dimPlex,pReal)) + & 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) K_eB)/real(dimPlex,pReal)
else else
K_e = K_eA K_e = K_eA
endif end if
K_e = (K_e + eps*math_eye(int(cellDof))) * abs(detJ) K_e = (K_e + eps*math_eye(int(cellDof))) * abs(detJ)
#ifndef __INTEL_COMPILER #ifndef __INTEL_COMPILER
pK_e(1:cellDOF**2) => K_e 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) CHKERRQ(err_PETSc)
call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc) call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
enddo end do
call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,err_PETSc) call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,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) 0.0_pReal,fieldBC%componentBC(field)%Value(face),timeinc_old)
call ISDestroy(bcPoints,err_PETSc) call ISDestroy(bcPoints,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
endif end if
endif end if
enddo; enddo end do; end do
call DMRestoreLocalVector(dm_local,x_local,err_PETSc) call DMRestoreLocalVector(dm_local,x_local,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
@ -716,7 +716,7 @@ subroutine FEM_mechanical_forward(guess,timeinc,timeinc_old,fieldBC)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecScale(solution_rate,timeinc_old**(-1),err_PETSc) call VecScale(solution_rate,timeinc_old**(-1),err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
endif end if
call VecCopy(solution_rate,solution,err_PETSc) call VecCopy(solution_rate,solution,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
call VecScale(solution,timeinc,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) call DMPlexGetPointLocal(dm_local, p, s, e, err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
nodeCoords(1:dimPlex,p)=nodeCoords_linear(s+1:e) nodeCoords(1:dimPlex,p)=nodeCoords_linear(s+1:e)
enddo end do
call discretization_setNodeCoords(nodeCoords) call discretization_setNodeCoords(nodeCoords)
call VecRestoreArrayF90(x_local,nodeCoords_linear,err_PETSc) call VecRestoreArrayF90(x_local,nodeCoords_linear,err_PETSc)
@ -827,9 +827,9 @@ subroutine FEM_mechanical_updateCoords()
x_scal(nOffset+1:nOffset+dimPlex)) x_scal(nOffset+1:nOffset+dimPlex))
q = q+dimPlex q = q+dimPlex
nOffset = nOffset+dimPlex nOffset = nOffset+dimPlex
enddo end do
enddo end do
enddo end do
call DMPlexVecRestoreClosure(dm_local,section,x_local,c,x_scal,err_PETSc) call DMPlexVecRestoreClosure(dm_local,section,x_local,c,x_scal,err_PETSc)
CHKERRQ(err_PETSc) CHKERRQ(err_PETSc)
end do end do

4
src/parallelization.f90
View File

@ -53,7 +53,7 @@ contains
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @brief Initialize shared memory (openMP) and distributed memory (MPI) parallelization. !> @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 integer(MPI_INTEGER_KIND) :: err_MPI, typeSize, version, subversion, devNull
character(len=4) :: rank_str character(len=4) :: rank_str
@ -136,7 +136,7 @@ subroutine parallelization_init
error stop 'Mismatch between MPI_DOUBLE and DAMASK pReal' error stop 'Mismatch between MPI_DOUBLE and DAMASK pReal'
!$ call get_environment_variable(name='OMP_NUM_THREADS',value=NumThreadsString,STATUS=got_env) !$ 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' !$ print'(1x,a)', 'Could not get $OMP_NUM_THREADS, using default'
!$ OMP_NUM_THREADS = 4_pI32 !$ OMP_NUM_THREADS = 4_pI32
!$ else !$ else

13
src/phase.f90
View File

@ -9,6 +9,7 @@ module phase
use math use math
use rotations use rotations
use polynomials use polynomials
use tables
use IO use IO
use config use config
use material use material
@ -160,6 +161,11 @@ module phase
integer, intent(in) :: ph integer, intent(in) :: ph
end subroutine thermal_restartWrite 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) module subroutine mechanical_restartRead(groupHandle,ph)
integer(HID_T), intent(in) :: groupHandle integer(HID_T), intent(in) :: groupHandle
integer, intent(in) :: ph integer, intent(in) :: ph
@ -170,6 +176,11 @@ module phase
integer, intent(in) :: ph integer, intent(in) :: ph
end subroutine thermal_restartRead 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) module function mechanical_S(ph,en) result(S)
integer, intent(in) :: ph,en integer, intent(in) :: ph,en
real(pReal), dimension(3,3) :: S real(pReal), dimension(3,3) :: S
@ -674,6 +685,7 @@ subroutine phase_restartWrite(fileHandle)
call mechanical_restartWrite(groupHandle(2),ph) call mechanical_restartWrite(groupHandle(2),ph)
call thermal_restartWrite(groupHandle(2),ph) call thermal_restartWrite(groupHandle(2),ph)
call damage_restartWrite(groupHandle(2),ph)
call HDF5_closeGroup(groupHandle(2)) call HDF5_closeGroup(groupHandle(2))
@ -703,6 +715,7 @@ subroutine phase_restartRead(fileHandle)
call mechanical_restartRead(groupHandle(2),ph) call mechanical_restartRead(groupHandle(2),ph)
call thermal_restartRead(groupHandle(2),ph) call thermal_restartRead(groupHandle(2),ph)
call damage_restartRead(groupHandle(2),ph)
call HDF5_closeGroup(groupHandle(2)) 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 !> @brief internal microstructure state for all damage sources and kinematics constitutive models
!---------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
submodule(phase) damage submodule(phase) damage
type :: tDamageParameters type :: tDamageParameters
@ -310,6 +310,35 @@ function integrateDamageState(Delta_t,ph,en) result(broken)
end function integrateDamageState 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 !< @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 dotState_last(1:sizeDotState,1) = dotState
broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en)
if(broken) exit iteration if (broken) exit iteration
dotState = plastic_dotState(Delta_t,ph,en) dotState = plastic_dotState(Delta_t,ph,en)
if (any(IEEE_is_NaN(dotState))) exit iteration 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 #endif
broken = plastic_deltaState(ph,en) broken = plastic_deltaState(ph,en)
if(broken) return if (broken) return
broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) 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 #endif
broken = plastic_deltaState(ph,en) broken = plastic_deltaState(ph,en)
if(broken) return if (broken) return
broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en)
if(broken) return if (broken) return
dotState = plastic_dotState(Delta_t,ph,en) dotState = plastic_dotState(Delta_t,ph,en)
if (any(IEEE_is_NaN(dotState))) return 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 #endif
broken = integrateStress(F_0+(F-F_0)*Delta_t*C(stage),subFp0,subFi0,Delta_t*C(stage), ph,en) 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) dotState = plastic_dotState(Delta_t*C(stage), ph,en)
if (any(IEEE_is_NaN(dotState))) exit if (any(IEEE_is_NaN(dotState))) exit
end do end do
if(broken) return if (broken) return
plastic_RKdotState(1:sizeDotState,size(B)) = dotState 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) plasticState(ph)%state(1:sizeDotState,en) = IEEE_FMA(dotState,Delta_t,subState0)
#endif #endif
if(present(DB)) & if (present(DB)) &
broken = .not. converged(matmul(plastic_RKdotState(1:sizeDotState,1:size(DB)),DB) * Delta_t, & broken = .not. converged(matmul(plastic_RKdotState(1:sizeDotState,1:size(DB)),DB) * Delta_t, &
plasticState(ph)%state(1:sizeDotState,en), & plasticState(ph)%state(1:sizeDotState,en), &
plasticState(ph)%atol(1:sizeDotState)) plasticState(ph)%atol(1:sizeDotState))
if(broken) return if (broken) return
broken = plastic_deltaState(ph,en) broken = plastic_deltaState(ph,en)
if(broken) return if (broken) return
broken = integrateStress(F,subFp0,subFi0,Delta_t,ph,en) 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') myKinematics = kinematics_active2('anisobrittle')
if(count(myKinematics) == 0) return if (count(myKinematics) == 0) return
print'(/,1x,a)', '<<<+- phase:mechanical:eigen:cleavageopening init -+>>>' print'(/,1x,a)', '<<<+- phase:mechanical:eigen:cleavageopening init -+>>>'
print'(/,a,i2)', ' # phases: ',count(myKinematics); flush(IO_STDOUT) 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') myPlasticity = plastic_active('isotropic')
if(count(myPlasticity) == 0) return if (count(myPlasticity) == 0) return
print'(/,1x,a)', '<<<+- phase:mechanical:plastic:isotropic init -+>>>' print'(/,1x,a)', '<<<+- phase:mechanical:plastic:isotropic init -+>>>'
print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT) print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT)
@ -77,7 +77,7 @@ module function plastic_isotropic_init() result(myPlasticity)
allocate(state(phases%length)) allocate(state(phases%length))
do ph = 1, phases%length do ph = 1, phases%length
if(.not. myPlasticity(ph)) cycle if (.not. myPlasticity(ph)) cycle
associate(prm => param(ph), stt => state(ph)) 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 pl
myPlasticity = plastic_active('kinehardening') myPlasticity = plastic_active('kinehardening')
if(count(myPlasticity) == 0) return if (count(myPlasticity) == 0) return
print'(/,1x,a)', '<<<+- phase:mechanical:plastic:kinehardening init -+>>>' print'(/,1x,a)', '<<<+- phase:mechanical:plastic:kinehardening init -+>>>'
print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT) 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 if (phase_lattice(ph) == 'cI') then
a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray) 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_pos = lattice_nonSchmidMatrix(N_sl,a,+1)
prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1) prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1)
else else
@ -189,7 +189,7 @@ module function plastic_kinehardening_init() result(myPlasticity)
stt%xi => plasticState(ph)%state(startIndex:endIndex,:) stt%xi => plasticState(ph)%state(startIndex:endIndex,:)
stt%xi = spread(xi_0, 2, Nmembers) stt%xi = spread(xi_0, 2, Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) 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 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_sl endIndex = endIndex + prm%sum_N_sl
@ -202,7 +202,7 @@ module function plastic_kinehardening_init() result(myPlasticity)
idx_dot%gamma = [startIndex,endIndex] idx_dot%gamma = [startIndex,endIndex]
stt%gamma => plasticState(ph)%state(startIndex:endIndex,:) stt%gamma => plasticState(ph)%state(startIndex:endIndex,:)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_gamma',defaultVal=1.0e-6_pReal) 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 o = plasticState(ph)%offsetDeltaState
startIndex = endIndex + 1 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 if (phase_lattice(ph) == 'cI') then
a = pl%get_as1dFloat('a_nonSchmid',defaultVal = emptyRealArray) 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_pos = lattice_nonSchmidMatrix(ini%N_sl,a,+1)
prm%P_nS_neg = lattice_nonSchmidMatrix(ini%N_sl,a,-1) prm%P_nS_neg = lattice_nonSchmidMatrix(ini%N_sl,a,-1)
else else
@ -416,7 +416,7 @@ module function plastic_nonlocal_init() result(myPlasticity)
allocate(geom(ph)%IPcoordinates(3,Nmembers)) allocate(geom(ph)%IPcoordinates(3,Nmembers))
call storeGeometry(ph) 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') 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,:) 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) 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) 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) 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' extmsg = trim(extmsg)//' atol_gamma'
stt%rho_forest => plasticState(ph)%state (11*prm%sum_N_sl + 1:12*prm%sum_N_sl,1:Nmembers) 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 do ph = 1, phases%length
if(.not. myPlasticity(ph)) cycle if (.not. myPlasticity(ph)) cycle
phase => phases%get_dict(ph) phase => phases%get_dict(ph)
Nmembers = count(material_phaseID == ph) Nmembers = count(material_phaseID == ph)
@ -1783,6 +1783,6 @@ subroutine storeGeometry(ph)
end do end do
end do end do
end subroutine end subroutine storeGeometry
end submodule nonlocal 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') myPlasticity = plastic_active('phenopowerlaw')
if(count(myPlasticity) == 0) return if (count(myPlasticity) == 0) return
print'(/,1x,a)', '<<<+- phase:mechanical:plastic:phenopowerlaw init -+>>>' print'(/,1x,a)', '<<<+- phase:mechanical:plastic:phenopowerlaw init -+>>>'
print'(/,a,i0)', ' # phases: ',count(myPlasticity); flush(IO_STDOUT) 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 if (phase_lattice(ph) == 'cI') then
a = pl%get_as1dFloat('a_nonSchmid',defaultVal=emptyRealArray) 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_pos = lattice_nonSchmidMatrix(N_sl,a,+1)
prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1) prm%P_nS_neg = lattice_nonSchmidMatrix(N_sl,a,-1)
else else
@ -243,7 +243,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
stt%xi_sl => plasticState(ph)%state(startIndex:endIndex,:) stt%xi_sl => plasticState(ph)%state(startIndex:endIndex,:)
stt%xi_sl = spread(xi_0_sl, 2, Nmembers) stt%xi_sl = spread(xi_0_sl, 2, Nmembers)
plasticState(ph)%atol(startIndex:endIndex) = pl%get_asFloat('atol_xi',defaultVal=1.0_pReal) 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 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tw endIndex = endIndex + prm%sum_N_tw
@ -257,7 +257,7 @@ module function plastic_phenopowerlaw_init() result(myPlasticity)
idx_dot%gamma_sl = [startIndex,endIndex] idx_dot%gamma_sl = [startIndex,endIndex]
stt%gamma_sl => plasticState(ph)%state(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) 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 startIndex = endIndex + 1
endIndex = endIndex + prm%sum_N_tw 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) mySources = thermal_active('dissipation',source_length)
if(count(mySources) == 0) return if (count(mySources) == 0) return
print'(/,1x,a)', '<<<+- phase:thermal:dissipation init -+>>>' print'(/,1x,a)', '<<<+- phase:thermal:dissipation init -+>>>'
print'(/,a,i2)', ' # phases: ',count(mySources); flush(IO_STDOUT) 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? source_thermal_externalheat_offset !< which source is my current thermal dissipation mechanism?
type :: tParameters !< container type for internal constitutive parameters type :: tParameters !< container type for internal constitutive parameters
real(pReal), dimension(:), allocatable :: & type(tTable) :: f
t_n, &
f_T
integer :: &
nIntervals
end type tParameters end type tParameters
type(tParameters), dimension(:), allocatable :: param !< containers of constitutive parameters (len Ninstances) 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) mySources = thermal_active('externalheat',source_length)
if(count(mySources) == 0) return if (count(mySources) == 0) return
print'(/,1x,a)', '<<<+- phase:thermal:externalheat init -+>>>' print'(/,1x,a)', '<<<+- phase:thermal:externalheat init -+>>>'
print'(/,a,i2)', ' # phases: ',count(mySources); flush(IO_STDOUT) 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)) associate(prm => param(ph))
src => sources%get_dict(so) src => sources%get_dict(so)
prm%t_n = src%get_as1dFloat('t_n') prm%f = table(src,'t','f')
prm%nIntervals = size(prm%t_n) - 1
prm%f_T = src%get_as1dFloat('f_T',requiredSize = size(prm%t_n))
Nmembers = count(material_phaseID == ph) Nmembers = count(material_phaseID == ph)
call phase_allocateState(thermalState(ph)%p(so),Nmembers,1,1,0) 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 f_T
integer :: & integer :: &
so, interval so
real(pReal) :: &
frac_time
so = source_thermal_externalheat_offset(ph) so = source_thermal_externalheat_offset(ph)
associate(prm => param(ph)) associate(prm => param(ph))
do interval = 1, prm%nIntervals ! scan through all rate segments f_T = prm%f%at(thermalState(ph)%p(so)%state(1,en))
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
end associate end associate
end function externalheat_f_T end function externalheat_f_T

10
src/polynomials.f90
View File

@ -1,6 +1,6 @@
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
!> @author Martin Diehl, KU Leuven !> @author Martin Diehl, KU Leuven
!> @brief Polynomial representation for variable data !> @brief Polynomial representation for variable data.
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
module polynomials module polynomials
use prec use prec
@ -19,8 +19,8 @@ module polynomials
end type tPolynomial end type tPolynomial
interface polynomial interface polynomial
module procedure polynomial_from_dict
module procedure polynomial_from_coef module procedure polynomial_from_coef
module procedure polynomial_from_dict
end interface polynomial end interface polynomial
public :: & 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) 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) 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) !> @details https://nvlpubs.nist.gov/nistpubs/jres/71b/jresv71bn1p11_a1b.pdf (eq. 1.2)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
pure function eval(self,x) result(y) pure function eval(self,x) result(y)

5
src/prec.f90
View File

@ -26,7 +26,7 @@ module prec
PetscInt, private :: dummy_int PetscInt, private :: dummy_int
integer, parameter :: pPETSCINT = kind(dummy_int) integer, parameter :: pPETSCINT = kind(dummy_int)
PetscScalar, private :: dummy_scalar PetscScalar, private :: dummy_scalar
real(pReal), parameter :: pPETSCSCALAR = kind(dummy_scalar) real(pReal), parameter, private :: pPETSCSCALAR = kind(dummy_scalar)
#endif #endif
integer, parameter :: pSTRINGLEN = 256 !< default string length integer, parameter :: pSTRINGLEN = 256 !< default string length
integer, parameter :: pPATHLEN = 4096 !< maximum length of a path name on linux integer, parameter :: pPATHLEN = 4096 !< maximum length of a path name on linux
@ -254,8 +254,9 @@ subroutine selfTest()
integer(pI64), dimension(1) :: i integer(pI64), dimension(1) :: i
real(pReal), dimension(2) :: r real(pReal), dimension(2) :: r
#ifdef PETSC #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 #endif
realloc_lhs_test = [1,2] realloc_lhs_test = [1,2]
if (any(realloc_lhs_test/=[1,2])) error stop 'LHS allocation' 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 real(pReal), dimension(:,:,:), allocatable :: dataset_transposed
if(present(transposed)) then if (present(transposed)) then
transposed_ = transposed transposed_ = transposed
else else
transposed_ = .true. transposed_ = .true.
end if end if
groupHandle = results_openGroup(group) groupHandle = results_openGroup(group)
if(transposed_) then if (transposed_) then
if(size(dataset,1) /= size(dataset,2)) error stop 'transpose non-symmetric tensor' if (size(dataset,1) /= size(dataset,2)) error stop 'transpose non-symmetric tensor'
allocate(dataset_transposed,mold=dataset) allocate(dataset_transposed,mold=dataset)
do i=1,size(dataset_transposed,3) do i=1,size(dataset_transposed,3)
dataset_transposed(:,:,i) = transpose(dataset(:,:,i)) 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 writeSize(worldrank) = size(entry(1,:)) ! total number of entries of this process
call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) 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 #ifndef PETSC
entryGlobal = int(entry -1,pI64) ! 0-based entryGlobal = int(entry -1,pI64) ! 0-based
@ -535,10 +535,10 @@ subroutine results_mapping_phase(ID,entry,label)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! MPI settings and communication ! MPI settings and communication
call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) 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 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 entryOffset = 0_pI64
do co = 1, size(ID,1) do co = 1, size(ID,1)
@ -547,7 +547,7 @@ subroutine results_mapping_phase(ID,entry,label)
end do end do
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 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) entryOffset(:,worldrank) = sum(entryOffset(:,0:worldrank-1),2)
do co = 1, size(ID,1) do co = 1, size(ID,1)
do ce = 1, size(ID,2) do ce = 1, size(ID,2)
@ -563,80 +563,80 @@ subroutine results_mapping_phase(ID,entry,label)
!--------------------------------------------------------------------------------------------------- !---------------------------------------------------------------------------------------------------
! compound type: label(ID) + entry ! compound type: label(ID) + entry
call H5Tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr) 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) 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) 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) pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND)
call H5Tget_size_f(pI64_t, type_size_int, hdferr) 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) 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) 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) 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 ! create memory types for each component of the compound type
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr) 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) 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) 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) 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) 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) ! create dataspace in memory (local shape = hyperslab) and in file (global shape)
call H5Screate_simple_f(2,myShape,memspace_id,hdferr,myShape) 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) 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) 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 ! write the components of the compound type individually
call H5Pset_preserve_f(plist_id, .true., hdferr) 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') loc_id = results_openGroup('/cell_to')
call H5Dcreate_f(loc_id, 'phase', dtype_id, filespace_id, dset_id, hdferr) 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), & 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) 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), & 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) 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 ! close all
call HDF5_closeGroup(loc_id) call HDF5_closeGroup(loc_id)
call H5Pclose_f(plist_id, hdferr) 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) 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) 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) 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) 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) 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 H5Tclose_f(entry_id, hdferr)
call executionStamp('cell_to/phase','cell ID and constituent ID to phase results') 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 writeSize(worldrank) = size(entry) ! total number of entries of this process
call H5Pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) 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 #ifndef PETSC
entryGlobal = int(entry -1,pI64) ! 0-based entryGlobal = int(entry -1,pI64) ! 0-based
@ -691,17 +691,17 @@ subroutine results_mapping_homogenization(ID,entry,label)
!-------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------
! MPI settings and communication ! MPI settings and communication
call H5Pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) 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 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 entryOffset = 0_pI64
do ce = 1, size(ID,1) do ce = 1, size(ID,1)
entryOffset(ID(ce),worldrank) = entryOffset(ID(ce),worldrank) +1_pI64 entryOffset(ID(ce),worldrank) = entryOffset(ID(ce),worldrank) +1_pI64
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 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) entryOffset(:,worldrank) = sum(entryOffset(:,0:worldrank-1),2)
do ce = 1, size(ID,1) do ce = 1, size(ID,1)
entryGlobal(ce) = int(entry(ce),pI64) -1_pI64 + entryOffset(ID(ce),worldrank) 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 ! compound type: label(ID) + entry
call H5Tcopy_f(H5T_NATIVE_CHARACTER, dt_id, hdferr) 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) 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) 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) pI64_t = h5kind_to_type(kind(entryGlobal),H5_INTEGER_KIND)
call H5Tget_size_f(pI64_t, type_size_int, hdferr) 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) 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) 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) 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 ! create memory types for each component of the compound type
call H5Tcreate_f(H5T_COMPOUND_F, type_size_string, label_id, hdferr) 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) 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) 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) 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) 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) ! create dataspace in memory (local shape = hyperslab) and in file (global shape)
call H5Screate_simple_f(1,myShape,memspace_id,hdferr,myShape) 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) 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) 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 ! write the components of the compound type individually
call H5Pset_preserve_f(plist_id, .true., hdferr) 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') loc_id = results_openGroup('/cell_to')
call H5Dcreate_f(loc_id, 'homogenization', dtype_id, filespace_id, dset_id, hdferr) 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), & 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) 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), & 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) 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 ! close all
call HDF5_closeGroup(loc_id) call HDF5_closeGroup(loc_id)
call H5Pclose_f(plist_id, hdferr) 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) 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) 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) 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) 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) 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 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') 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) axis = ax(1:3)
else else
axis = ax(1:3) * merge(-1.0_pReal,1.0_pReal,P == 1) 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 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') call IO_error(402,ext_msg='fromAxisAngle')
self%q = ax2qu([axis,angle]) self%q = ax2qu([axis,angle])
@ -513,11 +513,11 @@ pure function om2qu(om) result(qu)
trace = math_trace33(om) 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) 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] 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 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)) 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] 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 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] 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
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(2:4) = merge(qu(2:4),qu(2:4)*P,dEq0(qu(2:4)))
qu = qu/norm2(qu) qu = qu/norm2(qu)
@ -619,7 +619,7 @@ pure function eu2qu(eu) result(qu)
-P*sPhi*cos(ee(1)-ee(3)), & -P*sPhi*cos(ee(1)-ee(3)), &
-P*sPhi*sin(ee(1)-ee(3)), & -P*sPhi*sin(ee(1)-ee(3)), &
-P*cPhi*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 end function eu2qu
@ -807,15 +807,15 @@ subroutine selfTest()
do i = 1, 20 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] 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] 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] 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] 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] qu = [0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal]
else else
call random_number(x) call random_number(x)
@ -825,20 +825,20 @@ subroutine selfTest()
sin(TAU*x(2))*B,& sin(TAU*x(2))*B,&
cos(TAU*x(2))*B,& cos(TAU*x(2))*B,&
sin(TAU*x(1))*A] 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 end if
if(.not. quaternion_equal(om2qu(qu2om(qu)),qu)) error stop 'om2qu2om' 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(eu2qu(qu2eu(qu)),qu)) error stop 'eu2qu2eu'
if(.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) error stop 'ax2qu2ax' if (.not. quaternion_equal(ax2qu(qu2ax(qu)),qu)) error stop 'ax2qu2ax'
om = qu2om(qu) om = qu2om(qu)
if(.not. quaternion_equal(om2qu(eu2om(om2eu(om))),qu)) error stop 'eu2om2eu' 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(ax2om(om2ax(om))),qu)) error stop 'ax2om2ax'
eu = qu2eu(qu) 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) call R%fromMatrix(om)
@ -872,7 +872,7 @@ subroutine selfTest()
logical :: ok logical :: ok
ok = all(dEq(qu1,qu2,1.0e-7_pReal)) 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)) ok = ok .or. all(dEq(-1.0_pReal*qu1,qu2,1.0e-7_pReal))
end function quaternion_equal end function quaternion_equal

6
src/system_routines.f90
View File

@ -119,7 +119,7 @@ function getCWD()
call getCWD_C(getCWD_Cstring,stat) call getCWD_C(getCWD_Cstring,stat)
if(stat == 0) then if (stat == 0) then
getCWD = c_f_string(getCWD_Cstring) getCWD = c_f_string(getCWD_Cstring)
else else
error stop 'invalid working directory' error stop 'invalid working directory'
@ -141,7 +141,7 @@ function getHostName()
call getHostName_C(getHostName_Cstring,stat) call getHostName_C(getHostName_Cstring,stat)
if(stat == 0) then if (stat == 0) then
getHostName = c_f_string(getHostName_Cstring) getHostName = c_f_string(getHostName_Cstring)
else else
getHostName = 'n/a (Error!)' getHostName = 'n/a (Error!)'
@ -163,7 +163,7 @@ function getUserName()
call getUserName_C(getUserName_Cstring,stat) call getUserName_C(getUserName_Cstring,stat)
if(stat == 0) then if (stat == 0) then
getUserName = c_f_string(getUserName_Cstring) getUserName = c_f_string(getUserName_Cstring)
else else
getUserName = 'n/a (Error!)' 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