From d0b1db19668e9c90a9a3fb678e87ca58dffd88c7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 4 Apr 2019 07:40:25 +0200 Subject: [PATCH 01/97] use consistent pre processor macro --- installation/mods_Abaqus/abaqus_v6.env | 2 +- installation/mods_Abaqus/abaqus_v6_debug.env | 2 +- .../2018.1/Marc_tools/include_linux64 | 2 +- .../2018/Marc_tools/include_linux64 | 14 ++++++++++++-- src/commercialFEM_fileList.f90 | 2 +- 5 files changed, 16 insertions(+), 6 deletions(-) diff --git a/installation/mods_Abaqus/abaqus_v6.env b/installation/mods_Abaqus/abaqus_v6.env index 0811d0f65..83cc2ed33 100644 --- a/installation/mods_Abaqus/abaqus_v6.env +++ b/installation/mods_Abaqus/abaqus_v6.env @@ -16,7 +16,7 @@ if False: # use hdf5 compiler wrapper in $PATH fortCmd = os.popen('h5fc -shlib -show').read().replace('\n','') # complicated way needed to pass in DAMASKVERSION string link_sl += fortCmd.split()[1:] - fortCmd +=" -DDAMASKHDF5" + fortCmd +=" -DDAMASK_HDF5" else: # Use the version in $PATH fortCmd = "ifort" diff --git a/installation/mods_Abaqus/abaqus_v6_debug.env b/installation/mods_Abaqus/abaqus_v6_debug.env index 943f40bfa..943d0d10e 100644 --- a/installation/mods_Abaqus/abaqus_v6_debug.env +++ b/installation/mods_Abaqus/abaqus_v6_debug.env @@ -16,7 +16,7 @@ if False: # use hdf5 compiler wrapper in $PATH fortCmd = os.popen('h5fc -shlib -show').read().replace('\n','') # complicated way needed to pass in DAMASKVERSION string link_sl += fortCmd.split()[1:] - fortCmd +=" -DDAMASKHDF5" + fortCmd +=" -DDAMASK_HDF5" else: # Use the version in $PATH fortCmd = "ifort" diff --git a/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 index 661d3aaca..538434ad0 100644 --- a/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2018.1/Marc_tools/include_linux64 @@ -102,7 +102,7 @@ fi if test "$DAMASK_HDF5" = "ON";then H5FC="$(h5fc -shlib -show)" HDF5_LIB=${H5FC//ifort/} - FCOMP="$H5FC -DDAMASKHDF5" + FCOMP="$H5FC -DDAMASK_HDF5" echo $FCOMP else FCOMP=ifort diff --git a/installation/mods_MarcMentat/2018/Marc_tools/include_linux64 b/installation/mods_MarcMentat/2018/Marc_tools/include_linux64 index 270184af2..d3151ac6c 100644 --- a/installation/mods_MarcMentat/2018/Marc_tools/include_linux64 +++ b/installation/mods_MarcMentat/2018/Marc_tools/include_linux64 @@ -63,7 +63,6 @@ else INTEGER_PATH=/$MARC_INTEGER_SIZE fi -FCOMP=ifort INTELPATH="/opt/intel/compilers_and_libraries_2017/linux" # find the root directory of the compiler installation: @@ -99,6 +98,16 @@ else FCOMPROOT= fi +# DAMASK uses the HDF5 compiler wrapper around the Intel compiler +if test "$DAMASK_HDF5" = "ON";then + H5FC="$(h5fc -shlib -show)" + HDF5_LIB=${H5FC//ifort/} + FCOMP="$H5FC -DDAMASK_HDF5" + echo $FCOMP +else + FCOMP=ifort +fi + # AEM if test "$MARCDLLOUTDIR" = ""; then DLLOUTDIR="$MARC_LIB" @@ -535,6 +544,7 @@ else DAMASKVERSION="'N/A'" fi + # DAMASK compiler calls: additional flags are in line 2 OpenMP flags in line 3 DFORTLOWMP="$FCOMP -c -implicitnone -stand f08 -standard-semantics -assume nostd_mod_proc_name -safe_cray_ptr $PROFILE -zero -mp1 -WB -O0 $I8FFLAGS -I$MARC_SOURCE/common \ -fpp -ftz -diag-disable 5268 -warn declarations -warn general -warn usage -warn interfaces -warn ignore_loc -warn alignments -DMarc4DAMASK=2018 -DDAMASKVERSION=$DAMASKVERSION \ @@ -737,7 +747,7 @@ SECLIBS="-L$MARC_LIB -llapi" SOLVERLIBS="${BCSSOLVERLIBS} ${VKISOLVERLIBS} ${CASISOLVERLIBS} ${MF2SOLVERLIBS} \ $MKLLIB -L$MARC_MKL -liomp5 \ - $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/kdtree2.a " + $MARC_LIB/blas_src.a ${ACSI_LIB}/ACSI_MarcLib.a $KDTREE2_LIB/kdtree2.a $HDF5_LIB " SOLVERLIBS_DLL=${SOLVERLIBS} if test "$AEM_DLL" -eq 1 diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 301274897..342fbab0f 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -9,7 +9,7 @@ #include "list.f90" #include "future.f90" #include "config.f90" -#ifdef DAMASKHDF5 +#ifdef DAMASK_HDF5 #include "HDF5_utilities.f90" #include "results.f90" #endif From 4cac2448d42fd64e91e6dff599576f941353e9fb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 4 Apr 2019 07:52:36 +0200 Subject: [PATCH 02/97] writing more results out --- src/constitutive.f90 | 2 +- src/plastic_disloUCLA.f90 | 29 ++++-- src/plastic_isotropic.f90 | 19 ++-- src/plastic_phenopowerlaw.f90 | 42 ++++---- src/results.f90 | 181 ++++++++++++++++++++++++++++++---- 5 files changed, 219 insertions(+), 54 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 23ae3f07b..c6978915f 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -1085,7 +1085,7 @@ subroutine constitutive_results() PLASTICITY_DISLOTWIN_ID, & PLASTICITY_DISLOUCLA_ID, & PLASTICITY_NONLOCAL_ID -#if defined(PETSc) || defined(DAMASKHDF5) +#if defined(PETSc) || defined(DAMASK_HDF5) use results use HDF5_utilities use config, only: & diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 88aa27432..99444421b 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -560,23 +560,40 @@ end function plastic_disloUCLA_postResults !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_disloUCLA_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) +#if defined(PETSc) || defined(DAMASK_HDF5) use results implicit none - integer, intent(in) :: instance - character(len=*) :: group + integer, intent(in) :: instance + character(len=*), intent(in) :: group + integer :: o - associate(prm => param(instance), stt => state(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + case (rho_mob_ID) + call results_writeDataset(group,stt%rho_mob,'rho_mob',& + 'mobile dislocation density','1/m^2') + case (rho_dip_ID) + call results_writeDataset(group,stt%rho_dip,'rho_dip',& + 'dislocation dipole density''1/m^2') + case (dot_gamma_sl_ID) + call results_writeDataset(group,stt%gamma_sl,'dot_gamma_sl',& + 'plastic slip','1') + case (Lambda_sl_ID) + call results_writeDataset(group,dst%Lambda_sl,'Lambda_sl',& + 'mean free path for slip','m') + case (thresholdstress_ID) + call results_writeDataset(group,dst%threshold_stress,'threshold_stress',& + 'threshold stress for slip','Pa') end select enddo outputsLoop end associate + #else - integer, intent(in) :: instance - character(len=*) :: group + integer, intent(in) :: instance + character(len=*), intent(in) :: group #endif end subroutine plastic_disloUCLA_results diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 05a31ab75..984e13f0e 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -409,8 +409,7 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) xi_inf_star = prm%xi_inf else xi_inf_star = prm%xi_inf & - + asinh( (dot_gamma / prm%c_1)**(1.0_pReal / prm%c_2) & - )**(1.0_pReal / prm%c_3) & + + asinh( (dot_gamma / prm%c_1)**(1.0_pReal / prm%c_2))**(1.0_pReal / prm%c_3) & / prm%c_4 * (dot_gamma / prm%dot_gamma_0)**(1.0_pReal / prm%n) endif dot%xi(of) = dot_gamma & @@ -469,7 +468,7 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) c = c + 1 case (dot_gamma_ID) postResults(c+1) = prm%dot_gamma_0 & - * (sqrt(1.5_pReal) * norm_Mp /(prm%M * stt%xi(of)))**prm%n + * (sqrt(1.5_pReal) * norm_Mp /(prm%M * stt%xi(of)))**prm%n c = c + 1 end select @@ -484,23 +483,27 @@ end function plastic_isotropic_postResults !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_isotropic_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) +#if defined(PETSc) || defined(DAMASK_HDF5) use results implicit none - integer, intent(in) :: instance - character(len=*) :: group + integer, intent(in) :: instance + character(len=*), intent(in) :: group + integer :: o associate(prm => param(instance), stt => state(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + case (xi_ID) + call results_writeDataset(group,stt%xi,'xi','resistance against plastic flow','Pa') end select enddo outputsLoop end associate + #else - integer, intent(in) :: instance - character(len=*) :: group + integer, intent(in) :: instance + character(len=*), intent(in) :: group #endif end subroutine plastic_isotropic_results diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 4124856d1..c2a4843f2 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -563,28 +563,34 @@ end function plastic_phenopowerlaw_postResults !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_phenopowerlaw_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) - use results +#if defined(PETSc) || defined(DAMASK_HDF5) + use results - implicit none - integer, intent(in) :: instance - character(len=*) :: group - integer :: o + implicit none + integer, intent(in) :: instance + character(len=*), intent(in) :: group + + integer :: o - associate(prm => param(instance), stt => state(instance)) - outputsLoop: do o = 1,size(prm%outputID) - select case(prm%outputID(o)) - case (resistance_slip_ID) - call results_writeVectorDataset(group,stt%xi_slip,'xi_slip','Pa') - case (accumulatedshear_slip_ID) - call results_writeVectorDataset(group,stt%gamma_slip,'gamma_slip','-') - end select - enddo outputsLoop - end associate + associate(prm => param(instance), stt => state(instance)) + outputsLoop: do o = 1,size(prm%outputID) + select case(prm%outputID(o)) + case (resistance_slip_ID) + call results_writeDataset(group,stt%xi_slip, 'xi_slip', & + 'resistance against plastic slip','Pa') + case (accumulatedshear_slip_ID) + call results_writeDataset(group,stt%gamma_slip,'gamma_slip', & + 'plastic slip','1') + + end select + enddo outputsLoop + end associate + #else - integer, intent(in) :: instance - character(len=*) :: group + integer, intent(in) :: instance + character(len=*), intent(in) :: group #endif + end subroutine plastic_phenopowerlaw_results diff --git a/src/results.f90 b/src/results.f90 index f70e124f8..cd4a15cef 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -18,6 +18,13 @@ module results integer(HID_T), public, protected :: tempCoordinates, tempResults integer(HID_T), private :: resultsFile, currentIncID, plist_id + interface results_writeDataset + module procedure results_writeTensorDataset_real + module procedure results_writeTensorDataset_int + module procedure results_writeVectorDataset_real + module procedure results_writeVectorDataset_int + module procedure results_writeScalarDataset_real + end interface results_writeDataset public :: & results_init, & @@ -26,8 +33,9 @@ module results results_addIncrement, & results_addGroup, & results_openGroup, & - results_writeVectorDataset, & + results_writeDataset, & results_setLink, & + results_addAttribute, & results_removeLink contains @@ -36,13 +44,21 @@ subroutine results_init getSolverJobName implicit none + character(len=pStringLen) :: commandLine write(6,'(/,a)') ' <<<+- results init -+>>>' write(6,'(/,a)') ' Diehl et al., Integrating Materials and Manufacturing Innovation 6(1):83–91, 2017' write(6,'(a)') ' https://doi.org/10.1007/s40192-018-0118-7' - call HDF5_closeFile(HDF5_openFile(trim(getSolverJobName())//'.hdf5','w',.true.)) + resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','w',.true.) + call HDF5_addAttribute(resultsFile,'DADF5-version',0.1) + call HDF5_addAttribute(resultsFile,'DADF5-major',0) + call HDF5_addAttribute(resultsFile,'DADF5-minor',1) + call HDF5_addAttribute(resultsFile,'DAMASK',DAMASKVERSION) + call get_command(commandLine) + call HDF5_addAttribute(resultsFile,'call',trim(commandLine)) + call HDF5_closeFile(resultsFile) end subroutine results_init @@ -50,18 +66,13 @@ end subroutine results_init !-------------------------------------------------------------------------------------------------- !> @brief opens the results file to append data !-------------------------------------------------------------------------------------------------- -subroutine results_openJobFile() +subroutine results_openJobFile use DAMASK_interface, only: & getSolverJobName implicit none - character(len=pStringLen) :: commandLine resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','a',.true.) - call HDF5_addAttribute(resultsFile,'DADF5',0.1_pReal) - call HDF5_addAttribute(resultsFile,'DAMASK',DAMASKVERSION) - call get_command(commandLine) - call HDF5_addAttribute(resultsFile,'call',trim(commandLine)) end subroutine results_openJobFile @@ -69,7 +80,7 @@ end subroutine results_openJobFile !-------------------------------------------------------------------------------------------------- !> @brief closes the results file !-------------------------------------------------------------------------------------------------- -subroutine results_closeJobFile() +subroutine results_closeJobFile implicit none call HDF5_closeFile(resultsFile) @@ -87,7 +98,7 @@ subroutine results_addIncrement(inc,time) real(pReal), intent(in) :: time character(len=pStringLen) :: incChar - write(incChar,*) inc + write(incChar,'(i5.5)') inc ! allow up to 99999 increments call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) call results_setLink(trim('inc'//trim(adjustl(incChar))),'current') call HDF5_addAttribute(resultsFile,'time/s',time,trim('inc'//trim(adjustl(incChar)))) @@ -135,6 +146,19 @@ subroutine results_setLink(path,link) end subroutine results_setLink +!-------------------------------------------------------------------------------------------------- +!> @brief adds an attribute to an object +!-------------------------------------------------------------------------------------------------- +subroutine results_addAttribute(attrLabel,attrValue,path) + + implicit none + character(len=*), intent(in) :: attrLabel, attrValue, path + + call HDF5_addAttribute_str(resultsFile,attrLabel, attrValue, path) + +end subroutine results_addAttribute + + !-------------------------------------------------------------------------------------------------- !> @brief remove link to an object !-------------------------------------------------------------------------------------------------- @@ -151,23 +175,138 @@ subroutine results_removeLink(link) end subroutine results_removeLink +!-------------------------------------------------------------------------------------------------- +!> @brief stores a scalar dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeScalarDataset_real(group,dataset,label,description,SIunit) + + implicit none + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: SIunit + real(pReal), intent(inout), dimension(:) :: dataset + + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeScalarDataset_real + !-------------------------------------------------------------------------------------------------- !> @brief stores a vector dataset in a group !-------------------------------------------------------------------------------------------------- -subroutine results_writeVectorDataset(group,dataset,label,SIunit) +subroutine results_writeVectorDataset_real(group,dataset,label,description,SIunit) - implicit none - character(len=*), intent(in) :: SIunit,label,group - real(pReal), intent(inout), dimension(:,:) :: dataset - integer(HID_T) :: groupHandle + implicit none + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: SIunit + real(pReal), intent(inout), dimension(:,:) :: dataset + + integer(HID_T) :: groupHandle - groupHandle = results_openGroup(group) - call HDF5_write(groupHandle,dataset,label) - if (HDF5_objectExists(groupHandle,label)) & - call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) - call HDF5_closeGroup(groupHandle) + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + call HDF5_closeGroup(groupHandle) -end subroutine results_writeVectorDataset +end subroutine results_writeVectorDataset_real + + +!-------------------------------------------------------------------------------------------------- +!> @brief stores a tensor dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeTensorDataset_real(group,dataset,label,description,SIunit) + + implicit none + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: SIunit + real(pReal), intent(inout), dimension(:,:,:) :: dataset + + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeTensorDataset_real + + +!-------------------------------------------------------------------------------------------------- +!> @brief stores a vector dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeVectorDataset_int(group,dataset,label,description,SIunit) + + implicit none + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: SIunit + integer, intent(inout), dimension(:,:) :: dataset + + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeVectorDataset_int + + +!-------------------------------------------------------------------------------------------------- +!> @brief stores a vector dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeTensorDataset_int(group,dataset,label,description,SIunit) + + implicit none + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: SIunit + integer, intent(inout), dimension(:,:,:) :: dataset + + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & + call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeTensorDataset_int !-------------------------------------------------------------------------------------------------- From 658befa1a161bbf4465d2f57e256169c517f2781 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 4 Apr 2019 09:12:57 +0200 Subject: [PATCH 03/97] no pInt and some renames --- src/HDF5_utilities.f90 | 448 ++++++++++++++++++++--------------------- 1 file changed, 224 insertions(+), 224 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index a81aaee0e..75074fa73 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -465,26 +465,26 @@ subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & ! ToDo: Fortran 2018 size(shape(A)) = rank(A) myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dread_f') @@ -506,26 +506,26 @@ subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dread_f') @@ -547,26 +547,26 @@ subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dread_f') @@ -588,26 +588,26 @@ subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dread_f') @@ -629,26 +629,26 @@ subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dread_f') @@ -670,26 +670,26 @@ subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dread_f') @@ -711,26 +711,26 @@ subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dread_f') @@ -745,7 +745,7 @@ end subroutine HDF5_read_pReal7 subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:) :: dataset + integer, intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -753,26 +753,26 @@ subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dread_f') @@ -786,7 +786,7 @@ end subroutine HDF5_read_pInt1 subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:) :: dataset + integer, intent(inout), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -794,26 +794,26 @@ subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dread_f') @@ -827,7 +827,7 @@ end subroutine HDF5_read_pInt2 subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:) :: dataset + integer, intent(inout), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -835,26 +835,26 @@ subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dread_f') @@ -868,7 +868,7 @@ end subroutine HDF5_read_pInt3 subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset + integer, intent(inout), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -876,26 +876,26 @@ subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dread_f') @@ -909,7 +909,7 @@ end subroutine HDF5_read_pInt4 subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset + integer, intent(inout), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -917,26 +917,26 @@ subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dread_f') @@ -950,7 +950,7 @@ end subroutine HDF5_read_pInt5 subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer, intent(inout), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -958,26 +958,26 @@ subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dread_f') @@ -991,7 +991,7 @@ end subroutine HDF5_read_pInt6 subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer, intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -999,26 +999,26 @@ subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures if (present(parallel)) then call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,parallel) + myStart, totalShape, loc_id,myShape,datasetName,parallel) else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, globalShape, loc_id,localShape,datasetName,.false.) + myStart, totalShape, loc_id,myShape,datasetName,.false.) endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,globalShape, 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dread_f') @@ -1043,25 +1043,25 @@ subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape,loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape,loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1083,25 +1083,25 @@ subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1123,25 +1123,25 @@ subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1163,25 +1163,25 @@ subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1204,25 +1204,25 @@ subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1244,25 +1244,25 @@ subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1284,25 +1284,25 @@ subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1315,7 +1315,7 @@ end subroutine HDF5_write_pReal7 subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:) :: dataset + integer, intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -1325,25 +1325,25 @@ subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1355,7 +1355,7 @@ end subroutine HDF5_write_pInt1 subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:) :: dataset + integer, intent(inout), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -1365,25 +1365,25 @@ subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1395,7 +1395,7 @@ end subroutine HDF5_write_pInt2 subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:) :: dataset + integer, intent(inout), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -1405,25 +1405,25 @@ subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1435,7 +1435,7 @@ end subroutine HDF5_write_pInt3 subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:) :: dataset + integer, intent(inout), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -1445,25 +1445,25 @@ subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1475,7 +1475,7 @@ end subroutine HDF5_write_pInt4 subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:) :: dataset + integer, intent(inout), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -1485,25 +1485,25 @@ subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1515,7 +1515,7 @@ end subroutine HDF5_write_pInt5 subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer, intent(inout), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -1525,25 +1525,25 @@ subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1555,7 +1555,7 @@ end subroutine HDF5_write_pInt6 subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) implicit none - integer(pInt), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer, intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in), optional :: parallel @@ -1565,25 +1565,25 @@ subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id integer(HSIZE_T), dimension(size(shape(dataset))) :: & myStart, & - localShape, & !< shape of the dataset (this process) - globalShape !< shape of the dataset (all processes) + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - localShape = int(shape(dataset),HSIZE_T) - if (any(localShape(1:size(localShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) if (present(parallel)) then call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,parallel) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, loc_id,localShape,datasetName,H5T_NATIVE_INTEGER,.false.) + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(globalShape,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) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dread_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dwrite_f') call finalize_write(plist_id, dset_id, filespace_id, memspace_id) From 811883df285e5fcd800ddc147cd742c1a71c312a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 4 Apr 2019 10:03:52 +0200 Subject: [PATCH 04/97] avoid error for empty datasets --- src/HDF5_utilities.f90 | 61 ++++++++++++++++++++++++++---------------- 1 file changed, 38 insertions(+), 23 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 75074fa73..8033c8eed 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -1059,6 +1059,7 @@ subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dwrite_f') @@ -1099,6 +1100,7 @@ subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dwrite_f') @@ -1139,6 +1141,7 @@ subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dwrite_f') @@ -1179,6 +1182,7 @@ subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dwrite_f') @@ -1220,6 +1224,7 @@ subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dwrite_f') @@ -1260,6 +1265,7 @@ subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dwrite_f') @@ -1300,6 +1306,7 @@ subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dwrite_f') @@ -1341,6 +1348,7 @@ subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dwrite_f') @@ -1381,6 +1389,7 @@ subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dwrite_f') @@ -1421,6 +1430,7 @@ subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dwrite_f') @@ -1461,6 +1471,7 @@ subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dwrite_f') @@ -1501,6 +1512,7 @@ subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dwrite_f') @@ -1541,6 +1553,7 @@ subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dwrite_f') @@ -1581,6 +1594,7 @@ subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif + if (product(totalShape) /= 0) & call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dwrite_f') @@ -1690,8 +1704,8 @@ end subroutine finalize_read !> @brief initialize HDF5 handles, determines global shape and start for parallel write !-------------------------------------------------------------------------------------------------- subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, globalShape, & - loc_id,localShape,datasetName,datatype,parallel) + myStart, totalShape, & + loc_id,myShape,datasetName,datatype,parallel) use numerics, only: & worldrank, & worldsize @@ -1699,59 +1713,60 @@ subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & implicit none integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in) :: parallel - integer(HID_T), intent(in) :: datatype + logical, intent(in) :: parallel + integer(HID_T), intent(in) :: datatype integer(HSIZE_T), intent(in), dimension(:) :: & - localShape - integer(HSIZE_T), intent(out), dimension(size(localShape,1)):: & + myShape + integer(HSIZE_T), intent(out), dimension(size(myShape,1)):: & myStart, & - globalShape !< shape of the dataset (all processes) + totalShape !< shape of the dataset (all processes) integer(HID_T), intent(out) :: dset_id, filespace_id, memspace_id, plist_id - integer(pInt), dimension(worldsize) :: & + integer, dimension(worldsize) :: & writeSize !< contribution of all processes integer :: ierr integer :: hdferr !------------------------------------------------------------------------------------------------- -! creating a property list for transfer properties +! creating a property list for transfer properties (is collective when reading in parallel) call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5pcreate_f') - -!-------------------------------------------------------------------------------------------------- - writeSize = 0_pInt - writeSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) - #ifdef PETSc if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5pset_dxpl_mpio_f') + endif +#endif + +!-------------------------------------------------------------------------------------------------- +! determine the global data layout among all processes + writeSize = 0_pInt + writeSize(worldrank+1) = int(myShape(ubound(myShape,1)),pInt) +#ifdef PETSc +if (parallel) then call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process if (ierr /= 0) call IO_error(894_pInt,ext_msg='initialize_write: MPI_allreduce') endif #endif - myStart = int(0,HSIZE_T) myStart(ubound(myStart)) = int(sum(writeSize(1:worldrank)),HSIZE_T) - globalShape = [localShape(1:ubound(localShape,1)-1),int(sum(writeSize),HSIZE_T)] + totalShape = [myShape(1:ubound(myShape,1)-1),int(sum(writeSize),HSIZE_T)] !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) and in file (global shape) - call h5screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) + call h5screate_simple_f(size(myShape), myShape, memspace_id, hdferr, myShape) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dopen_f') - call h5screate_simple_f(size(globalShape), globalShape, filespace_id, hdferr, globalShape) + call h5screate_simple_f(size(totalShape), totalShape, filespace_id, hdferr, totalShape) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dget_space_f') !-------------------------------------------------------------------------------------------------- -! create dataset +! 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) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dcreate_f') - -!-------------------------------------------------------------------------------------------------- -! select a hyperslab (the portion of the current process) in the file - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, myShape, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5sselect_hyperslab_f') + end subroutine initialize_write From bc4b79a3a28d64da8231ff8a9426d5438c353b92 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 4 Apr 2019 10:04:44 +0200 Subject: [PATCH 05/97] writing results out credits to Vitesh --- src/constitutive.f90 | 41 +++++++++++++---------- src/plastic_disloUCLA.f90 | 4 +-- src/plastic_dislotwin.f90 | 54 ++++++++++++++++++++++++------ src/plastic_kinematichardening.f90 | 2 +- src/plastic_nonlocal.f90 | 2 +- src/plastic_phenopowerlaw.f90 | 1 + 6 files changed, 72 insertions(+), 32 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index c6978915f..ada022e37 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -1109,35 +1109,42 @@ subroutine constitutive_results() plastic_nonlocal_results implicit none - integer :: p - call HDF5_closeGroup(results_addGroup('current/phase')) - do p=1,size(config_name_phase) - call HDF5_closeGroup(results_addGroup('current/phase/'//trim(config_name_phase(p)))) + integer :: p + character(len=256) :: group + character(len=16) :: i + + call HDF5_closeGroup(results_addGroup('current/constitutive')) + + do p=1,size(config_name_phase) + write(i,('(i2.2)')) p ! allow 99 groups + group = trim('current/constitutive')//'/'//trim(i)//'_'//trim(config_name_phase(p)) + call HDF5_closeGroup(results_addGroup(group)) + group = trim(group)//'/'//'plastic' + + call HDF5_closeGroup(results_addGroup(group)) select case(material_phase_plasticity_type(p)) case(PLASTICITY_ISOTROPIC_ID) - call plastic_isotropic_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) + call plastic_isotropic_results(phase_plasticityInstance(p),group) case(PLASTICITY_PHENOPOWERLAW_ID) - call plastic_phenopowerlaw_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) + call plastic_phenopowerlaw_results(phase_plasticityInstance(p),group) - case(PLASTICITY_KINEHARDENING_ID) - call plastic_kinehardening_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) + case(PLASTICITY_KINEHARDENING_ID) + call plastic_kinehardening_results(phase_plasticityInstance(p),group) - case(PLASTICITY_DISLOTWIN_ID) - call plastic_dislotwin_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) + case(PLASTICITY_DISLOTWIN_ID) + call plastic_dislotwin_results(phase_plasticityInstance(p),group) - case(PLASTICITY_DISLOUCLA_ID) - call plastic_disloUCLA_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) + case(PLASTICITY_DISLOUCLA_ID) + call plastic_disloUCLA_results(phase_plasticityInstance(p),group) - case(PLASTICITY_NONLOCAL_ID) - call plastic_nonlocal_results(phase_plasticityInstance(p),'current/phase/'//trim(config_name_phase(p))) - + case(PLASTICITY_NONLOCAL_ID) + call plastic_nonlocal_results(phase_plasticityInstance(p),group) end select - enddo - + enddo #endif diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 99444421b..4fb83a6ce 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -574,10 +574,10 @@ subroutine plastic_disloUCLA_results(instance,group) select case(prm%outputID(o)) case (rho_mob_ID) call results_writeDataset(group,stt%rho_mob,'rho_mob',& - 'mobile dislocation density','1/m^2') + 'mobile dislocation density','1/m²') case (rho_dip_ID) call results_writeDataset(group,stt%rho_dip,'rho_dip',& - 'dislocation dipole density''1/m^2') + 'dislocation dipole density''1/m²') case (dot_gamma_sl_ID) call results_writeDataset(group,stt%gamma_sl,'dot_gamma_sl',& 'plastic slip','1') diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index cb13265b4..1ad6f9763 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -148,7 +148,7 @@ module plastic_dislotwin type(tDislotwinState), allocatable, dimension(:), private :: & dotState, & state - type(tDislotwinMicrostructure), allocatable, dimension(:), private :: microstructure + type(tDislotwinMicrostructure), allocatable, dimension(:), private :: dependentState public :: & plastic_dislotwin_init, & @@ -241,14 +241,14 @@ subroutine plastic_dislotwin_init allocate(param(Ninstance)) allocate(state(Ninstance)) allocate(dotState(Ninstance)) - allocate(microstructure(Ninstance)) + allocate(dependentState(Ninstance)) do p = 1, size(phase_plasticity) if (phase_plasticity(p) /= PLASTICITY_DISLOTWIN_ID) cycle associate(prm => param(phase_plasticityInstance(p)), & dot => dotState(phase_plasticityInstance(p)), & stt => state(phase_plasticityInstance(p)), & - dst => microstructure(phase_plasticityInstance(p)), & + dst => dependentState(phase_plasticityInstance(p)), & config => config_phase(p)) prm%aTol_rho = config%getFloat('atol_rho', defaultVal=0.0_pReal) @@ -801,7 +801,7 @@ subroutine plastic_dislotwin_dotState(Mp,T,instance,of) dot_gamma_tr associate(prm => param(instance), stt => state(instance), & - dot => dotstate(instance), dst => microstructure(instance)) + dot => dotstate(instance), dst => dependentState(instance)) f_unrotated = 1.0_pReal & - sum(stt%f_tw(1:prm%sum_N_tw,of)) & @@ -897,7 +897,7 @@ subroutine plastic_dislotwin_dependentState(T,instance,of) associate(prm => param(instance),& stt => state(instance),& - dst => microstructure(instance)) + dst => dependentState(instance)) sumf_twin = sum(stt%f_tw(1:prm%sum_N_tw,of)) sumf_trans = sum(stt%f_tr(1:prm%sum_N_tr,of)) @@ -1002,7 +1002,7 @@ function plastic_dislotwin_postResults(Mp,T,instance,of) result(postResults) integer :: & o,c,j - associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) c = 0 @@ -1063,7 +1063,7 @@ end function plastic_dislotwin_postResults !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_dislotwin_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) +#if defined(PETSc) || defined(DAMASK_HDF5) use results implicit none @@ -1071,12 +1071,44 @@ subroutine plastic_dislotwin_results(instance,group) character(len=*) :: group integer :: o - associate(prm => param(instance), stt => state(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + + case (rho_mob_ID) + call results_writeDataset(group,stt%rho_mob,'rho_mob',& + 'mobile dislocation density','1/m²') + case (rho_dip_ID) + call results_writeDataset(group,stt%rho_dip,'rho_dip',& + 'dislocation dipole density''1/m²') + case (dot_gamma_sl_ID) + call results_writeDataset(group,stt%gamma_sl,'dot_gamma_sl',& + 'plastic slip','1') + case (Lambda_sl_ID) + call results_writeDataset(group,dst%Lambda_sl,'Lambda_sl',& + 'mean free path for slip','m') + case (threshold_stress_slip_ID) + call results_writeDataset(group,dst%tau_pass,'tau_pass',& + 'passing stress for slip','Pa') + + case (f_tw_ID) + call results_writeDataset(group,stt%f_tw,'f_tw',& + 'twinned volume fraction','m³/m³') + case (Lambda_tw_ID) + call results_writeDataset(group,dst%Lambda_tw,'Lambda_tw',& + 'mean free path for twinning','m') + case (tau_hat_tw_ID) + call results_writeDataset(group,dst%tau_hat_tw,'tau_hat_tw',& + 'threshold stress for twinnin','Pa') + + case (f_tr_ID) + call results_writeDataset(group,stt%f_tr,'f_tr',& + 'martensite volume fraction','m³/m³') + end select enddo outputsLoop end associate + #else integer, intent(in) :: instance character(len=*) :: group @@ -1130,7 +1162,7 @@ pure subroutine kinetics_slip(Mp,T,instance,of, & tau_eff !< effective resolved stress integer :: i - associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) do i = 1, prm%sum_N_sl tau(i) = math_mul33xx33(Mp,prm%P_sl(1:3,1:3,i)) @@ -1203,7 +1235,7 @@ pure subroutine kinetics_twin(Mp,T,dot_gamma_sl,instance,of,& integer :: i,s1,s2 - associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) do i = 1, prm%sum_N_tw tau(i) = math_mul33xx33(Mp,prm%P_tw(1:3,1:3,i)) @@ -1275,7 +1307,7 @@ pure subroutine kinetics_trans(Mp,T,dot_gamma_sl,instance,of,& integer :: i,s1,s2 - associate(prm => param(instance), stt => state(instance), dst => microstructure(instance)) + associate(prm => param(instance), stt => state(instance), dst => dependentState(instance)) do i = 1, prm%sum_N_tr tau(i) = math_mul33xx33(Mp,prm%P_tr(1:3,1:3,i)) diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 0a4a6b3bc..fa92be298 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -550,7 +550,7 @@ end function plastic_kinehardening_postResults !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_kinehardening_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) +#if defined(PETSc) || defined(DAMASK_HDF5) use results implicit none diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index f5f48ed11..0eec39ba1 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -2402,7 +2402,7 @@ end function getRho !> @brief writes results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_results(instance,group) -#if defined(PETSc) || defined(DAMASKHDF5) +#if defined(PETSc) || defined(DAMASK_HDF5) use results implicit none diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index c2a4843f2..de84fb12d 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -575,6 +575,7 @@ subroutine plastic_phenopowerlaw_results(instance,group) associate(prm => param(instance), stt => state(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + case (resistance_slip_ID) call results_writeDataset(group,stt%xi_slip, 'xi_slip', & 'resistance against plastic slip','Pa') From 280a11c4bc50ff8aec799ef90335bb2318aa53eb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 4 Apr 2019 11:49:23 +0200 Subject: [PATCH 06/97] avoid checking of unitialized variables --- src/HDF5_utilities.f90 | 1607 ++++++++++++++++++++-------------------- src/results.f90 | 87 +-- 2 files changed, 852 insertions(+), 842 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 8033c8eed..dd1746f5c 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -5,11 +5,11 @@ !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !-------------------------------------------------------------------------------------------------- module HDF5_utilities - use prec - use IO - use HDF5 + use prec + use IO + use HDF5 #ifdef PETSc - use PETSC + use PETSC #endif implicit none @@ -19,73 +19,77 @@ module HDF5_utilities !> @brief reads pInt or pReal data of defined shape from file ! ToDo: order of arguments wrong !> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- - interface HDF5_read - module procedure HDF5_read_pReal1 - module procedure HDF5_read_pReal2 - module procedure HDF5_read_pReal3 - module procedure HDF5_read_pReal4 - module procedure HDF5_read_pReal5 - module procedure HDF5_read_pReal6 - module procedure HDF5_read_pReal7 - - module procedure HDF5_read_pInt1 - module procedure HDF5_read_pInt2 - module procedure HDF5_read_pInt3 - module procedure HDF5_read_pInt4 - module procedure HDF5_read_pInt5 - module procedure HDF5_read_pInt6 - module procedure HDF5_read_pInt7 - - end interface HDF5_read + interface HDF5_read + module procedure HDF5_read_real1 + module procedure HDF5_read_real2 + module procedure HDF5_read_real3 + module procedure HDF5_read_real4 + module procedure HDF5_read_real5 + module procedure HDF5_read_real6 + module procedure HDF5_read_real7 + + module procedure HDF5_read_int1 + module procedure HDF5_read_int2 + module procedure HDF5_read_int3 + module procedure HDF5_read_int4 + module procedure HDF5_read_int5 + module procedure HDF5_read_int6 + module procedure HDF5_read_int7 + + end interface HDF5_read !-------------------------------------------------------------------------------------------------- !> @brief writes pInt or pReal data of defined shape to file ! ToDo: order of arguments wrong !> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- - interface HDF5_write - module procedure HDF5_write_pReal1 - module procedure HDF5_write_pReal2 - module procedure HDF5_write_pReal3 - module procedure HDF5_write_pReal4 - module procedure HDF5_write_pReal5 - module procedure HDF5_write_pReal6 - module procedure HDF5_write_pReal7 - - module procedure HDF5_write_pInt1 - module procedure HDF5_write_pInt2 - module procedure HDF5_write_pInt3 - module procedure HDF5_write_pInt4 - module procedure HDF5_write_pInt5 - module procedure HDF5_write_pInt6 - module procedure HDF5_write_pInt7 - - end interface HDF5_write + interface HDF5_write + module procedure HDF5_write_real1 + module procedure HDF5_write_real2 + module procedure HDF5_write_real3 + module procedure HDF5_write_real4 + module procedure HDF5_write_real5 + module procedure HDF5_write_real6 + module procedure HDF5_write_real7 + + module procedure HDF5_write_int1 + module procedure HDF5_write_int2 + module procedure HDF5_write_int3 + module procedure HDF5_write_int4 + module procedure HDF5_write_int5 + module procedure HDF5_write_int6 + module procedure HDF5_write_int7 + + end interface HDF5_write !-------------------------------------------------------------------------------------------------- !> @brief attached attributes of type char,pInt or pReal to a file/dataset/group !-------------------------------------------------------------------------------------------------- - interface HDF5_addAttribute - module procedure HDF5_addAttribute_str - module procedure HDF5_addAttribute_pInt - module procedure HDF5_addAttribute_pReal - end interface HDF5_addAttribute + interface HDF5_addAttribute + module procedure HDF5_addAttribute_str + module procedure HDF5_addAttribute_int + module procedure HDF5_addAttribute_real + end interface HDF5_addAttribute !-------------------------------------------------------------------------------------------------- - public :: & - HDF5_utilities_init, & - HDF5_openFile, & - HDF5_closeFile, & - HDF5_addAttribute, & - HDF5_closeGroup ,& - HDF5_openGroup, & - HDF5_addGroup, & - HDF5_read, & - HDF5_write, & - HDF5_setLink, & - HDF5_objectExists + public :: & + HDF5_utilities_init, & + HDF5_openFile, & + HDF5_closeFile, & + HDF5_addAttribute, & + HDF5_closeGroup ,& + HDF5_openGroup, & + HDF5_addGroup, & + HDF5_read, & + HDF5_write, & + HDF5_setLink, & + HDF5_objectExists contains + +!-------------------------------------------------------------------------------------------------- +!> @brief open libary and do sanity checks +!-------------------------------------------------------------------------------------------------- subroutine HDF5_utilities_init implicit none @@ -117,46 +121,46 @@ end subroutine HDF5_utilities_init !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_openFile(fileName,mode,parallel) ! ToDo: simply "open" is enough - implicit none - character(len=*), intent(in) :: fileName - character, intent(in), optional :: mode - logical, intent(in), optional :: parallel - - character :: m - integer(HID_T) :: plist_id - integer :: hdferr - - if (present(mode)) then - m = mode - else - m = 'r' - endif - - call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pcreate_f') + implicit none + character(len=*), intent(in) :: fileName + character, intent(in), optional :: mode + logical, intent(in), optional :: parallel + + character :: m + integer(HID_T) :: plist_id + integer :: hdferr + + if (present(mode)) then + m = mode + else + m = 'r' + endif + + call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pcreate_f') #ifdef PETSc - if (present(parallel)) then; if (parallel) then - call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pset_fapl_mpio_f') - endif; endif + if (present(parallel)) then; if (parallel) then + call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pset_fapl_mpio_f') + endif; endif #endif - if (m == 'w') then - call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f (w)') - elseif(m == 'a') then - call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)') - elseif(m == 'r') then - call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)') - else - call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode: '//trim(m)) - endif - - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pclose_f') + if (m == 'w') then + call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f (w)') + elseif(m == 'a') then + call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)') + elseif(m == 'r') then + call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)') + else + call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode: '//trim(m)) + endif + + call h5pclose_f(plist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pclose_f') end function HDF5_openFile @@ -166,13 +170,13 @@ end function HDF5_openFile !-------------------------------------------------------------------------------------------------- subroutine HDF5_closeFile(fileHandle) - implicit none - integer(HID_T), intent(in) :: fileHandle - - integer :: hdferr - - call h5fclose_f(fileHandle,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeFile: h5fclose_f') + implicit none + integer(HID_T), intent(in) :: fileHandle + + integer :: hdferr + + call h5fclose_f(fileHandle,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeFile: h5fclose_f') end subroutine HDF5_closeFile @@ -182,29 +186,29 @@ end subroutine HDF5_closeFile !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_addGroup(fileHandle,groupName) - implicit none - integer(HID_T), intent(in) :: fileHandle - character(len=*), intent(in) :: groupName + implicit none + integer(HID_T), intent(in) :: fileHandle + character(len=*), intent(in) :: groupName + + integer :: hdferr + integer(HID_T) :: aplist_id - integer :: hdferr - integer(HID_T) :: aplist_id +!------------------------------------------------------------------------------------------------- +! creating a property list for data access properties + call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pcreate_f ('//trim(groupName)//')') - !------------------------------------------------------------------------------------------------- - ! creating a property list for data access properties - call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pcreate_f ('//trim(groupName)//')') - - !------------------------------------------------------------------------------------------------- - ! setting I/O mode to collective +!------------------------------------------------------------------------------------------------- +! setting I/O mode to collective #ifdef PETSc - call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') + call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') #endif - !------------------------------------------------------------------------------------------------- - ! Create group - call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') +!------------------------------------------------------------------------------------------------- +! Create group + call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') end function HDF5_addGroup @@ -214,32 +218,32 @@ end function HDF5_addGroup !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_openGroup(fileHandle,groupName) - implicit none - integer(HID_T), intent(in) :: fileHandle - character(len=*), intent(in) :: groupName - - - integer :: hdferr - integer(HID_T) :: aplist_id - logical :: is_collective + implicit none + integer(HID_T), intent(in) :: fileHandle + character(len=*), intent(in) :: groupName + + + integer :: hdferr + integer(HID_T) :: aplist_id + logical :: is_collective !------------------------------------------------------------------------------------------------- ! creating a property list for data access properties - call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pcreate_f ('//trim(groupName)//')') + call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pcreate_f ('//trim(groupName)//')') !------------------------------------------------------------------------------------------------- ! setting I/O mode to collective #ifdef PETSc - call h5pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') + call h5pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') #endif !------------------------------------------------------------------------------------------------- ! opening the group - call h5gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') + call h5gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') end function HDF5_openGroup @@ -249,12 +253,12 @@ end function HDF5_openGroup !-------------------------------------------------------------------------------------------------- subroutine HDF5_closeGroup(group_id) - implicit none - integer(HID_T), intent(in) :: group_id - integer :: hdferr - - call h5gclose_f(group_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(group_id,pInt)) + implicit none + integer(HID_T), intent(in) :: group_id + integer :: hdferr + + call h5gclose_f(group_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(group_id,pInt)) end subroutine HDF5_closeGroup @@ -264,25 +268,25 @@ end subroutine HDF5_closeGroup !-------------------------------------------------------------------------------------------------- logical function HDF5_objectExists(loc_id,path) - implicit none - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in), optional :: path - integer :: hdferr - character(len=256) :: p + implicit none + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in), optional :: path + integer :: hdferr + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif - if (present(path)) then - p = trim(path) - else - p = '.' - endif - - call h5lexists_f(loc_id, p, HDF5_objectExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') - - if(HDF5_objectExists) then - call h5oexists_by_name_f(loc_id, p, HDF5_objectExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') - endif + call h5lexists_f(loc_id, p, HDF5_objectExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') + + if(HDF5_objectExists) then + call h5oexists_by_name_f(loc_id, p, HDF5_objectExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') + endif end function HDF5_objectExists @@ -292,43 +296,43 @@ end function HDF5_objectExists !-------------------------------------------------------------------------------------------------- subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path) - implicit none - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in) :: attrLabel, attrValue - character(len=*), intent(in), optional :: path - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - logical :: attrExists - character(len=256) :: p + implicit none + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel, attrValue + character(len=*), intent(in), optional :: path + integer :: hdferr + integer(HID_T) :: attr_id, space_id, type_id + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif - if (present(path)) then - p = trim(path) - else - p = '.' - endif - - call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5screate_f') - call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tcopy_f') - call h5tset_size_f(type_id, int(len(trim(attrValue)),HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tset_size_f') - call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aexists_by_name_f') - if (attrExists) then - call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5adelete_by_name_f') - endif - call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5acreate_f') - call h5awrite_f(attr_id, type_id, trim(attrValue), int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5awrite_f') - call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aclose_f') - call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tclose_f') - call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5sclose_f') + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5screate_f') + call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tcopy_f') + call h5tset_size_f(type_id, int(len(trim(attrValue)),HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tset_size_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5acreate_f') + call h5awrite_f(attr_id, type_id, trim(attrValue), int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aclose_f') + call h5tclose_f(type_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5sclose_f') end subroutine HDF5_addAttribute_str @@ -336,117 +340,116 @@ end subroutine HDF5_addAttribute_str !-------------------------------------------------------------------------------------------------- !> @brief adds a integer attribute to the path given relative to the location !-------------------------------------------------------------------------------------------------- -subroutine HDF5_addAttribute_pInt(loc_id,attrLabel,attrValue,path) +subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path) - implicit none - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in) :: attrLabel - integer(pInt), intent(in) :: attrValue - character(len=*), intent(in), optional :: path - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - logical :: attrExists - character(len=256) :: p + implicit none + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel + integer(pInt), intent(in) :: attrValue + character(len=*), intent(in), optional :: path + integer :: hdferr + integer(HID_T) :: attr_id, space_id, type_id + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif - if (present(path)) then - p = trim(path) - else - p = '.' - endif + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5screate_f') + call h5tcopy_f(H5T_NATIVE_INTEGER, type_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tcopy_f') + call h5tset_size_f(type_id, 1_HSIZE_T, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tset_size_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5acreate_f') + call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5aclose_f') + call h5tclose_f(type_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5sclose_f') - call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5screate_f') - call h5tcopy_f(H5T_NATIVE_INTEGER, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tcopy_f') - call h5tset_size_f(type_id, 1_HSIZE_T, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tset_size_f') - call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5aexists_by_name_f') - if (attrExists) then - call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5adelete_by_name_f') - endif - call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5acreate_f') - call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5awrite_f') - call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5aclose_f') - call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tclose_f') - call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5sclose_f') - -end subroutine HDF5_addAttribute_pInt +end subroutine HDF5_addAttribute_int !-------------------------------------------------------------------------------------------------- !> @brief adds a integer attribute to the path given relative to the location !-------------------------------------------------------------------------------------------------- -subroutine HDF5_addAttribute_pReal(loc_id,attrLabel,attrValue,path) +subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path) - implicit none - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in) :: attrLabel - real(pReal), intent(in) :: attrValue - character(len=*), intent(in), optional :: path - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - logical :: attrExists - character(len=256) :: p + implicit none + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel + real(pReal), intent(in) :: attrValue + character(len=*), intent(in), optional :: path + integer :: hdferr + integer(HID_T) :: attr_id, space_id, type_id + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif - if (present(path)) then - p = trim(path) - else - p = '.' - endif + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5screate_f') + call h5tcopy_f(H5T_NATIVE_DOUBLE, type_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tcopy_f') + call h5tset_size_f(type_id, 8_HSIZE_T, hdferr) ! ToDo + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tset_size_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5acreate_f') + call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5aclose_f') + call h5tclose_f(type_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5sclose_f') - call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5screate_f') - call h5tcopy_f(H5T_NATIVE_DOUBLE, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tcopy_f') - call h5tset_size_f(type_id, 8_HSIZE_T, hdferr) ! ToDo - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tset_size_f') - call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5aexists_by_name_f') - if (attrExists) then - call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5adelete_by_name_f') - endif - call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5acreate_f') - call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5awrite_f') - call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5aclose_f') - call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tclose_f') - call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5sclose_f') - -end subroutine HDF5_addAttribute_pReal +end subroutine HDF5_addAttribute_real !-------------------------------------------------------------------------------------------------- !> @brief set link to object in results file !-------------------------------------------------------------------------------------------------- subroutine HDF5_setLink(loc_id,target_name,link_name) - use hdf5 - implicit none - character(len=*), intent(in) :: target_name, link_name + implicit none + character(len=*), intent(in) :: target_name, link_name integer(HID_T), intent(in) :: loc_id - integer :: hdferr - logical :: linkExists - - call h5lexists_f(loc_id, link_name,linkExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link_name)//')') - if (linkExists) then - call h5ldelete_f(loc_id,link_name, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link_name)//')') - endif - call h5lcreate_soft_f(target_name, loc_id, link_name, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(target_name)//' '//trim(link_name)//')') + integer :: hdferr + logical :: linkExists + + call h5lexists_f(loc_id, link_name,linkExists, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link_name)//')') + if (linkExists) then + call h5ldelete_f(loc_id,link_name, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link_name)//')') + endif + call h5lcreate_soft_f(target_name, loc_id, link_name, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(target_name)//' '//trim(link_name)//')') end subroutine HDF5_setLink @@ -454,583 +457,583 @@ end subroutine HDF5_setLink !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal1(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_real1(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & ! ToDo: Fortran 2018 size(shape(A)) = rank(A) - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr - -!--------------------------------------------------------------------------------------------------- -! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - -!--------------------------------------------------------------------------------------------------- -! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif - - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal1: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pReal1 - -!-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 2 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal2(loc_id,dataset,datasetName,parallel) - - implicit none - real(pReal), intent(inout), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr - -!--------------------------------------------------------------------------------------------------- -! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - -!--------------------------------------------------------------------------------------------------- -! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif - - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal2: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pReal2 - -!-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 2 dimensions -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal3(loc_id,dataset,datasetName,parallel) - - implicit none - real(pReal), intent(inout), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr - -!--------------------------------------------------------------------------------------------------- -! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - -!--------------------------------------------------------------------------------------------------- -! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + implicit none + real(pReal), intent(inout), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal3: h5dread_f') + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & ! ToDo: Fortran 2018 size(shape(A)) = rank(A) + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) +!--------------------------------------------------------------------------------------------------- +! determine shape of dataset + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) -end subroutine HDF5_read_pReal3 +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real1: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + +end subroutine HDF5_read_real1 + +!-------------------------------------------------------------------------------------------------- +!> @brief read dataset of type pReal with 2 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_real2(loc_id,dataset,datasetName,parallel) + + implicit none + real(pReal), intent(inout), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr + +!--------------------------------------------------------------------------------------------------- +! determine shape of dataset + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real2: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + +end subroutine HDF5_read_real2 + +!-------------------------------------------------------------------------------------------------- +!> @brief read dataset of type pReal with 2 dimensions +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_read_real3(loc_id,dataset,datasetName,parallel) + + implicit none + real(pReal), intent(inout), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr + +!--------------------------------------------------------------------------------------------------- +! determine shape of dataset + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + +!--------------------------------------------------------------------------------------------------- +! initialize HDF5 data structures + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real3: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + +end subroutine HDF5_read_real3 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal4(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_real4(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + implicit none + real(pReal), intent(inout), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real4: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal4: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pReal4 +end subroutine HDF5_read_real4 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal5(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_real5(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + implicit none + real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real5: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal5: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pReal5 +end subroutine HDF5_read_real5 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal6(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_real6(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + implicit none + real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal6: h5dread_f') + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real6: h5dread_f') - 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) -end subroutine HDF5_read_pReal6 +end subroutine HDF5_read_real6 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pReal7(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_real7(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + implicit none + real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real7: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pReal7: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pReal7 +end subroutine HDF5_read_real7 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 1 dimension !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt1(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int1(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + implicit none + integer, intent(inout), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt1: h5dread_f') + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int1: h5dread_f') - 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) -end subroutine HDF5_read_pInt1 +end subroutine HDF5_read_int1 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt2(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int2(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + implicit none + integer, intent(inout), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif - - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt2: h5dread_f') + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int2: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) -end subroutine HDF5_read_pInt2 +end subroutine HDF5_read_int2 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt3(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int3(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + implicit none + integer, intent(inout), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + endif + + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int3: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt3: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pInt3 +end subroutine HDF5_read_int3 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt withh 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt4(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int4(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + implicit none + integer, intent(inout), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int4: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt4: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pInt4 +end subroutine HDF5_read_int4 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt5(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int5(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + implicit none + integer, intent(inout), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt5: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int5: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) -end subroutine HDF5_read_pInt5 +end subroutine HDF5_read_int5 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt6(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int6(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + implicit none + integer, intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int6: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt6: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pInt6 +end subroutine HDF5_read_int6 !-------------------------------------------------------------------------------------------------- !> @brief read dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_read_pInt7(loc_id,dataset,datasetName,parallel) +subroutine HDF5_read_int7(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel - - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer :: hdferr + implicit none + integer, intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer :: hdferr !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) !--------------------------------------------------------------------------------------------------- ! initialize HDF5 data structures - if (present(parallel)) then - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,parallel) - else - call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & - myStart, totalShape, loc_id,myShape,datasetName,.false.) - endif + if (present(parallel)) then + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,parallel) + else + call initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id, & + myStart, totalShape, loc_id,myShape,datasetName,.false.) + endif + + call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& + file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int7: h5dread_f') + + call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& - file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_pInt7: h5dread_f') - - call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - -end subroutine HDF5_read_pInt7 +end subroutine HDF5_read_int7 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 1 dimension !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real1(loc_id,dataset,datasetName,parallel) implicit none real(pReal), intent(inout), dimension(:) :: dataset @@ -1059,19 +1062,20 @@ subroutine HDF5_write_pReal1(loc_id,dataset,datasetName,parallel) myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal1: h5dwrite_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real1: h5dwrite_f') + endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pReal1 +end subroutine HDF5_write_real1 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real2(loc_id,dataset,datasetName,parallel) implicit none real(pReal), intent(inout), dimension(:,:) :: dataset @@ -1100,19 +1104,20 @@ subroutine HDF5_write_pReal2(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal2: h5dwrite_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real2: h5dwrite_f') + endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pReal2 +end subroutine HDF5_write_real2 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real3(loc_id,dataset,datasetName,parallel) implicit none real(pReal), intent(inout), dimension(:,:,:) :: dataset @@ -1141,19 +1146,20 @@ subroutine HDF5_write_pReal3(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal3: h5dwrite_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real3: h5dwrite_f') + endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pReal3 +end subroutine HDF5_write_real3 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real4(loc_id,dataset,datasetName,parallel) implicit none real(pReal), intent(inout), dimension(:,:,:,:) :: dataset @@ -1182,20 +1188,21 @@ subroutine HDF5_write_pReal4(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal4: h5dwrite_f') - + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real4: h5dwrite_f') + endif + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pReal4 +end subroutine HDF5_write_real4 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real5(loc_id,dataset,datasetName,parallel) implicit none real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset @@ -1224,19 +1231,20 @@ subroutine HDF5_write_pReal5(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal5: h5dwrite_f') - + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real5: h5dwrite_f') + endif + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pReal5 +end subroutine HDF5_write_real5 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real6(loc_id,dataset,datasetName,parallel) implicit none real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset @@ -1265,19 +1273,20 @@ subroutine HDF5_write_pReal6(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal6: h5dwrite_f') - + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real6: h5dwrite_f') + endif + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pReal6 +end subroutine HDF5_write_real6 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pReal with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_real7(loc_id,dataset,datasetName,parallel) implicit none real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset @@ -1306,20 +1315,21 @@ subroutine HDF5_write_pReal7(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pReal7: h5dwrite_f') - + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real7: h5dwrite_f') + endif + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pReal7 +end subroutine HDF5_write_real7 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 1 dimension !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int1(loc_id,dataset,datasetName,parallel) implicit none integer, intent(inout), dimension(:) :: dataset @@ -1348,19 +1358,20 @@ subroutine HDF5_write_pInt1(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt1: h5dwrite_f') - + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int1: h5dwrite_f') + endif + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt1 +end subroutine HDF5_write_int1 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 2 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int2(loc_id,dataset,datasetName,parallel) implicit none integer, intent(inout), dimension(:,:) :: dataset @@ -1389,19 +1400,20 @@ subroutine HDF5_write_pInt2(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt2: h5dwrite_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int2: h5dwrite_f') + endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt2 +end subroutine HDF5_write_int2 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 3 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int3(loc_id,dataset,datasetName,parallel) implicit none integer, intent(inout), dimension(:,:,:) :: dataset @@ -1430,19 +1442,20 @@ subroutine HDF5_write_pInt3(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt3: h5dwrite_f') - + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int3: h5dwrite_f') + endif + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt3 +end subroutine HDF5_write_int3 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 4 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int4(loc_id,dataset,datasetName,parallel) implicit none integer, intent(inout), dimension(:,:,:,:) :: dataset @@ -1471,19 +1484,20 @@ subroutine HDF5_write_pInt4(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt4: h5dwrite_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int4: h5dwrite_f') + endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt4 +end subroutine HDF5_write_int4 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 5 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int5(loc_id,dataset,datasetName,parallel) implicit none integer, intent(inout), dimension(:,:,:,:,:) :: dataset @@ -1512,19 +1526,20 @@ subroutine HDF5_write_pInt5(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt5: h5dwrite_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int5: h5dwrite_f') + endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt5 +end subroutine HDF5_write_int5 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 6 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int6(loc_id,dataset,datasetName,parallel) implicit none integer, intent(inout), dimension(:,:,:,:,:,:) :: dataset @@ -1553,19 +1568,20 @@ subroutine HDF5_write_pInt6(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt6: h5dwrite_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int6: h5dwrite_f') + endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt6 +end subroutine HDF5_write_int6 !-------------------------------------------------------------------------------------------------- !> @brief write dataset of type pInt with 7 dimensions !-------------------------------------------------------------------------------------------------- -subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) +subroutine HDF5_write_int7(loc_id,dataset,datasetName,parallel) implicit none integer, intent(inout), dimension(:,:,:,:,:,:,:) :: dataset @@ -1594,14 +1610,15 @@ subroutine HDF5_write_pInt7(loc_id,dataset,datasetName,parallel) myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) endif - if (product(totalShape) /= 0) & - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_pInt7: h5dwrite_f') + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int7: h5dwrite_f') + endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) -end subroutine HDF5_write_pInt7 +end subroutine HDF5_write_int7 !-------------------------------------------------------------------------------------------------- diff --git a/src/results.f90 b/src/results.f90 index cd4a15cef..d818e50fa 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -5,9 +5,6 @@ !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !-------------------------------------------------------------------------------------------------- module results - use prec - use IO - use HDF5 use HDF5_utilities #ifdef PETSc use PETSC @@ -18,13 +15,13 @@ module results integer(HID_T), public, protected :: tempCoordinates, tempResults integer(HID_T), private :: resultsFile, currentIncID, plist_id - interface results_writeDataset - module procedure results_writeTensorDataset_real - module procedure results_writeTensorDataset_int - module procedure results_writeVectorDataset_real - module procedure results_writeVectorDataset_int - module procedure results_writeScalarDataset_real - end interface results_writeDataset + interface results_writeDataset + module procedure results_writeTensorDataset_real + module procedure results_writeTensorDataset_int + module procedure results_writeVectorDataset_real + module procedure results_writeVectorDataset_int + module procedure results_writeScalarDataset_real + end interface results_writeDataset public :: & results_init, & @@ -67,12 +64,12 @@ end subroutine results_init !> @brief opens the results file to append data !-------------------------------------------------------------------------------------------------- subroutine results_openJobFile - use DAMASK_interface, only: & - getSolverJobName + use DAMASK_interface, only: & + getSolverJobName - implicit none + implicit none - resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','a',.true.) + resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','a',.true.) end subroutine results_openJobFile @@ -81,9 +78,9 @@ end subroutine results_openJobFile !> @brief closes the results file !-------------------------------------------------------------------------------------------------- subroutine results_closeJobFile - implicit none + implicit none - call HDF5_closeFile(resultsFile) + call HDF5_closeFile(resultsFile) end subroutine results_closeJobFile @@ -93,15 +90,15 @@ end subroutine results_closeJobFile !-------------------------------------------------------------------------------------------------- subroutine results_addIncrement(inc,time) - implicit none - integer(pInt), intent(in) :: inc - real(pReal), intent(in) :: time - character(len=pStringLen) :: incChar + implicit none + integer(pInt), intent(in) :: inc + real(pReal), intent(in) :: time + character(len=pStringLen) :: incChar - write(incChar,'(i5.5)') inc ! allow up to 99999 increments - call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) - call results_setLink(trim('inc'//trim(adjustl(incChar))),'current') - call HDF5_addAttribute(resultsFile,'time/s',time,trim('inc'//trim(adjustl(incChar)))) + write(incChar,'(i5.5)') inc ! allow up to 99999 increments + call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) + call results_setLink(trim('inc'//trim(adjustl(incChar))),'current') + call HDF5_addAttribute(resultsFile,'time/s',time,trim('inc'//trim(adjustl(incChar)))) end subroutine results_addIncrement @@ -110,10 +107,10 @@ end subroutine results_addIncrement !-------------------------------------------------------------------------------------------------- integer(HID_T) function results_openGroup(groupName) - implicit none - character(len=*), intent(in) :: groupName - - results_openGroup = HDF5_openGroup(resultsFile,groupName) + implicit none + character(len=*), intent(in) :: groupName + + results_openGroup = HDF5_openGroup(resultsFile,groupName) end function results_openGroup @@ -123,10 +120,10 @@ end function results_openGroup !-------------------------------------------------------------------------------------------------- integer(HID_T) function results_addGroup(groupName) - implicit none - character(len=*), intent(in) :: groupName - - results_addGroup = HDF5_addGroup(resultsFile,groupName) + implicit none + character(len=*), intent(in) :: groupName + + results_addGroup = HDF5_addGroup(resultsFile,groupName) end function results_addGroup @@ -135,13 +132,11 @@ end function results_addGroup !> @brief set link to object in results file !-------------------------------------------------------------------------------------------------- subroutine results_setLink(path,link) - use hdf5_utilities, only: & - HDF5_setLink - implicit none - character(len=*), intent(in) :: path, link + implicit none + character(len=*), intent(in) :: path, link - call HDF5_setLink(resultsFile,path,link) + call HDF5_setLink(resultsFile,path,link) end subroutine results_setLink @@ -151,10 +146,10 @@ end subroutine results_setLink !-------------------------------------------------------------------------------------------------- subroutine results_addAttribute(attrLabel,attrValue,path) - implicit none - character(len=*), intent(in) :: attrLabel, attrValue, path + implicit none + character(len=*), intent(in) :: attrLabel, attrValue, path - call HDF5_addAttribute_str(resultsFile,attrLabel, attrValue, path) + call HDF5_addAttribute_str(resultsFile,attrLabel, attrValue, path) end subroutine results_addAttribute @@ -163,14 +158,13 @@ end subroutine results_addAttribute !> @brief remove link to an object !-------------------------------------------------------------------------------------------------- subroutine results_removeLink(link) - use hdf5 - implicit none - character(len=*), intent(in) :: link - integer :: hdferr + implicit none + character(len=*), intent(in) :: link + integer :: hdferr - call h5ldelete_f(resultsFile,link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'results_removeLink: h5ldelete_soft_f ('//trim(link)//')') + call h5ldelete_f(resultsFile,link, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'results_removeLink: h5ldelete_soft_f ('//trim(link)//')') end subroutine results_removeLink @@ -313,7 +307,6 @@ end subroutine results_writeTensorDataset_int !> @brief adds the unique mapping from spatial position and constituent ID to results !-------------------------------------------------------------------------------------------------- subroutine HDF5_mappingPhase(mapping,mapping2,Nconstituents,material_phase,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) - use hdf5 implicit none integer(pInt), intent(in) :: Nconstituents, dataspace_size, mpiOffset From 953acf9c7130a35fb12965b7466c7e6f129d243a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 4 Apr 2019 13:25:29 +0200 Subject: [PATCH 07/97] introducing new mappings --- src/material.f90 | 63 +- src/results.f90 | 1598 +++++++++++++++++++++++----------------------- 2 files changed, 844 insertions(+), 817 deletions(-) diff --git a/src/material.f90 b/src/material.f90 index d35cfebd4..a4fc78350 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -147,16 +147,14 @@ module material damage_initialPhi !< initial damage per each homogenization ! NEW MAPPINGS - integer(pInt), dimension(:), allocatable, public, protected :: & - material_homogenizationAt, & !< homogenization ID of each element (copy of mesh_homogenizationAt) - material_homogenizationMemberAt, & !< position of the element within its homogenization instance - material_aggregateAt, & !< aggregate ID of each element FUTURE USE FOR OUTPUT - material_aggregatMemberAt !< position of the element within its aggregate instance FUTURE USE FOR OUTPUT - integer(pInt), dimension(:,:), allocatable, public, protected :: & - material_phaseAt, & !< phase ID of each element - material_phaseMemberAt, & !< position of the element within its phase instance - material_crystalliteAt, & !< crystallite ID of each element CURRENTLY NOT PER CONSTITUTENT - material_crystalliteMemberAt !< position of the element within its crystallite instance CURRENTLY NOT PER CONSTITUTENT + integer, dimension(:), allocatable, public, protected :: & ! (elem) + material_homogenizationAt !< homogenization ID of each element (copy of mesh_homogenizationAt) + integer, dimension(:,:), allocatable, public, protected :: & ! (ip,elem) + material_homogenizationMemberAt !< position of the element within its homogenization instance + integer, dimension(:,:), allocatable, public, protected :: & ! (constituent,elem) + material_phaseAt !< phase ID of each element + integer, dimension(:,:,:), allocatable, public, protected :: & ! (constituent,ip,elem) + material_phaseMemberAt !< position of the element within its phase instance ! END NEW MAPPINGS ! DEPRECATED: use material_phaseAt @@ -275,7 +273,7 @@ contains !> @details figures out if solverJobName.materialConfig is present, if not looks for !> material.config !-------------------------------------------------------------------------------------------------- -subroutine material_init() +subroutine material_init use IO, only: & IO_error use debug, only: & @@ -382,21 +380,50 @@ subroutine material_init() endif debugOut call material_populateGrains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! new mappings + allocate(material_homogenizationAt,source=theMesh%homogenizationAt) + allocate(material_homogenizationMemberAt(theMesh%elem%nIPs,theMesh%Nelems),source=0) + allocate(CounterHomogenization(size(config_homogenization)),source=0) + do e = 1, theMesh%Nelems + do i = 1, theMesh%elem%nIPs + CounterHomogenization(material_homogenizationAt(e)) = & + CounterHomogenization(material_homogenizationAt(e)) + 1 + material_homogenizationMemberAt(i,e) = CounterHomogenization(material_homogenizationAt(e)) + enddo + enddo + + + allocate(material_phaseAt(homogenization_maxNgrains,theMesh%Nelems), source=material_phase(:,1,:)) + allocate(material_phaseMemberAt(homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0) + + allocate(CounterPhase(size(config_phase)),source=0) + do e = 1, theMesh%Nelems + do i = 1, theMesh%elem%nIPs + do c = 1, homogenization_maxNgrains + CounterPhase(material_phaseAt(c,e)) = & + CounterPhase(material_phaseAt(c,e)) + 1 + material_phaseMemberAt(c,i,e) = CounterPhase(material_phaseAt(c,e)) + enddo + enddo + enddo + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! BEGIN DEPRECATED allocate(phaseAt ( homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0_pInt) allocate(phasememberAt ( homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0_pInt) allocate(mappingHomogenization (2, theMesh%elem%nIPs,theMesh%Nelems),source=0_pInt) allocate(mappingHomogenizationConst( theMesh%elem%nIPs,theMesh%Nelems),source=1_pInt) -! END DEPRECATED - - allocate(material_homogenizationAt,source=theMesh%homogenizationAt) - allocate(material_AggregateAt, source=theMesh%homogenizationAt) - allocate(CounterPhase (size(config_phase)), source=0_pInt) - allocate(CounterHomogenization(size(config_homogenization)),source=0_pInt) + CounterHomogenization=0 + CounterPhase =0 + -! BEGIN DEPRECATED do e = 1_pInt,theMesh%Nelems myHomog = theMesh%homogenizationAt(e) do i = 1_pInt, theMesh%elem%nIPs diff --git a/src/results.f90 b/src/results.f90 index d818e50fa..4af545f54 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -303,805 +303,805 @@ subroutine results_writeTensorDataset_int(group,dataset,label,description,SIunit end subroutine results_writeTensorDataset_int -!-------------------------------------------------------------------------------------------------- -!> @brief adds the unique mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingPhase(mapping,mapping2,Nconstituents,material_phase,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) - - implicit none - integer(pInt), intent(in) :: Nconstituents, dataspace_size, mpiOffset - integer(pInt), intent(in), dimension(:) :: mapping, mapping2 - character(len=*), intent(in), dimension(:) :: phase_name - integer(pInt), intent(in), dimension(:) :: mpiOffset_phase - integer(pInt), intent(in), dimension(:,:,:) :: material_phase - - character(len=len(phase_name(1))), dimension(:), allocatable :: namesNA - character(len=len(phase_name(1))) :: a - character(len=*), parameter :: n = "NULL" - - integer(pInt) :: hdferr, NmatPoints, i, j, k - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace - integer(HID_T) :: dt5_id ! Memory datatype identifier - integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - - integer(HSIZE_T), dimension(2) :: counter - integer(HSSIZE_T), dimension(2) :: fileOffset - integer(pInt), dimension(:,:), allocatable :: arrOffset - - a = n - allocate(namesNA(0:size(phase_name)),source=[a,phase_name]) - NmatPoints = size(mapping,1)/Nconstituents - mapping_ID = results_openGroup("current/mapGeometry") - - allocate(arrOffset(Nconstituents,NmatPoints)) - do i=1_pInt, NmatPoints - do k=1_pInt, Nconstituents - do j=1_pInt, size(phase_name) - if(material_phase(k,1,i) == j) & - arrOffset(k,i) = mpiOffset_phase(j) - enddo - enddo - enddo - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(2, int([Nconstituents,dataspace_size],HSIZE_T), space_id, hdferr, & - int([Nconstituents,dataspace_size],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') - -!-------------------------------------------------------------------------------------------------- -! compound type - ! First calculate total size by calculating sizes of each member - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) - typesize = len(phase_name(1)) - CALL h5tset_size_f(dt5_id, typesize, hdferr) - CALL h5tget_size_f(dt5_id, type_sizec, hdferr) - CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) - type_size = type_sizec + type_sizei - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 0') - call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 2') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, 'constitutive', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase') - -!-------------------------------------------------------------------------------------------------- -! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f instance_id') - call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f instance_id') - - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- -! Define and select hyperslabs - counter(1) = Nconstituents ! how big i am - counter(2) = NmatPoints - fileOffset(1) = 0 ! where i start to write my data - fileOffset(2) = mpiOffset - - call h5screate_simple_f(2, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, name_id, reshape(namesNA(mapping),[Nconstituents,NmatPoints]), & - int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f position_id') - - call h5dwrite_f(dset_id, position_id, reshape(mapping2-1_pInt,[Nconstituents,NmatPoints])+arrOffset, & - int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & - file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- -! close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f position_id') - call h5tclose_f(name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f name_id ') - call h5tclose_f(dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dt5_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingPhase - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the backward mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_backwardMappingPhase(material_phase,phasememberat,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:,:) :: material_phase, phasememberat - character(len=*), intent(in), dimension(:) :: phase_name - integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_phase - integer(pInt), intent(in) :: mpiOffset - - integer(pInt) :: hdferr, NmatPoints, Nconstituents, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace - integer(SIZE_T) :: type_size - - integer(pInt), dimension(:,:), allocatable :: arr - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - - character(len=64) :: phaseID - - Nconstituents = size(phasememberat,1) - NmatPoints = count(material_phase /=0_pInt)/Nconstituents - - allocate(arr(2,NmatPoints*Nconstituents)) - - do i=1_pInt, NmatPoints - do j=Nconstituents-1_pInt, 0_pInt, -1_pInt - arr(1,Nconstituents*i-j) = i-1_pInt - enddo - enddo - arr(2,:) = pack(material_phase,material_phase/=0_pInt) - - do i=1_pInt, size(phase_name) - write(phaseID, '(i0)') i - mapping_ID = results_openGroup('/current/constitutive/'//trim(phaseID)//'_'//phase_name(i)) - NmatPoints = count(material_phase == i) - -!-------------------------------------------------------------------------------------------------- - ! create dataspace - call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & - int([dataspace_size(i)],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') - -!-------------------------------------------------------------------------------------------------- - ! compound type - call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f 0') - -!-------------------------------------------------------------------------------------------------- - ! create Dataset - call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase') - -!-------------------------------------------------------------------------------------------------- - ! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- - ! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset_phase(i) ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- - ! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset, int([dataspace_size(i)],HSIZE_T),& - hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- - !close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f position_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - - enddo - -end subroutine HDF5_backwardMappingPhase - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the unique mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat - character(len=*), intent(in), dimension(:) :: homogenization_name - integer(pInt), intent(in), dimension(:) :: mpiOffset_homog - integer(pInt), intent(in) :: dataspace_size, mpiOffset - - integer(pInt) :: hdferr, NmatPoints, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace - - integer(HID_T) :: dt5_id ! Memory datatype identifier - integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - integer(pInt), dimension(:), allocatable :: arrOffset - - NmatPoints = count(material_homog /=0_pInt) - mapping_ID = results_openGroup("current/mapGeometry") - - allocate(arrOffset(NmatPoints)) - do i=1_pInt, NmatPoints - do j=1_pInt, size(homogenization_name) - if(material_homog(1,i) == j) & - arrOffset(i) = mpiOffset_homog(j) - enddo - enddo - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & - int([dataspace_size],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') - -!-------------------------------------------------------------------------------------------------- -! compound type - ! First calculate total size by calculating sizes of each member - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) - typesize = len(homogenization_name(1)) - CALL h5tset_size_f(dt5_id, typesize, hdferr) - CALL h5tget_size_f(dt5_id, type_sizec, hdferr) - CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) - type_size = type_sizec + type_sizei - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 0') - call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 2') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, 'homogenization', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog') - -!-------------------------------------------------------------------------------------------------- -! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f instance_id') - call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f instance_id') - - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- -! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- -! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, name_id, homogenization_name(pack(material_homog,material_homog/=0_pInt)), & - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f position_id') - - call h5dwrite_f(dset_id, position_id, pack(homogmemberat-1_pInt,homogmemberat/=0_pInt) + arrOffset, & - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces -call h5tclose_f(dtype_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dtype_id') -call h5tclose_f(position_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f position_id') -call h5tclose_f(name_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f name_id ') -call h5tclose_f(dt5_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dt5_id') -call h5dclose_f(dset_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dclose_f') -call h5sclose_f(space_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f space_id') -call h5sclose_f(memspace, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f memspace') -call h5pclose_f(plist_id, hdferr) -if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pclose_f') -call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingHomog - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the backward mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_backwardMappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat - character(len=*), intent(in), dimension(:) :: homogenization_name - integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_homog - integer(pInt), intent(in) :: mpiOffset - - integer(pInt) :: hdferr, NmatPoints, i - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace - integer(SIZE_T) :: type_size - - integer(pInt), dimension(:,:), allocatable :: arr - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - - character(len=64) :: homogID - - NmatPoints = count(material_homog /=0_pInt) - allocate(arr(2,NmatPoints)) - - arr(1,:) = (/(i, i=0_pint,NmatPoints-1_pInt)/) - arr(2,:) = pack(material_homog,material_homog/=0_pInt) - - do i=1_pInt, size(homogenization_name) - write(homogID, '(i0)') i - mapping_ID = results_openGroup('/current/homogenization/'//trim(homogID)//'_'//homogenization_name(i)) - -!-------------------------------------------------------------------------------------------------- - ! create dataspace - call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & - int([dataspace_size(i)],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') - -!-------------------------------------------------------------------------------------------------- - ! compound type - call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f 0') - -!-------------------------------------------------------------------------------------------------- - ! create Dataset - call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog') - -!-------------------------------------------------------------------------------------------------- - ! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- - ! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset_homog(i) ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- - ! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset,int([dataspace_size(i)],HSIZE_T),& - hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- - !close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f position_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - - enddo - -end subroutine HDF5_backwardMappingHomog - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the unique mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: crystalliteAt - integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt - character(len=*), intent(in), dimension(:) :: crystallite_name - integer(pInt), intent(in), dimension(:) :: mpiOffset_cryst - integer(pInt), intent(in) :: dataspace_size, mpiOffset - - integer :: hdferr - integer(pInt) :: NmatPoints, Nconstituents, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, plist_id, memspace - - integer(HID_T), dimension(:), allocatable :: position_id - - integer(HID_T) :: dt5_id ! Memory datatype identifier - integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - integer(pInt), dimension(:), allocatable :: arrOffset - - character(len=64) :: m - - Nconstituents = size(crystmemberAt,1) - NmatPoints = count(crystalliteAt /=0_pInt) - mapping_ID = results_openGroup("current/mapGeometry") - - allocate(position_id(Nconstituents)) - - allocate(arrOffset(NmatPoints)) - do i=1_pInt, NmatPoints - do j=1_pInt, size(crystallite_name) - if(crystalliteAt(1,i) == j) & - arrOffset(i) = Nconstituents*mpiOffset_cryst(j) - enddo - enddo - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & - int([dataspace_size],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') - -!-------------------------------------------------------------------------------------------------- -! compound type - ! First calculate total size by calculating sizes of each member - ! - CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) - typesize = len(crystallite_name(1)) - CALL h5tset_size_f(dt5_id, typesize, hdferr) - CALL h5tget_size_f(dt5_id, type_sizec, hdferr) - CALL h5tget_size_f(H5T_STD_I32LE, type_sizei, hdferr) - type_size = type_sizec + type_sizei*Nconstituents - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 0') - do i=1_pInt, Nconstituents - write(m, '(i0)') i - call h5tinsert_f(dtype_id, "Position "//trim(m), type_sizec+(i-1)*type_sizei, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 2 '//trim(m)) - enddo - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, 'crystallite', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite') - -!-------------------------------------------------------------------------------------------------- -! Create memory types (one compound datatype for each member) - call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f instance_id') - call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f instance_id') - - do i=1_pInt, Nconstituents - write(m, '(i0)') i - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id(i), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f position_id') - call h5tinsert_f(position_id(i), "Position "//trim(m), 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f position_id') - enddo - -!-------------------------------------------------------------------------------------------------- -! Define and select hyperslabs - counter = NmatPoints ! how big i am - fileOffset = mpiOffset ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, name_id, crystallite_name(pack(crystalliteAt,crystalliteAt/=0_pInt)), & - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f position_id') - - do i=1_pInt, Nconstituents - call h5dwrite_f(dset_id, position_id(i), pack(crystmemberAt(i,:,:)-1_pInt,crystmemberAt(i,:,:)/=0_pInt)+arrOffset,& - int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f instance_id') - enddo - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dtype_id') - do i=1_pInt, Nconstituents - call h5tclose_f(position_id(i), hdferr) - enddo - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f position_id') - call h5tclose_f(name_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f name_id') - call h5tclose_f(dt5_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dt5_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingCrystallite - - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the backward mapping from spatial position and constituent ID to results -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_backwardMappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:,:) :: crystalliteAt - integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt - character(len=*), intent(in), dimension(:) :: crystallite_name - integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_cryst - integer(pInt), intent(in) :: mpiOffset - - integer :: hdferr - integer(pInt) :: NmatPoints, Nconstituents, i, j - integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace - integer(SIZE_T) :: type_size - - integer(pInt), dimension(:,:), allocatable :: h_arr, arr - - integer(HSIZE_T), dimension(1) :: counter - integer(HSSIZE_T), dimension(1) :: fileOffset - - character(len=64) :: crystallID - - Nconstituents = size(crystmemberAt,1) - NmatPoints = count(crystalliteAt /=0_pInt) - - allocate(h_arr(2,NmatPoints)) - allocate(arr(2,Nconstituents*NmatPoints)) - - h_arr(1,:) = (/(i, i=0_pInt,NmatPoints-1_pInt)/) - h_arr(2,:) = pack(crystalliteAt,crystalliteAt/=0_pInt) - - do i=1_pInt, NmatPoints - do j=Nconstituents-1_pInt, 0_pInt, -1_pInt - arr(1,Nconstituents*i-j) = h_arr(1,i) - arr(2,Nconstituents*i-j) = h_arr(2,i) - enddo - enddo - - do i=1_pInt, size(crystallite_name) - if (crystallite_name(i) == 'none') cycle - write(crystallID, '(i0)') i - mapping_ID = results_openGroup('/current/crystallite/'//trim(crystallID)//'_'//crystallite_name(i)) - NmatPoints = count(crystalliteAt == i) - -!-------------------------------------------------------------------------------------------------- - ! create dataspace - call h5screate_simple_f(1, int([Nconstituents*dataspace_size(i)],HSIZE_T), space_id, hdferr, & - int([Nconstituents*dataspace_size(i)],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') - -!-------------------------------------------------------------------------------------------------- - ! compound type - call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) - call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') - - call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f 0') - -!-------------------------------------------------------------------------------------------------- - ! create Dataset - call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite') - -!-------------------------------------------------------------------------------------------------- - ! Create memory types - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tcreate_f position_id') - call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f position_id') - -!-------------------------------------------------------------------------------------------------- - ! Define and select hyperslabs - counter = Nconstituents*NmatPoints ! how big i am - fileOffset = Nconstituents*mpiOffset_cryst(i) ! where i start to write my data - - call h5screate_simple_f(1, counter, memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5screate_simple_f') - call h5dget_space_f(dset_id, space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dget_space_f') - call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sselect_hyperslab_f') - -!-------------------------------------------------------------------------------------------------- - ! Create property list for collective dataset write -#ifdef PETSc - call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pcreate_f') - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pset_dxpl_mpio_f') -#endif - -!-------------------------------------------------------------------------------------------------- - ! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i) + mpiOffset,& - int([Nconstituents*dataspace_size(i)],HSIZE_T), hdferr, file_space_id = space_id, & - mem_space_id = memspace, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- - !close types, dataspaces - call h5tclose_f(dtype_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f dtype_id') - call h5tclose_f(position_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f position_id') - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f space_id') - call h5sclose_f(memspace, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f memspace') - call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pclose_f') - call HDF5_closeGroup(mapping_ID) - - enddo - -end subroutine HDF5_backwardMappingCrystallite - -!-------------------------------------------------------------------------------------------------- -!> @brief adds the unique cell to node mapping -!-------------------------------------------------------------------------------------------------- -subroutine HDF5_mappingCells(mapping) - use hdf5 - - implicit none - integer(pInt), intent(in), dimension(:) :: mapping - - integer :: hdferr, Nnodes - integer(HID_T) :: mapping_id, dset_id, space_id - - Nnodes=size(mapping) - mapping_ID = results_openGroup("mapping") - -!-------------------------------------------------------------------------------------------------- -! create dataspace - call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, & - int([Nnodes],HSIZE_T)) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5screate_simple_f') - -!-------------------------------------------------------------------------------------------------- -! create Dataset - call h5dcreate_f(mapping_id, "Cell",H5T_NATIVE_INTEGER, space_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells') - -!-------------------------------------------------------------------------------------------------- -! write data by fields in the datatype. Fields order is not important. - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, mapping, int([Nnodes],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5dwrite_f instance_id') - -!-------------------------------------------------------------------------------------------------- -!close types, dataspaces - call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5dclose_f') - call h5sclose_f(space_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5sclose_f') - call HDF5_closeGroup(mapping_ID) - -end subroutine HDF5_mappingCells +!!-------------------------------------------------------------------------------------------------- +!!> @brief adds the unique mapping from spatial position and constituent ID to results +!!-------------------------------------------------------------------------------------------------- +!subroutine HDF5_mappingPhase(mapping,mapping2,Nconstituents,material_phase,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) + +! implicit none +! integer(pInt), intent(in) :: Nconstituents, dataspace_size, mpiOffset +! integer(pInt), intent(in), dimension(:) :: mapping, mapping2 +! character(len=*), intent(in), dimension(:) :: phase_name +! integer(pInt), intent(in), dimension(:) :: mpiOffset_phase +! integer(pInt), intent(in), dimension(:,:,:) :: material_phase + +! character(len=len(phase_name(1))), dimension(:), allocatable :: namesNA +! character(len=len(phase_name(1))) :: a +! character(len=*), parameter :: n = "NULL" + +! integer(pInt) :: hdferr, NmatPoints, i, j, k +! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace +! integer(HID_T) :: dt5_id ! Memory datatype identifier +! integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size + +! integer(HSIZE_T), dimension(2) :: counter +! integer(HSSIZE_T), dimension(2) :: fileOffset +! integer(pInt), dimension(:,:), allocatable :: arrOffset + +! a = n +! allocate(namesNA(0:size(phase_name)),source=[a,phase_name]) +! NmatPoints = size(mapping,1)/Nconstituents +! mapping_ID = results_openGroup("current/mapGeometry") + +! allocate(arrOffset(Nconstituents,NmatPoints)) +! do i=1_pInt, NmatPoints +! do k=1_pInt, Nconstituents +! do j=1_pInt, size(phase_name) +! if(material_phase(k,1,i) == j) & +! arrOffset(k,i) = mpiOffset_phase(j) +! enddo +! enddo +! enddo + +!!-------------------------------------------------------------------------------------------------- +!! create dataspace +! call h5screate_simple_f(2, int([Nconstituents,dataspace_size],HSIZE_T), space_id, hdferr, & +! int([Nconstituents,dataspace_size],HSIZE_T)) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') + +!!-------------------------------------------------------------------------------------------------- +!! compound type +! ! First calculate total size by calculating sizes of each member +! ! +! CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) +! typesize = len(phase_name(1)) +! CALL h5tset_size_f(dt5_id, typesize, hdferr) +! CALL h5tget_size_f(dt5_id, type_sizec, hdferr) +! CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) +! type_size = type_sizec + type_sizei +! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') + +! call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 0') +! call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 2') + +!!-------------------------------------------------------------------------------------------------- +!! create Dataset +! call h5dcreate_f(mapping_id, 'constitutive', dtype_id, space_id, dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase') + +!!-------------------------------------------------------------------------------------------------- +!! Create memory types (one compound datatype for each member) +! call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f instance_id') +! call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f instance_id') + +! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f position_id') +! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f position_id') + +!!-------------------------------------------------------------------------------------------------- +!! Define and select hyperslabs +! counter(1) = Nconstituents ! how big i am +! counter(2) = NmatPoints +! fileOffset(1) = 0 ! where i start to write my data +! fileOffset(2) = mpiOffset + +! call h5screate_simple_f(2, counter, memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5screate_simple_f') +! call h5dget_space_f(dset_id, space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dget_space_f') +! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sselect_hyperslab_f') + +!!-------------------------------------------------------------------------------------------------- +! ! Create property list for collective dataset write +!#ifdef PETSc +! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pcreate_f') +! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pset_dxpl_mpio_f') +!#endif + +!!-------------------------------------------------------------------------------------------------- +!! write data by fields in the datatype. Fields order is not important. +! call h5dwrite_f(dset_id, name_id, reshape(namesNA(mapping),[Nconstituents,NmatPoints]), & +! int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & +! file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f position_id') + +! call h5dwrite_f(dset_id, position_id, reshape(mapping2-1_pInt,[Nconstituents,NmatPoints])+arrOffset, & +! int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & +! file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f instance_id') + +!!-------------------------------------------------------------------------------------------------- +!! close types, dataspaces +! call h5tclose_f(dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dtype_id') +! call h5tclose_f(position_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f position_id') +! call h5tclose_f(name_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f name_id ') +! call h5tclose_f(dt5_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dt5_id') +! call h5dclose_f(dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dclose_f') +! call h5sclose_f(space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f space_id') +! call h5sclose_f(memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f memspace') +! call h5pclose_f(plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pclose_f') +! call HDF5_closeGroup(mapping_ID) + +!end subroutine HDF5_mappingPhase + +!!-------------------------------------------------------------------------------------------------- +!!> @brief adds the backward mapping from spatial position and constituent ID to results +!!-------------------------------------------------------------------------------------------------- +!subroutine HDF5_backwardMappingPhase(material_phase,phasememberat,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) +! use hdf5 + +! implicit none +! integer(pInt), intent(in), dimension(:,:,:) :: material_phase, phasememberat +! character(len=*), intent(in), dimension(:) :: phase_name +! integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_phase +! integer(pInt), intent(in) :: mpiOffset + +! integer(pInt) :: hdferr, NmatPoints, Nconstituents, i, j +! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace +! integer(SIZE_T) :: type_size + +! integer(pInt), dimension(:,:), allocatable :: arr + +! integer(HSIZE_T), dimension(1) :: counter +! integer(HSSIZE_T), dimension(1) :: fileOffset + +! character(len=64) :: phaseID + +! Nconstituents = size(phasememberat,1) +! NmatPoints = count(material_phase /=0_pInt)/Nconstituents + +! allocate(arr(2,NmatPoints*Nconstituents)) + +! do i=1_pInt, NmatPoints +! do j=Nconstituents-1_pInt, 0_pInt, -1_pInt +! arr(1,Nconstituents*i-j) = i-1_pInt +! enddo +! enddo +! arr(2,:) = pack(material_phase,material_phase/=0_pInt) + +! do i=1_pInt, size(phase_name) +! write(phaseID, '(i0)') i +! mapping_ID = results_openGroup('/current/constitutive/'//trim(phaseID)//'_'//phase_name(i)) +! NmatPoints = count(material_phase == i) + +!!-------------------------------------------------------------------------------------------------- +! ! create dataspace +! call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & +! int([dataspace_size(i)],HSIZE_T)) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') + +!!-------------------------------------------------------------------------------------------------- +! ! compound type +! call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) +! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') + +! call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f 0') + +!!-------------------------------------------------------------------------------------------------- +! ! create Dataset +! call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase') + +!!-------------------------------------------------------------------------------------------------- +! ! Create memory types (one compound datatype for each member) +! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tcreate_f position_id') +! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f position_id') + +!!-------------------------------------------------------------------------------------------------- +! ! Define and select hyperslabs +! counter = NmatPoints ! how big i am +! fileOffset = mpiOffset_phase(i) ! where i start to write my data + +! call h5screate_simple_f(1, counter, memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5screate_simple_f') +! call h5dget_space_f(dset_id, space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dget_space_f') +! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sselect_hyperslab_f') + +!!-------------------------------------------------------------------------------------------------- +! ! Create property list for collective dataset write +!#ifdef PETSc +! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pcreate_f') +! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pset_dxpl_mpio_f') +!#endif + +!!-------------------------------------------------------------------------------------------------- +! ! write data by fields in the datatype. Fields order is not important. +! call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset, int([dataspace_size(i)],HSIZE_T),& +! hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dwrite_f instance_id') + +!!-------------------------------------------------------------------------------------------------- +! !close types, dataspaces +! call h5tclose_f(dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f dtype_id') +! call h5tclose_f(position_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f position_id') +! call h5dclose_f(dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dclose_f') +! call h5sclose_f(space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f space_id') +! call h5sclose_f(memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f memspace') +! call h5pclose_f(plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pclose_f') +! call HDF5_closeGroup(mapping_ID) + +! enddo + +!end subroutine HDF5_backwardMappingPhase + +!!-------------------------------------------------------------------------------------------------- +!!> @brief adds the unique mapping from spatial position and constituent ID to results +!!-------------------------------------------------------------------------------------------------- +!subroutine HDF5_mappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) +! use hdf5 + +! implicit none +! integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat +! character(len=*), intent(in), dimension(:) :: homogenization_name +! integer(pInt), intent(in), dimension(:) :: mpiOffset_homog +! integer(pInt), intent(in) :: dataspace_size, mpiOffset + +! integer(pInt) :: hdferr, NmatPoints, i, j +! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace + +! integer(HID_T) :: dt5_id ! Memory datatype identifier +! integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size + +! integer(HSIZE_T), dimension(1) :: counter +! integer(HSSIZE_T), dimension(1) :: fileOffset +! integer(pInt), dimension(:), allocatable :: arrOffset + +! NmatPoints = count(material_homog /=0_pInt) +! mapping_ID = results_openGroup("current/mapGeometry") + +! allocate(arrOffset(NmatPoints)) +! do i=1_pInt, NmatPoints +! do j=1_pInt, size(homogenization_name) +! if(material_homog(1,i) == j) & +! arrOffset(i) = mpiOffset_homog(j) +! enddo +! enddo + +!!-------------------------------------------------------------------------------------------------- +!! create dataspace +! call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & +! int([dataspace_size],HSIZE_T)) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') + +!!-------------------------------------------------------------------------------------------------- +!! compound type +! ! First calculate total size by calculating sizes of each member +! ! +! CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) +! typesize = len(homogenization_name(1)) +! CALL h5tset_size_f(dt5_id, typesize, hdferr) +! CALL h5tget_size_f(dt5_id, type_sizec, hdferr) +! CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) +! type_size = type_sizec + type_sizei +! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') + +! call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 0') +! call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 2') + +!!-------------------------------------------------------------------------------------------------- +!! create Dataset +! call h5dcreate_f(mapping_id, 'homogenization', dtype_id, space_id, dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog') + +!!-------------------------------------------------------------------------------------------------- +!! Create memory types (one compound datatype for each member) +! call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f instance_id') +! call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f instance_id') + +! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f position_id') +! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f position_id') + +!!-------------------------------------------------------------------------------------------------- +!! Define and select hyperslabs +! counter = NmatPoints ! how big i am +! fileOffset = mpiOffset ! where i start to write my data + +! call h5screate_simple_f(1, counter, memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5screate_simple_f') +! call h5dget_space_f(dset_id, space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dget_space_f') +! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sselect_hyperslab_f') + +!!-------------------------------------------------------------------------------------------------- +!! Create property list for collective dataset write +!#ifdef PETSc +! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pcreate_f') +! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pset_dxpl_mpio_f') +!#endif + +!!-------------------------------------------------------------------------------------------------- +!! write data by fields in the datatype. Fields order is not important. +! call h5dwrite_f(dset_id, name_id, homogenization_name(pack(material_homog,material_homog/=0_pInt)), & +! int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & +! mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f position_id') + +! call h5dwrite_f(dset_id, position_id, pack(homogmemberat-1_pInt,homogmemberat/=0_pInt) + arrOffset, & +! int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & +! mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f instance_id') + +!!-------------------------------------------------------------------------------------------------- +!!close types, dataspaces +!call h5tclose_f(dtype_id, hdferr) +!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dtype_id') +!call h5tclose_f(position_id, hdferr) +!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f position_id') +!call h5tclose_f(name_id, hdferr) +!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f name_id ') +!call h5tclose_f(dt5_id, hdferr) +!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dt5_id') +!call h5dclose_f(dset_id, hdferr) +!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dclose_f') +!call h5sclose_f(space_id, hdferr) +!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f space_id') +!call h5sclose_f(memspace, hdferr) +!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f memspace') +!call h5pclose_f(plist_id, hdferr) +!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pclose_f') +!call HDF5_closeGroup(mapping_ID) + +!end subroutine HDF5_mappingHomog + +!!-------------------------------------------------------------------------------------------------- +!!> @brief adds the backward mapping from spatial position and constituent ID to results +!!-------------------------------------------------------------------------------------------------- +!subroutine HDF5_backwardMappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) +! use hdf5 + +! implicit none +! integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat +! character(len=*), intent(in), dimension(:) :: homogenization_name +! integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_homog +! integer(pInt), intent(in) :: mpiOffset + +! integer(pInt) :: hdferr, NmatPoints, i +! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace +! integer(SIZE_T) :: type_size + +! integer(pInt), dimension(:,:), allocatable :: arr + +! integer(HSIZE_T), dimension(1) :: counter +! integer(HSSIZE_T), dimension(1) :: fileOffset + +! character(len=64) :: homogID + +! NmatPoints = count(material_homog /=0_pInt) +! allocate(arr(2,NmatPoints)) + +! arr(1,:) = (/(i, i=0_pint,NmatPoints-1_pInt)/) +! arr(2,:) = pack(material_homog,material_homog/=0_pInt) + +! do i=1_pInt, size(homogenization_name) +! write(homogID, '(i0)') i +! mapping_ID = results_openGroup('/current/homogenization/'//trim(homogID)//'_'//homogenization_name(i)) + +!!-------------------------------------------------------------------------------------------------- +! ! create dataspace +! call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & +! int([dataspace_size(i)],HSIZE_T)) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') + +!!-------------------------------------------------------------------------------------------------- +! ! compound type +! call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) +! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') + +! call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f 0') + +!!-------------------------------------------------------------------------------------------------- +! ! create Dataset +! call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog') + +!!-------------------------------------------------------------------------------------------------- +! ! Create memory types (one compound datatype for each member) +! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tcreate_f position_id') +! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f position_id') + +!!-------------------------------------------------------------------------------------------------- +! ! Define and select hyperslabs +! counter = NmatPoints ! how big i am +! fileOffset = mpiOffset_homog(i) ! where i start to write my data + +! call h5screate_simple_f(1, counter, memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5screate_simple_f') +! call h5dget_space_f(dset_id, space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dget_space_f') +! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sselect_hyperslab_f') + +!!-------------------------------------------------------------------------------------------------- +! ! Create property list for collective dataset write +!#ifdef PETSc +! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pcreate_f') +! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pset_dxpl_mpio_f') +!#endif + +!!-------------------------------------------------------------------------------------------------- +! ! write data by fields in the datatype. Fields order is not important. +! call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset,int([dataspace_size(i)],HSIZE_T),& +! hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dwrite_f instance_id') + +!!-------------------------------------------------------------------------------------------------- +! !close types, dataspaces +! call h5tclose_f(dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f dtype_id') +! call h5tclose_f(position_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f position_id') +! call h5dclose_f(dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dclose_f') +! call h5sclose_f(space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f space_id') +! call h5sclose_f(memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f memspace') +! call h5pclose_f(plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pclose_f') +! call HDF5_closeGroup(mapping_ID) + +! enddo + +!end subroutine HDF5_backwardMappingHomog + +!!-------------------------------------------------------------------------------------------------- +!!> @brief adds the unique mapping from spatial position and constituent ID to results +!!-------------------------------------------------------------------------------------------------- +!subroutine HDF5_mappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) +! use hdf5 + +! implicit none +! integer(pInt), intent(in), dimension(:,:) :: crystalliteAt +! integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt +! character(len=*), intent(in), dimension(:) :: crystallite_name +! integer(pInt), intent(in), dimension(:) :: mpiOffset_cryst +! integer(pInt), intent(in) :: dataspace_size, mpiOffset + +! integer :: hdferr +! integer(pInt) :: NmatPoints, Nconstituents, i, j +! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, plist_id, memspace + +! integer(HID_T), dimension(:), allocatable :: position_id + +! integer(HID_T) :: dt5_id ! Memory datatype identifier +! integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size + +! integer(HSIZE_T), dimension(1) :: counter +! integer(HSSIZE_T), dimension(1) :: fileOffset +! integer(pInt), dimension(:), allocatable :: arrOffset + +! character(len=64) :: m + +! Nconstituents = size(crystmemberAt,1) +! NmatPoints = count(crystalliteAt /=0_pInt) +! mapping_ID = results_openGroup("current/mapGeometry") + +! allocate(position_id(Nconstituents)) + +! allocate(arrOffset(NmatPoints)) +! do i=1_pInt, NmatPoints +! do j=1_pInt, size(crystallite_name) +! if(crystalliteAt(1,i) == j) & +! arrOffset(i) = Nconstituents*mpiOffset_cryst(j) +! enddo +! enddo + +!!-------------------------------------------------------------------------------------------------- +!! create dataspace +! call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & +! int([dataspace_size],HSIZE_T)) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') + +!!-------------------------------------------------------------------------------------------------- +!! compound type +! ! First calculate total size by calculating sizes of each member +! ! +! CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) +! typesize = len(crystallite_name(1)) +! CALL h5tset_size_f(dt5_id, typesize, hdferr) +! CALL h5tget_size_f(dt5_id, type_sizec, hdferr) +! CALL h5tget_size_f(H5T_STD_I32LE, type_sizei, hdferr) +! type_size = type_sizec + type_sizei*Nconstituents +! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') + +! call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 0') +! do i=1_pInt, Nconstituents +! write(m, '(i0)') i +! call h5tinsert_f(dtype_id, "Position "//trim(m), type_sizec+(i-1)*type_sizei, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 2 '//trim(m)) +! enddo + +!!-------------------------------------------------------------------------------------------------- +!! create Dataset +! call h5dcreate_f(mapping_id, 'crystallite', dtype_id, space_id, dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite') + +!!-------------------------------------------------------------------------------------------------- +!! Create memory types (one compound datatype for each member) +! call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f instance_id') +! call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f instance_id') + +! do i=1_pInt, Nconstituents +! write(m, '(i0)') i +! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id(i), hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f position_id') +! call h5tinsert_f(position_id(i), "Position "//trim(m), 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f position_id') +! enddo + +!!-------------------------------------------------------------------------------------------------- +!! Define and select hyperslabs +! counter = NmatPoints ! how big i am +! fileOffset = mpiOffset ! where i start to write my data + +! call h5screate_simple_f(1, counter, memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5screate_simple_f') +! call h5dget_space_f(dset_id, space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dget_space_f') +! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sselect_hyperslab_f') + +!!-------------------------------------------------------------------------------------------------- +! ! Create property list for collective dataset write +!#ifdef PETSc +! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pcreate_f') +! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pset_dxpl_mpio_f') +!#endif + +!!-------------------------------------------------------------------------------------------------- +!! write data by fields in the datatype. Fields order is not important. +! call h5dwrite_f(dset_id, name_id, crystallite_name(pack(crystalliteAt,crystalliteAt/=0_pInt)), & +! int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & +! mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f position_id') + +! do i=1_pInt, Nconstituents +! call h5dwrite_f(dset_id, position_id(i), pack(crystmemberAt(i,:,:)-1_pInt,crystmemberAt(i,:,:)/=0_pInt)+arrOffset,& +! int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & +! mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f instance_id') +! enddo + +!!-------------------------------------------------------------------------------------------------- +!!close types, dataspaces +! call h5tclose_f(dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dtype_id') +! do i=1_pInt, Nconstituents +! call h5tclose_f(position_id(i), hdferr) +! enddo +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f position_id') +! call h5tclose_f(name_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f name_id') +! call h5tclose_f(dt5_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dt5_id') +! call h5dclose_f(dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dclose_f') +! call h5sclose_f(space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f space_id') +! call h5sclose_f(memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f memspace') +! call h5pclose_f(plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pclose_f') +! call HDF5_closeGroup(mapping_ID) + +!end subroutine HDF5_mappingCrystallite + + +!!-------------------------------------------------------------------------------------------------- +!!> @brief adds the backward mapping from spatial position and constituent ID to results +!!-------------------------------------------------------------------------------------------------- +!subroutine HDF5_backwardMappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) +! use hdf5 + +! implicit none +! integer(pInt), intent(in), dimension(:,:) :: crystalliteAt +! integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt +! character(len=*), intent(in), dimension(:) :: crystallite_name +! integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_cryst +! integer(pInt), intent(in) :: mpiOffset + +! integer :: hdferr +! integer(pInt) :: NmatPoints, Nconstituents, i, j +! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace +! integer(SIZE_T) :: type_size + +! integer(pInt), dimension(:,:), allocatable :: h_arr, arr + +! integer(HSIZE_T), dimension(1) :: counter +! integer(HSSIZE_T), dimension(1) :: fileOffset + +! character(len=64) :: crystallID + +! Nconstituents = size(crystmemberAt,1) +! NmatPoints = count(crystalliteAt /=0_pInt) + +! allocate(h_arr(2,NmatPoints)) +! allocate(arr(2,Nconstituents*NmatPoints)) + +! h_arr(1,:) = (/(i, i=0_pInt,NmatPoints-1_pInt)/) +! h_arr(2,:) = pack(crystalliteAt,crystalliteAt/=0_pInt) + +! do i=1_pInt, NmatPoints +! do j=Nconstituents-1_pInt, 0_pInt, -1_pInt +! arr(1,Nconstituents*i-j) = h_arr(1,i) +! arr(2,Nconstituents*i-j) = h_arr(2,i) +! enddo +! enddo + +! do i=1_pInt, size(crystallite_name) +! if (crystallite_name(i) == 'none') cycle +! write(crystallID, '(i0)') i +! mapping_ID = results_openGroup('/current/crystallite/'//trim(crystallID)//'_'//crystallite_name(i)) +! NmatPoints = count(crystalliteAt == i) + +!!-------------------------------------------------------------------------------------------------- +! ! create dataspace +! call h5screate_simple_f(1, int([Nconstituents*dataspace_size(i)],HSIZE_T), space_id, hdferr, & +! int([Nconstituents*dataspace_size(i)],HSIZE_T)) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') + +!!-------------------------------------------------------------------------------------------------- +! ! compound type +! call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) +! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') + +! call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f 0') + +!!-------------------------------------------------------------------------------------------------- +! ! create Dataset +! call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite') + +!!-------------------------------------------------------------------------------------------------- +! ! Create memory types +! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tcreate_f position_id') +! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f position_id') + +!!-------------------------------------------------------------------------------------------------- +! ! Define and select hyperslabs +! counter = Nconstituents*NmatPoints ! how big i am +! fileOffset = Nconstituents*mpiOffset_cryst(i) ! where i start to write my data + +! call h5screate_simple_f(1, counter, memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5screate_simple_f') +! call h5dget_space_f(dset_id, space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dget_space_f') +! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sselect_hyperslab_f') + +!!-------------------------------------------------------------------------------------------------- +! ! Create property list for collective dataset write +!#ifdef PETSc +! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pcreate_f') +! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pset_dxpl_mpio_f') +!#endif + +!!-------------------------------------------------------------------------------------------------- +! ! write data by fields in the datatype. Fields order is not important. +! call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i) + mpiOffset,& +! int([Nconstituents*dataspace_size(i)],HSIZE_T), hdferr, file_space_id = space_id, & +! mem_space_id = memspace, xfer_prp = plist_id) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dwrite_f instance_id') + +!!-------------------------------------------------------------------------------------------------- +! !close types, dataspaces +! call h5tclose_f(dtype_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f dtype_id') +! call h5tclose_f(position_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f position_id') +! call h5dclose_f(dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dclose_f') +! call h5sclose_f(space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f space_id') +! call h5sclose_f(memspace, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f memspace') +! call h5pclose_f(plist_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pclose_f') +! call HDF5_closeGroup(mapping_ID) + +! enddo + +!end subroutine HDF5_backwardMappingCrystallite + +!!-------------------------------------------------------------------------------------------------- +!!> @brief adds the unique cell to node mapping +!!-------------------------------------------------------------------------------------------------- +!subroutine HDF5_mappingCells(mapping) +! use hdf5 + +! implicit none +! integer(pInt), intent(in), dimension(:) :: mapping + +! integer :: hdferr, Nnodes +! integer(HID_T) :: mapping_id, dset_id, space_id + +! Nnodes=size(mapping) +! mapping_ID = results_openGroup("mapping") + +!!-------------------------------------------------------------------------------------------------- +!! create dataspace +! call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, & +! int([Nnodes],HSIZE_T)) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5screate_simple_f') + +!!-------------------------------------------------------------------------------------------------- +!! create Dataset +! call h5dcreate_f(mapping_id, "Cell",H5T_NATIVE_INTEGER, space_id, dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells') + +!!-------------------------------------------------------------------------------------------------- +!! write data by fields in the datatype. Fields order is not important. +! call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, mapping, int([Nnodes],HSIZE_T), hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5dwrite_f instance_id') + +!!-------------------------------------------------------------------------------------------------- +!!close types, dataspaces +! call h5dclose_f(dset_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5dclose_f') +! call h5sclose_f(space_id, hdferr) +! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5sclose_f') +! call HDF5_closeGroup(mapping_ID) + +!end subroutine HDF5_mappingCells end module results From 63e6d60949c1e243ea9b486aaad6149f1755e564 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 4 Apr 2019 16:22:33 +0200 Subject: [PATCH 08/97] [skip sc] wip: implementing mapping for HDF5 --- src/CPFEM2.f90 | 2 +- src/material.f90 | 4 +++ src/results.f90 | 91 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 96 insertions(+), 1 deletion(-) diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 13d7f06c4..c6f08cbf6 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -72,9 +72,9 @@ subroutine CPFEM_initAll() call FE_init call mesh_init call lattice_init - call material_init call HDF5_utilities_init call results_init + call material_init call constitutive_init call crystallite_init call homogenization_init diff --git a/src/material.f90 b/src/material.f90 index a4fc78350..f04bfb35d 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -274,6 +274,7 @@ contains !> material.config !-------------------------------------------------------------------------------------------------- subroutine material_init + use results use IO, only: & IO_error use debug, only: & @@ -409,6 +410,9 @@ subroutine material_init enddo enddo enddo + + call results_openJobFile + call results_closeJobFile !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/results.f90 b/src/results.f90 index 4af545f54..7e98f0b9e 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -55,6 +55,8 @@ subroutine results_init call HDF5_addAttribute(resultsFile,'DAMASK',DAMASKVERSION) call get_command(commandLine) call HDF5_addAttribute(resultsFile,'call',trim(commandLine)) + call HDF5_closeGroup(results_addGroup('mapping')) + call HDF5_closeGroup(results_addGroup('mapping/cellResults')) call HDF5_closeFile(resultsFile) end subroutine results_init @@ -303,6 +305,95 @@ subroutine results_writeTensorDataset_int(group,dataset,label,description,SIunit end subroutine results_writeTensorDataset_int +!-------------------------------------------------------------------------------------------------- +!> @brief adds the unique mapping from spatial position and constituent ID to results +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_mapping_phase(phaseAt,memberAt,label) + use numerics, only: & + worldrank, & + worldsize + + integer, dimension(:,:), intent(in) :: phaseAt + integer, dimension(:,:,:), intent(in) :: memberAt + character(len=64), dimension(:), intent(in) :: label + + integer, dimension(:,:), allocatable :: memberAt_global + + integer, dimension(size(label),0:worldsize-1) :: members + integer, dimension(0:worldsize-1) :: writeSize + + integer(HID_T) :: loc_id, dtype_id, dset_id, space_id, name_id, plist_id, dt5_id + integer(HID_T), dimension(size(memberAt,1)) :: position_id + + integer(SIZE_T) :: typesize, type_size_string, type_size_int, type_size_compound + integer :: ierr, i + + character(len=1) :: constituent_number + + memberAt_global = reshape(memberAt,[size(memberAt,1),size(memberAt)/size(memberAt,1)]) + +!--------------------------------------------------------------------------------------------------- +! property list for transfer properties (needed for MPI) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + +!--------------------------------------------------------------------------------------------------- +! compound type: name of phase section + position(s) within results array + call h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, ierr) + call h5tset_size_f(dt5_id, int(len(label(1)),SIZE_T), ierr) + call h5tget_size_f(dt5_id, type_size_string, ierr) + call h5tget_size_f(H5T_STD_I32LE, type_size_int, ierr) + type_size_compound = type_size_string + type_size_int*size(memberAt,1) ! total size of derived type + + call h5tcreate_f(H5T_COMPOUND_F, type_size_compound, dtype_id, ierr) + call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, ierr) + do i=1, size(memberAt,1) + write(constituent_number, '(i0)') i + call h5tinsert_f(dtype_id, "Index "//trim(constituent_number),type_size_string+(i-1)*type_size_int,& + H5T_STD_I32LE, ierr) + enddo + +!-------------------------------------------------------------------------------------------------- +! Create memory types for each component of the compound type + call h5tcreate_f(H5T_COMPOUND_F, int(type_size_string,SIZE_T), name_id, ierr) + call h5tinsert_f(name_id, "Name",0_SIZE_T, dt5_id, ierr) + do i=1, size(memberAt,1) + write(constituent_number, '(i0)') i + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id(i), ierr) + call h5tinsert_f(position_id(i), "Index "//trim(constituent_number), 0_SIZE_T, H5T_STD_I32LE, ierr) + enddo + +!-------------------------------------------------------------------------------------------------- +! Prepare MPI communication (transparent for non-MPI runs) + members = 0 + do i=1, size(label) + members(i,worldrank) = count(memberAt == i) ! number of points/instance of this process + enddo + writeSize = 0 + writeSize(worldrank) = sum(members(:,worldrank)) ! total number of points by this process + +#ifdef PETSc + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, ierr) + if (ierr < 0) call IO_error(1,ext_msg='IO_mappingConstituent: h5pset_dxpl_mpio_f') + + call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='IO_mappingConstituent: MPI_allreduce') + + call MPI_allreduce(MPI_IN_PLACE,members,size(members),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='IO_mappingConstituent: MPI_allreduce') +#endif + + + members(:,worldrank) = sum(members(:,0:worldrank-1),2) ! starting id for each instance of this process + + + + loc_id = results_openGroup('/mapping/cellResults') + + + call HDF5_closeGroup(loc_id) + +end subroutine + !!-------------------------------------------------------------------------------------------------- !!> @brief adds the unique mapping from spatial position and constituent ID to results !!-------------------------------------------------------------------------------------------------- From 049cd96bbf8984b259deb5539292cf65a5049dcc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 5 Apr 2019 14:02:24 +0200 Subject: [PATCH 09/97] introduced constituent mapping this mapping will be used to find for a given location in the mesh the constituent (phase/crystallite) results --- src/material.f90 | 5 + src/results.f90 | 576 +++++++++-------------------------------------- 2 files changed, 114 insertions(+), 467 deletions(-) diff --git a/src/material.f90 b/src/material.f90 index f04bfb35d..c01d1f799 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -274,7 +274,9 @@ contains !> material.config !-------------------------------------------------------------------------------------------------- subroutine material_init +#ifdef DAMASK_HDF5 use results +#endif use IO, only: & IO_error use debug, only: & @@ -411,8 +413,11 @@ subroutine material_init enddo enddo +#ifdef DAMASK_HDF5 call results_openJobFile + call results_mapping_constituent(material_phaseAt,material_phaseMemberAt,phase_name) call results_closeJobFile +#endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/results.f90 b/src/results.f90 index 7e98f0b9e..0bd63c7b7 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -33,7 +33,8 @@ module results results_writeDataset, & results_setLink, & results_addAttribute, & - results_removeLink + results_removeLink, & + results_mapping_constituent contains subroutine results_init @@ -308,229 +309,140 @@ end subroutine results_writeTensorDataset_int !-------------------------------------------------------------------------------------------------- !> @brief adds the unique mapping from spatial position and constituent ID to results !-------------------------------------------------------------------------------------------------- -subroutine HDF5_mapping_phase(phaseAt,memberAt,label) +subroutine results_mapping_constituent(phaseAt,memberAt,label) use numerics, only: & worldrank, & worldsize - integer, dimension(:,:), intent(in) :: phaseAt - integer, dimension(:,:,:), intent(in) :: memberAt - character(len=64), dimension(:), intent(in) :: label + integer, dimension(:,:), intent(in) :: phaseAt !< phase section at (constituent,element) + integer, dimension(:,:,:), intent(in) :: memberAt !< phase member at (constituent,IP, element) + character(len=64), dimension(:), intent(in) :: label !< label of each phase section - integer, dimension(:,:), allocatable :: memberAt_global + integer, dimension(size(memberAt,1),size(memberAt,2),size(memberAt,3)) :: & + phaseAt_perIP, & + memberAt_total + integer, dimension(size(label),0:worldsize-1) :: memberOffset !< offset in member counting per process + integer, dimension(0:worldsize-1) :: writeSize !< amount of data written per process + integer(HSIZE_T), dimension(2) :: & + myShape, & !< shape of the dataset (this process) + myOffset, & + totalShape !< shape of the dataset (all processes) - integer, dimension(size(label),0:worldsize-1) :: members - integer, dimension(0:worldsize-1) :: writeSize + integer(HID_T) :: & + loc_id, & !< identifier of group in file + dtype_id, & !< identifier of compound data type + name_id, & !< identifier of name (string) in compound data type + position_id, & !< identifier of position/index (integer) in compound data type + dset_id, & + memspace_id, & + filespace_id, & + plist_id, & + dt_id + - integer(HID_T) :: loc_id, dtype_id, dset_id, space_id, name_id, plist_id, dt5_id - integer(HID_T), dimension(size(memberAt,1)) :: position_id - - integer(SIZE_T) :: typesize, type_size_string, type_size_int, type_size_compound + integer(SIZE_T) :: type_size_string, type_size_int integer :: ierr, i - character(len=1) :: constituent_number - - memberAt_global = reshape(memberAt,[size(memberAt,1),size(memberAt)/size(memberAt,1)]) - !--------------------------------------------------------------------------------------------------- -! property list for transfer properties (needed for MPI) +! compound type: name of phase section + position/index within results array + call h5tcopy_f(H5T_NATIVE_CHARACTER, dt_id, ierr) + call h5tset_size_f(dt_id, int(len(label(1)),SIZE_T), ierr) + call h5tget_size_f(dt_id, type_size_string, ierr) + + call h5tget_size_f(H5T_NATIVE_INTEGER, type_size_int, ierr) + + call h5tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, ierr) + call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt_id,ierr) + call h5tinsert_f(dtype_id, "Position", type_size_string, H5T_NATIVE_INTEGER, ierr) + +!-------------------------------------------------------------------------------------------------- +! create memory types for each component of the compound type + call h5tcreate_f(H5T_COMPOUND_F, type_size_string, name_id, ierr) + call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt_id, ierr) + + call h5tcreate_f(H5T_COMPOUND_F, type_size_int, position_id, ierr) + call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_NATIVE_INTEGER, ierr) + + call h5tclose_f(dt_id, ierr) + +!-------------------------------------------------------------------------------------------------- +! prepare MPI communication (transparent for non-MPI runs) call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) - -!--------------------------------------------------------------------------------------------------- -! compound type: name of phase section + position(s) within results array - call h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, ierr) - call h5tset_size_f(dt5_id, int(len(label(1)),SIZE_T), ierr) - call h5tget_size_f(dt5_id, type_size_string, ierr) - call h5tget_size_f(H5T_STD_I32LE, type_size_int, ierr) - type_size_compound = type_size_string + type_size_int*size(memberAt,1) ! total size of derived type - - call h5tcreate_f(H5T_COMPOUND_F, type_size_compound, dtype_id, ierr) - call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, ierr) - do i=1, size(memberAt,1) - write(constituent_number, '(i0)') i - call h5tinsert_f(dtype_id, "Index "//trim(constituent_number),type_size_string+(i-1)*type_size_int,& - H5T_STD_I32LE, ierr) - enddo - -!-------------------------------------------------------------------------------------------------- -! Create memory types for each component of the compound type - call h5tcreate_f(H5T_COMPOUND_F, int(type_size_string,SIZE_T), name_id, ierr) - call h5tinsert_f(name_id, "Name",0_SIZE_T, dt5_id, ierr) - do i=1, size(memberAt,1) - write(constituent_number, '(i0)') i - call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id(i), ierr) - call h5tinsert_f(position_id(i), "Index "//trim(constituent_number), 0_SIZE_T, H5T_STD_I32LE, ierr) - enddo - -!-------------------------------------------------------------------------------------------------- -! Prepare MPI communication (transparent for non-MPI runs) - members = 0 + memberOffset = 0 do i=1, size(label) - members(i,worldrank) = count(memberAt == i) ! number of points/instance of this process + memberOffset(i,worldrank) = count(phaseAt == i)*size(memberAt,2) ! number of points/instance of this process enddo writeSize = 0 - writeSize(worldrank) = sum(members(:,worldrank)) ! total number of points by this process - + writeSize(worldrank) = size(memberAt(1,:,:)) ! total number of points by this process + +!-------------------------------------------------------------------------------------------------- +! MPI settings and communication #ifdef PETSc call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, ierr) - if (ierr < 0) call IO_error(1,ext_msg='IO_mappingConstituent: h5pset_dxpl_mpio_f') + if (ierr < 0) call IO_error(1,ext_msg='HDF5_mapping_phase: h5pset_dxpl_mpio_f') - call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='IO_mappingConstituent: MPI_allreduce') + call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get output at each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_mapping_phase: MPI_allreduce/writeSize') - call MPI_allreduce(MPI_IN_PLACE,members,size(members),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='IO_mappingConstituent: MPI_allreduce') + call MPI_allreduce(MPI_IN_PLACE,memberOffset,size(memberOffset),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get offset at each process + if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_mapping_phase: MPI_allreduce/memberOffset') #endif - - members(:,worldrank) = sum(members(:,0:worldrank-1),2) ! starting id for each instance of this process + myShape = int([size(phaseAt,1),writeSize(worldrank)], HSIZE_T) + myOffset = int([0,sum(writeSize(0:worldrank-1))], HSIZE_T) + totalShape = int([size(phaseAt,1),sum(writeSize)], HSIZE_T) +!-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape = hyperslab) and in file (global shape) + call h5screate_simple_f(2,myShape,memspace_id,ierr,myShape) + if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5screate_simple_f/memspace_id') + + call h5screate_simple_f(2,totalShape,filespace_id,ierr,totalShape) + if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5screate_simple_f/filespace_id') + + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, ierr) + if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5sselect_hyperslab_f') - - loc_id = results_openGroup('/mapping/cellResults') +!--------------------------------------------------------------------------------------------------- +! expand phaseAt to consider IPs (is not stored per IP) + do i = 1, size(phaseAt_perIP,2) + phaseAt_perIP(:,i,:) = phaseAt + enddo - - call HDF5_closeGroup(loc_id) +!--------------------------------------------------------------------------------------------------- +! renumber member from my process to all processes + do i = 1, size(label) + where(phaseAt_perIP == i) memberAt_total = memberAt + sum(memberOffset(i,0:worldrank-1)) + enddo -end subroutine +!-------------------------------------------------------------------------------------------------- +! write the components of the compound type individually + call h5pset_preserve_f(plist_id, .TRUE., ierr) + + loc_id = results_openGroup('/mapping/cellResults') + call h5dcreate_f(loc_id, 'constituent', dtype_id, filespace_id, dset_id, ierr) + if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5dcreate_f') + + call h5dwrite_f(dset_id, name_id, reshape(label(pack(phaseAt_perIP,.true.)),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5dwrite_f/name_id') + call h5dwrite_f(dset_id, position_id, reshape(pack(memberAt_total,.true.),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5dwrite_f/position_id') -!!-------------------------------------------------------------------------------------------------- -!!> @brief adds the unique mapping from spatial position and constituent ID to results -!!-------------------------------------------------------------------------------------------------- -!subroutine HDF5_mappingPhase(mapping,mapping2,Nconstituents,material_phase,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) +!-------------------------------------------------------------------------------------------------- +! close all + call HDF5_closeGroup(loc_id) + call h5pclose_f(plist_id, ierr) + call h5sclose_f(filespace_id, ierr) + call h5sclose_f(memspace_id, ierr) + call h5dclose_f(dset_id, ierr) + call h5tclose_f(dtype_id, ierr) + call h5tclose_f(name_id, ierr) + call h5tclose_f(position_id, ierr) -! implicit none -! integer(pInt), intent(in) :: Nconstituents, dataspace_size, mpiOffset -! integer(pInt), intent(in), dimension(:) :: mapping, mapping2 -! character(len=*), intent(in), dimension(:) :: phase_name -! integer(pInt), intent(in), dimension(:) :: mpiOffset_phase -! integer(pInt), intent(in), dimension(:,:,:) :: material_phase +end subroutine results_mapping_constituent -! character(len=len(phase_name(1))), dimension(:), allocatable :: namesNA -! character(len=len(phase_name(1))) :: a -! character(len=*), parameter :: n = "NULL" - -! integer(pInt) :: hdferr, NmatPoints, i, j, k -! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace -! integer(HID_T) :: dt5_id ! Memory datatype identifier -! integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - -! integer(HSIZE_T), dimension(2) :: counter -! integer(HSSIZE_T), dimension(2) :: fileOffset -! integer(pInt), dimension(:,:), allocatable :: arrOffset - -! a = n -! allocate(namesNA(0:size(phase_name)),source=[a,phase_name]) -! NmatPoints = size(mapping,1)/Nconstituents -! mapping_ID = results_openGroup("current/mapGeometry") - -! allocate(arrOffset(Nconstituents,NmatPoints)) -! do i=1_pInt, NmatPoints -! do k=1_pInt, Nconstituents -! do j=1_pInt, size(phase_name) -! if(material_phase(k,1,i) == j) & -! arrOffset(k,i) = mpiOffset_phase(j) -! enddo -! enddo -! enddo - -!!-------------------------------------------------------------------------------------------------- -!! create dataspace -! call h5screate_simple_f(2, int([Nconstituents,dataspace_size],HSIZE_T), space_id, hdferr, & -! int([Nconstituents,dataspace_size],HSIZE_T)) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') - -!!-------------------------------------------------------------------------------------------------- -!! compound type -! ! First calculate total size by calculating sizes of each member -! ! -! CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) -! typesize = len(phase_name(1)) -! CALL h5tset_size_f(dt5_id, typesize, hdferr) -! CALL h5tget_size_f(dt5_id, type_sizec, hdferr) -! CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) -! type_size = type_sizec + type_sizei -! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - -! call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 0') -! call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f 2') - -!!-------------------------------------------------------------------------------------------------- -!! create Dataset -! call h5dcreate_f(mapping_id, 'constitutive', dtype_id, space_id, dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase') - -!!-------------------------------------------------------------------------------------------------- -!! Create memory types (one compound datatype for each member) -! call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f instance_id') -! call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f instance_id') - -! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tcreate_f position_id') -! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tinsert_f position_id') - -!!-------------------------------------------------------------------------------------------------- -!! Define and select hyperslabs -! counter(1) = Nconstituents ! how big i am -! counter(2) = NmatPoints -! fileOffset(1) = 0 ! where i start to write my data -! fileOffset(2) = mpiOffset - -! call h5screate_simple_f(2, counter, memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5screate_simple_f') -! call h5dget_space_f(dset_id, space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dget_space_f') -! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sselect_hyperslab_f') - -!!-------------------------------------------------------------------------------------------------- -! ! Create property list for collective dataset write -!#ifdef PETSc -! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pcreate_f') -! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pset_dxpl_mpio_f') -!#endif - -!!-------------------------------------------------------------------------------------------------- -!! write data by fields in the datatype. Fields order is not important. -! call h5dwrite_f(dset_id, name_id, reshape(namesNA(mapping),[Nconstituents,NmatPoints]), & -! int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & -! file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f position_id') - -! call h5dwrite_f(dset_id, position_id, reshape(mapping2-1_pInt,[Nconstituents,NmatPoints])+arrOffset, & -! int([Nconstituents, dataspace_size],HSIZE_T), hdferr, & -! file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dwrite_f instance_id') - -!!-------------------------------------------------------------------------------------------------- -!! close types, dataspaces -! call h5tclose_f(dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dtype_id') -! call h5tclose_f(position_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f position_id') -! call h5tclose_f(name_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f name_id ') -! call h5tclose_f(dt5_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5tclose_f dt5_id') -! call h5dclose_f(dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5dclose_f') -! call h5sclose_f(space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f space_id') -! call h5sclose_f(memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5sclose_f memspace') -! call h5pclose_f(plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingPhase: h5pclose_f') -! call HDF5_closeGroup(mapping_ID) - -!end subroutine HDF5_mappingPhase !!-------------------------------------------------------------------------------------------------- !!> @brief adds the backward mapping from spatial position and constituent ID to results @@ -882,276 +794,6 @@ end subroutine !end subroutine HDF5_backwardMappingHomog -!!-------------------------------------------------------------------------------------------------- -!!> @brief adds the unique mapping from spatial position and constituent ID to results -!!-------------------------------------------------------------------------------------------------- -!subroutine HDF5_mappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) -! use hdf5 - -! implicit none -! integer(pInt), intent(in), dimension(:,:) :: crystalliteAt -! integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt -! character(len=*), intent(in), dimension(:) :: crystallite_name -! integer(pInt), intent(in), dimension(:) :: mpiOffset_cryst -! integer(pInt), intent(in) :: dataspace_size, mpiOffset - -! integer :: hdferr -! integer(pInt) :: NmatPoints, Nconstituents, i, j -! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, plist_id, memspace - -! integer(HID_T), dimension(:), allocatable :: position_id - -! integer(HID_T) :: dt5_id ! Memory datatype identifier -! integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - -! integer(HSIZE_T), dimension(1) :: counter -! integer(HSSIZE_T), dimension(1) :: fileOffset -! integer(pInt), dimension(:), allocatable :: arrOffset - -! character(len=64) :: m - -! Nconstituents = size(crystmemberAt,1) -! NmatPoints = count(crystalliteAt /=0_pInt) -! mapping_ID = results_openGroup("current/mapGeometry") - -! allocate(position_id(Nconstituents)) - -! allocate(arrOffset(NmatPoints)) -! do i=1_pInt, NmatPoints -! do j=1_pInt, size(crystallite_name) -! if(crystalliteAt(1,i) == j) & -! arrOffset(i) = Nconstituents*mpiOffset_cryst(j) -! enddo -! enddo - -!!-------------------------------------------------------------------------------------------------- -!! create dataspace -! call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & -! int([dataspace_size],HSIZE_T)) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') - -!!-------------------------------------------------------------------------------------------------- -!! compound type -! ! First calculate total size by calculating sizes of each member -! ! -! CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) -! typesize = len(crystallite_name(1)) -! CALL h5tset_size_f(dt5_id, typesize, hdferr) -! CALL h5tget_size_f(dt5_id, type_sizec, hdferr) -! CALL h5tget_size_f(H5T_STD_I32LE, type_sizei, hdferr) -! type_size = type_sizec + type_sizei*Nconstituents -! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - -! call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 0') -! do i=1_pInt, Nconstituents -! write(m, '(i0)') i -! call h5tinsert_f(dtype_id, "Position "//trim(m), type_sizec+(i-1)*type_sizei, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 2 '//trim(m)) -! enddo - -!!-------------------------------------------------------------------------------------------------- -!! create Dataset -! call h5dcreate_f(mapping_id, 'crystallite', dtype_id, space_id, dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite') - -!!-------------------------------------------------------------------------------------------------- -!! Create memory types (one compound datatype for each member) -! call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f instance_id') -! call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f instance_id') - -! do i=1_pInt, Nconstituents -! write(m, '(i0)') i -! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id(i), hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f position_id') -! call h5tinsert_f(position_id(i), "Position "//trim(m), 0_SIZE_T, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f position_id') -! enddo - -!!-------------------------------------------------------------------------------------------------- -!! Define and select hyperslabs -! counter = NmatPoints ! how big i am -! fileOffset = mpiOffset ! where i start to write my data - -! call h5screate_simple_f(1, counter, memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5screate_simple_f') -! call h5dget_space_f(dset_id, space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dget_space_f') -! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sselect_hyperslab_f') - -!!-------------------------------------------------------------------------------------------------- -! ! Create property list for collective dataset write -!#ifdef PETSc -! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pcreate_f') -! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pset_dxpl_mpio_f') -!#endif - -!!-------------------------------------------------------------------------------------------------- -!! write data by fields in the datatype. Fields order is not important. -! call h5dwrite_f(dset_id, name_id, crystallite_name(pack(crystalliteAt,crystalliteAt/=0_pInt)), & -! int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & -! mem_space_id = memspace, xfer_prp = plist_id) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f position_id') - -! do i=1_pInt, Nconstituents -! call h5dwrite_f(dset_id, position_id(i), pack(crystmemberAt(i,:,:)-1_pInt,crystmemberAt(i,:,:)/=0_pInt)+arrOffset,& -! int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & -! mem_space_id = memspace, xfer_prp = plist_id) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f instance_id') -! enddo - -!!-------------------------------------------------------------------------------------------------- -!!close types, dataspaces -! call h5tclose_f(dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dtype_id') -! do i=1_pInt, Nconstituents -! call h5tclose_f(position_id(i), hdferr) -! enddo -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f position_id') -! call h5tclose_f(name_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f name_id') -! call h5tclose_f(dt5_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f dt5_id') -! call h5dclose_f(dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dclose_f') -! call h5sclose_f(space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f space_id') -! call h5sclose_f(memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5sclose_f memspace') -! call h5pclose_f(plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5pclose_f') -! call HDF5_closeGroup(mapping_ID) - -!end subroutine HDF5_mappingCrystallite - - -!!-------------------------------------------------------------------------------------------------- -!!> @brief adds the backward mapping from spatial position and constituent ID to results -!!-------------------------------------------------------------------------------------------------- -!subroutine HDF5_backwardMappingCrystallite(crystalliteAt,crystmemberAt,crystallite_name,dataspace_size,mpiOffset,mpiOffset_cryst) -! use hdf5 - -! implicit none -! integer(pInt), intent(in), dimension(:,:) :: crystalliteAt -! integer(pInt), intent(in), dimension(:,:,:) :: crystmemberAt -! character(len=*), intent(in), dimension(:) :: crystallite_name -! integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_cryst -! integer(pInt), intent(in) :: mpiOffset - -! integer :: hdferr -! integer(pInt) :: NmatPoints, Nconstituents, i, j -! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, position_id, plist_id, memspace -! integer(SIZE_T) :: type_size - -! integer(pInt), dimension(:,:), allocatable :: h_arr, arr - -! integer(HSIZE_T), dimension(1) :: counter -! integer(HSSIZE_T), dimension(1) :: fileOffset - -! character(len=64) :: crystallID - -! Nconstituents = size(crystmemberAt,1) -! NmatPoints = count(crystalliteAt /=0_pInt) - -! allocate(h_arr(2,NmatPoints)) -! allocate(arr(2,Nconstituents*NmatPoints)) - -! h_arr(1,:) = (/(i, i=0_pInt,NmatPoints-1_pInt)/) -! h_arr(2,:) = pack(crystalliteAt,crystalliteAt/=0_pInt) - -! do i=1_pInt, NmatPoints -! do j=Nconstituents-1_pInt, 0_pInt, -1_pInt -! arr(1,Nconstituents*i-j) = h_arr(1,i) -! arr(2,Nconstituents*i-j) = h_arr(2,i) -! enddo -! enddo - -! do i=1_pInt, size(crystallite_name) -! if (crystallite_name(i) == 'none') cycle -! write(crystallID, '(i0)') i -! mapping_ID = results_openGroup('/current/crystallite/'//trim(crystallID)//'_'//crystallite_name(i)) -! NmatPoints = count(crystalliteAt == i) - -!!-------------------------------------------------------------------------------------------------- -! ! create dataspace -! call h5screate_simple_f(1, int([Nconstituents*dataspace_size(i)],HSIZE_T), space_id, hdferr, & -! int([Nconstituents*dataspace_size(i)],HSIZE_T)) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') - -!!-------------------------------------------------------------------------------------------------- -! ! compound type -! call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) -! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') - -! call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f 0') - -!!-------------------------------------------------------------------------------------------------- -! ! create Dataset -! call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite') - -!!-------------------------------------------------------------------------------------------------- -! ! Create memory types -! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tcreate_f position_id') -! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tinsert_f position_id') - -!!-------------------------------------------------------------------------------------------------- -! ! Define and select hyperslabs -! counter = Nconstituents*NmatPoints ! how big i am -! fileOffset = Nconstituents*mpiOffset_cryst(i) ! where i start to write my data - -! call h5screate_simple_f(1, counter, memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5screate_simple_f') -! call h5dget_space_f(dset_id, space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dget_space_f') -! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sselect_hyperslab_f') - -!!-------------------------------------------------------------------------------------------------- -! ! Create property list for collective dataset write -!#ifdef PETSc -! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pcreate_f') -! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pset_dxpl_mpio_f') -!#endif - -!!-------------------------------------------------------------------------------------------------- -! ! write data by fields in the datatype. Fields order is not important. -! call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i) + mpiOffset,& -! int([Nconstituents*dataspace_size(i)],HSIZE_T), hdferr, file_space_id = space_id, & -! mem_space_id = memspace, xfer_prp = plist_id) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dwrite_f instance_id') - -!!-------------------------------------------------------------------------------------------------- -! !close types, dataspaces -! call h5tclose_f(dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f dtype_id') -! call h5tclose_f(position_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5tclose_f position_id') -! call h5dclose_f(dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5dclose_f') -! call h5sclose_f(space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f space_id') -! call h5sclose_f(memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5sclose_f memspace') -! call h5pclose_f(plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingCrystallite: h5pclose_f') -! call HDF5_closeGroup(mapping_ID) - -! enddo - -!end subroutine HDF5_backwardMappingCrystallite !!-------------------------------------------------------------------------------------------------- !!> @brief adds the unique cell to node mapping From 7c30be47b060582b2b21b3ca09baf59f2c9b3416 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 5 Apr 2019 16:53:41 +0200 Subject: [PATCH 10/97] mapping for materialpoint/homogenization HDF5 file writing active for MSC.Marc/Abaqus (optional) --- src/CPFEM.f90 | 10 ++ src/material.f90 | 5 +- src/numerics.f90 | 2 +- src/results.f90 | 393 ++++++++++++++++++++++++----------------------- 4 files changed, 216 insertions(+), 194 deletions(-) diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index d34a79bf7..d2eaa7979 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -72,6 +72,12 @@ subroutine CPFEM_initAll(el,ip) mesh_init use material, only: & material_init +#ifdef DAMASK_HDF5 + use HDF5_utilities, only: & + HDF5_utilities_init + use results, only: & + results_init +#endif use lattice, only: & lattice_init use constitutive, only: & @@ -100,6 +106,10 @@ subroutine CPFEM_initAll(el,ip) call FE_init call mesh_init(ip, el) call lattice_init +#ifdef DAMASK_HDF5 + call HDF5_utilities_init + call results_init +#endif call material_init call constitutive_init call crystallite_init diff --git a/src/material.f90 b/src/material.f90 index c01d1f799..0b749c8ef 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -274,7 +274,7 @@ contains !> material.config !-------------------------------------------------------------------------------------------------- subroutine material_init -#ifdef DAMASK_HDF5 +#if defined(PETSc) || defined(DAMASK_HDF5) use results #endif use IO, only: & @@ -413,9 +413,10 @@ subroutine material_init enddo enddo -#ifdef DAMASK_HDF5 +#if defined(PETSc) || defined(DAMASK_HDF5) call results_openJobFile call results_mapping_constituent(material_phaseAt,material_phaseMemberAt,phase_name) + call results_mapping_materialpoint(material_homogenizationAt,material_homogenizationMemberAt,homogenization_name) call results_closeJobFile #endif diff --git a/src/numerics.f90 b/src/numerics.f90 index 955696219..f7c603c60 100644 --- a/src/numerics.f90 +++ b/src/numerics.f90 @@ -21,7 +21,7 @@ module numerics pert_method = 1_pInt, & !< method used in perturbation technique for tangent randomSeed = 0_pInt, & !< fixed seeding for pseudo-random number generator, Default 0: use random seed worldrank = 0_pInt, & !< MPI worldrank (/=0 for MPI simulations only) - worldsize = 0_pInt, & !< MPI worldsize (/=0 for MPI simulations only) + worldsize = 1_pInt, & !< MPI worldsize (/=1 for MPI simulations only) numerics_integrator = 1_pInt !< method used for state integration Default 1: fix-point iteration integer(4), protected, public :: & DAMASK_NumThreadsInt = 0 !< value stored in environment variable DAMASK_NUM_THREADS, set to zero if no OpenMP directive diff --git a/src/results.f90 b/src/results.f90 index 0bd63c7b7..0580436b8 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -34,7 +34,8 @@ module results results_setLink, & results_addAttribute, & results_removeLink, & - results_mapping_constituent + results_mapping_constituent, & + results_mapping_materialpoint contains subroutine results_init @@ -167,7 +168,7 @@ subroutine results_removeLink(link) integer :: hdferr call h5ldelete_f(resultsFile,link, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'results_removeLink: h5ldelete_soft_f ('//trim(link)//')') + if (hdferr < 0) call IO_error(1,ext_msg = 'results_removeLink: h5ldelete_soft_f ('//trim(link)//')') end subroutine results_removeLink @@ -315,7 +316,7 @@ subroutine results_mapping_constituent(phaseAt,memberAt,label) worldsize integer, dimension(:,:), intent(in) :: phaseAt !< phase section at (constituent,element) - integer, dimension(:,:,:), intent(in) :: memberAt !< phase member at (constituent,IP, element) + integer, dimension(:,:,:), intent(in) :: memberAt !< phase member at (constituent,IP,element) character(len=64), dimension(:), intent(in) :: label !< label of each phase section integer, dimension(size(memberAt,1),size(memberAt,2),size(memberAt,3)) :: & @@ -379,13 +380,13 @@ subroutine results_mapping_constituent(phaseAt,memberAt,label) ! MPI settings and communication #ifdef PETSc call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, ierr) - if (ierr < 0) call IO_error(1,ext_msg='HDF5_mapping_phase: h5pset_dxpl_mpio_f') + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get output at each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_mapping_phase: MPI_allreduce/writeSize') + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_constituent: MPI_allreduce/writeSize') call MPI_allreduce(MPI_IN_PLACE,memberOffset,size(memberOffset),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get offset at each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='HDF5_mapping_phase: MPI_allreduce/memberOffset') + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_constituent: MPI_allreduce/memberOffset') #endif myShape = int([size(phaseAt,1),writeSize(worldrank)], HSIZE_T) @@ -395,13 +396,13 @@ subroutine results_mapping_constituent(phaseAt,memberAt,label) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape = hyperslab) and in file (global shape) call h5screate_simple_f(2,myShape,memspace_id,ierr,myShape) - if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5screate_simple_f/memspace_id') + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5screate_simple_f/memspace_id') call h5screate_simple_f(2,totalShape,filespace_id,ierr,totalShape) - if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5screate_simple_f/filespace_id') + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5screate_simple_f/filespace_id') call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, ierr) - if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5sselect_hyperslab_f') + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5sselect_hyperslab_f') !--------------------------------------------------------------------------------------------------- ! expand phaseAt to consider IPs (is not stored per IP) @@ -421,14 +422,14 @@ subroutine results_mapping_constituent(phaseAt,memberAt,label) loc_id = results_openGroup('/mapping/cellResults') call h5dcreate_f(loc_id, 'constituent', dtype_id, filespace_id, dset_id, ierr) - if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5dcreate_f') + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dcreate_f') call h5dwrite_f(dset_id, name_id, reshape(label(pack(phaseAt_perIP,.true.)),myShape), & myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5dwrite_f/name_id') + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dwrite_f/name_id') call h5dwrite_f(dset_id, position_id, reshape(pack(memberAt_total,.true.),myShape), & myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (ierr < 0) call IO_error(1_pInt,ext_msg='HDF5_mapping_phase: h5dwrite_f/position_id') + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dwrite_f/position_id') !-------------------------------------------------------------------------------------------------- ! close all @@ -444,6 +445,144 @@ subroutine results_mapping_constituent(phaseAt,memberAt,label) end subroutine results_mapping_constituent +!-------------------------------------------------------------------------------------------------- +!> @brief adds the unique mapping from spatial position and constituent ID to results +!-------------------------------------------------------------------------------------------------- +subroutine results_mapping_materialpoint(homogenizationAt,memberAt,label) + use numerics, only: & + worldrank, & + worldsize + + integer, dimension(:), intent(in) :: homogenizationAt !< homogenization section at (element) + integer, dimension(:,:), intent(in) :: memberAt !< homogenization member at (IP,element) + character(len=64), dimension(:), intent(in) :: label !< label of each homogenization section + + integer, dimension(size(memberAt,1),size(memberAt,2)) :: & + homogenizationAt_perIP, & + memberAt_total + integer, dimension(size(label),0:worldsize-1) :: memberOffset !< offset in member counting per process + integer, dimension(0:worldsize-1) :: writeSize !< amount of data written per process + integer(HSIZE_T), dimension(1) :: & + myShape, & !< shape of the dataset (this process) + myOffset, & + totalShape !< shape of the dataset (all processes) + + integer(HID_T) :: & + loc_id, & !< identifier of group in file + dtype_id, & !< identifier of compound data type + name_id, & !< identifier of name (string) in compound data type + position_id, & !< identifier of position/index (integer) in compound data type + dset_id, & + memspace_id, & + filespace_id, & + plist_id, & + dt_id + + + integer(SIZE_T) :: type_size_string, type_size_int + integer :: ierr, i + +!--------------------------------------------------------------------------------------------------- +! compound type: name of phase section + position/index within results array + call h5tcopy_f(H5T_NATIVE_CHARACTER, dt_id, ierr) + call h5tset_size_f(dt_id, int(len(label(1)),SIZE_T), ierr) + call h5tget_size_f(dt_id, type_size_string, ierr) + + call h5tget_size_f(H5T_NATIVE_INTEGER, type_size_int, ierr) + + call h5tcreate_f(H5T_COMPOUND_F, type_size_string + type_size_int, dtype_id, ierr) + call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt_id,ierr) + call h5tinsert_f(dtype_id, "Position", type_size_string, H5T_NATIVE_INTEGER, ierr) + +!-------------------------------------------------------------------------------------------------- +! create memory types for each component of the compound type + call h5tcreate_f(H5T_COMPOUND_F, type_size_string, name_id, ierr) + call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt_id, ierr) + + call h5tcreate_f(H5T_COMPOUND_F, type_size_int, position_id, ierr) + call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_NATIVE_INTEGER, ierr) + + call h5tclose_f(dt_id, ierr) + +!-------------------------------------------------------------------------------------------------- +! prepare MPI communication (transparent for non-MPI runs) + call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, ierr) + memberOffset = 0 + do i=1, size(label) + memberOffset(i,worldrank) = count(homogenizationAt == i)*size(memberAt,1) ! number of points/instance of this process + enddo + writeSize = 0 + writeSize(worldrank) = size(memberAt) ! total number of points by this process + +!-------------------------------------------------------------------------------------------------- +! MPI settings and communication +#ifdef PETSc + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5pset_dxpl_mpio_f') + + call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get output at each process + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_materialpoint: MPI_allreduce/writeSize') + + call MPI_allreduce(MPI_IN_PLACE,memberOffset,size(memberOffset),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get offset at each process + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_materialpoint: MPI_allreduce/memberOffset') +#endif + + myShape = int([writeSize(worldrank)], HSIZE_T) + myOffset = int([sum(writeSize(0:worldrank-1))], HSIZE_T) + totalShape = int([sum(writeSize)], HSIZE_T) + +!-------------------------------------------------------------------------------------------------- +! create dataspace in memory (local shape = hyperslab) and in file (global shape) + call h5screate_simple_f(1,myShape,memspace_id,ierr,myShape) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5screate_simple_f/memspace_id') + + call h5screate_simple_f(1,totalShape,filespace_id,ierr,totalShape) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5screate_simple_f/filespace_id') + + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5sselect_hyperslab_f') + +!--------------------------------------------------------------------------------------------------- +! expand phaseAt to consider IPs (is not stored per IP) + do i = 1, size(homogenizationAt_perIP,1) + homogenizationAt_perIP(i,:) = homogenizationAt + enddo + +!--------------------------------------------------------------------------------------------------- +! renumber member from my process to all processes + do i = 1, size(label) + where(homogenizationAt_perIP == i) memberAt_total = memberAt + sum(memberOffset(i,0:worldrank-1)) + enddo + +!-------------------------------------------------------------------------------------------------- +! write the components of the compound type individually + call h5pset_preserve_f(plist_id, .TRUE., ierr) + + loc_id = results_openGroup('/mapping/cellResults') + call h5dcreate_f(loc_id, 'materialpoint', dtype_id, filespace_id, dset_id, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dcreate_f') + + call h5dwrite_f(dset_id, name_id, reshape(label(pack(homogenizationAt_perIP,.true.)),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dwrite_f/name_id') + call h5dwrite_f(dset_id, position_id, reshape(pack(memberAt_total,.true.),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dwrite_f/position_id') + +!-------------------------------------------------------------------------------------------------- +! close all + call HDF5_closeGroup(loc_id) + call h5pclose_f(plist_id, ierr) + call h5sclose_f(filespace_id, ierr) + call h5sclose_f(memspace_id, ierr) + call h5dclose_f(dset_id, ierr) + call h5tclose_f(dtype_id, ierr) + call h5tclose_f(name_id, ierr) + call h5tclose_f(position_id, ierr) + +end subroutine results_mapping_materialpoint + + !!-------------------------------------------------------------------------------------------------- !!> @brief adds the backward mapping from spatial position and constituent ID to results !!-------------------------------------------------------------------------------------------------- @@ -468,18 +607,18 @@ end subroutine results_mapping_constituent ! character(len=64) :: phaseID ! Nconstituents = size(phasememberat,1) -! NmatPoints = count(material_phase /=0_pInt)/Nconstituents +! NmatPoints = count(material_phase /=0)/Nconstituents ! allocate(arr(2,NmatPoints*Nconstituents)) -! do i=1_pInt, NmatPoints -! do j=Nconstituents-1_pInt, 0_pInt, -1_pInt -! arr(1,Nconstituents*i-j) = i-1_pInt +! do i=1, NmatPoints +! do j=Nconstituents-1, 0, -1 +! arr(1,Nconstituents*i-j) = i-1 ! enddo ! enddo -! arr(2,:) = pack(material_phase,material_phase/=0_pInt) +! arr(2,:) = pack(material_phase,material_phase/=0) -! do i=1_pInt, size(phase_name) +! do i=1, size(phase_name) ! write(phaseID, '(i0)') i ! mapping_ID = results_openGroup('/current/constitutive/'//trim(phaseID)//'_'//phase_name(i)) ! NmatPoints = count(material_phase == i) @@ -488,28 +627,28 @@ end subroutine results_mapping_constituent ! ! create dataspace ! call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & ! int([dataspace_size(i)],HSIZE_T)) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') +! if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping') !!-------------------------------------------------------------------------------------------------- ! ! compound type ! call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) ! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') +! if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') ! call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f 0') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tinsert_f 0') !!-------------------------------------------------------------------------------------------------- ! ! create Dataset ! call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase') !!-------------------------------------------------------------------------------------------------- ! ! Create memory types (one compound datatype for each member) ! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tcreate_f position_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tcreate_f position_id') ! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tinsert_f position_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tinsert_f position_id') !!-------------------------------------------------------------------------------------------------- ! ! Define and select hyperslabs @@ -517,175 +656,47 @@ end subroutine results_mapping_constituent ! fileOffset = mpiOffset_phase(i) ! where i start to write my data ! call h5screate_simple_f(1, counter, memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5screate_simple_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5screate_simple_f') ! call h5dget_space_f(dset_id, space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dget_space_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5dget_space_f') ! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sselect_hyperslab_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5sselect_hyperslab_f') !!-------------------------------------------------------------------------------------------------- ! ! Create property list for collective dataset write !#ifdef PETSc ! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pcreate_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5pcreate_f') ! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pset_dxpl_mpio_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5pset_dxpl_mpio_f') !#endif !!-------------------------------------------------------------------------------------------------- ! ! write data by fields in the datatype. Fields order is not important. ! call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset, int([dataspace_size(i)],HSIZE_T),& ! hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dwrite_f instance_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5dwrite_f instance_id') !!-------------------------------------------------------------------------------------------------- ! !close types, dataspaces ! call h5tclose_f(dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f dtype_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tclose_f dtype_id') ! call h5tclose_f(position_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5tclose_f position_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5tclose_f position_id') ! call h5dclose_f(dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5dclose_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5dclose_f') ! call h5sclose_f(space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f space_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5sclose_f space_id') ! call h5sclose_f(memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5sclose_f memspace') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5sclose_f memspace') ! call h5pclose_f(plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingPhase: h5pclose_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingPhase: h5pclose_f') ! call HDF5_closeGroup(mapping_ID) ! enddo !end subroutine HDF5_backwardMappingPhase -!!-------------------------------------------------------------------------------------------------- -!!> @brief adds the unique mapping from spatial position and constituent ID to results -!!-------------------------------------------------------------------------------------------------- -!subroutine HDF5_mappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) -! use hdf5 - -! implicit none -! integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat -! character(len=*), intent(in), dimension(:) :: homogenization_name -! integer(pInt), intent(in), dimension(:) :: mpiOffset_homog -! integer(pInt), intent(in) :: dataspace_size, mpiOffset - -! integer(pInt) :: hdferr, NmatPoints, i, j -! integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id, name_id, position_id, plist_id, memspace - -! integer(HID_T) :: dt5_id ! Memory datatype identifier -! integer(SIZE_T) :: typesize, type_sizec, type_sizei, type_size - -! integer(HSIZE_T), dimension(1) :: counter -! integer(HSSIZE_T), dimension(1) :: fileOffset -! integer(pInt), dimension(:), allocatable :: arrOffset - -! NmatPoints = count(material_homog /=0_pInt) -! mapping_ID = results_openGroup("current/mapGeometry") - -! allocate(arrOffset(NmatPoints)) -! do i=1_pInt, NmatPoints -! do j=1_pInt, size(homogenization_name) -! if(material_homog(1,i) == j) & -! arrOffset(i) = mpiOffset_homog(j) -! enddo -! enddo - -!!-------------------------------------------------------------------------------------------------- -!! create dataspace -! call h5screate_simple_f(1, int([dataspace_size],HSIZE_T), space_id, hdferr, & -! int([dataspace_size],HSIZE_T)) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping') - -!!-------------------------------------------------------------------------------------------------- -!! compound type -! ! First calculate total size by calculating sizes of each member -! ! -! CALL h5tcopy_f(H5T_NATIVE_CHARACTER, dt5_id, hdferr) -! typesize = len(homogenization_name(1)) -! CALL h5tset_size_f(dt5_id, typesize, hdferr) -! CALL h5tget_size_f(dt5_id, type_sizec, hdferr) -! CALL h5tget_size_f(H5T_STD_I32LE,type_sizei, hdferr) -! type_size = type_sizec + type_sizei -! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeMapping: h5tcreate_f dtype_id') - -! call h5tinsert_f(dtype_id, "Name", 0_SIZE_T, dt5_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 0') -! call h5tinsert_f(dtype_id, "Position", type_sizec, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f 2') - -!!-------------------------------------------------------------------------------------------------- -!! create Dataset -! call h5dcreate_f(mapping_id, 'homogenization', dtype_id, space_id, dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog') - -!!-------------------------------------------------------------------------------------------------- -!! Create memory types (one compound datatype for each member) -! call h5tcreate_f(H5T_COMPOUND_F, int(type_sizec,SIZE_T), name_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f instance_id') -! call h5tinsert_f(name_id, "Name", 0_SIZE_T, dt5_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f instance_id') - -! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tcreate_f position_id') -! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tinsert_f position_id') - -!!-------------------------------------------------------------------------------------------------- -!! Define and select hyperslabs -! counter = NmatPoints ! how big i am -! fileOffset = mpiOffset ! where i start to write my data - -! call h5screate_simple_f(1, counter, memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5screate_simple_f') -! call h5dget_space_f(dset_id, space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dget_space_f') -! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sselect_hyperslab_f') - -!!-------------------------------------------------------------------------------------------------- -!! Create property list for collective dataset write -!#ifdef PETSc -! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pcreate_f') -! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pset_dxpl_mpio_f') -!#endif - -!!-------------------------------------------------------------------------------------------------- -!! write data by fields in the datatype. Fields order is not important. -! call h5dwrite_f(dset_id, name_id, homogenization_name(pack(material_homog,material_homog/=0_pInt)), & -! int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & -! mem_space_id = memspace, xfer_prp = plist_id) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f position_id') - -! call h5dwrite_f(dset_id, position_id, pack(homogmemberat-1_pInt,homogmemberat/=0_pInt) + arrOffset, & -! int([dataspace_size],HSIZE_T), hdferr, file_space_id = space_id, & -! mem_space_id = memspace, xfer_prp = plist_id) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dwrite_f instance_id') - -!!-------------------------------------------------------------------------------------------------- -!!close types, dataspaces -!call h5tclose_f(dtype_id, hdferr) -!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dtype_id') -!call h5tclose_f(position_id, hdferr) -!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f position_id') -!call h5tclose_f(name_id, hdferr) -!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f name_id ') -!call h5tclose_f(dt5_id, hdferr) -!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5tclose_f dt5_id') -!call h5dclose_f(dset_id, hdferr) -!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5dclose_f') -!call h5sclose_f(space_id, hdferr) -!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f space_id') -!call h5sclose_f(memspace, hdferr) -!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5sclose_f memspace') -!call h5pclose_f(plist_id, hdferr) -!if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomog: h5pclose_f') -!call HDF5_closeGroup(mapping_ID) - -!end subroutine HDF5_mappingHomog !!-------------------------------------------------------------------------------------------------- !!> @brief adds the backward mapping from spatial position and constituent ID to results @@ -710,13 +721,13 @@ end subroutine results_mapping_constituent ! character(len=64) :: homogID -! NmatPoints = count(material_homog /=0_pInt) +! NmatPoints = count(material_homog /=0) ! allocate(arr(2,NmatPoints)) -! arr(1,:) = (/(i, i=0_pint,NmatPoints-1_pInt)/) -! arr(2,:) = pack(material_homog,material_homog/=0_pInt) +! arr(1,:) = (/(i, i=0,NmatPoints-1)/) +! arr(2,:) = pack(material_homog,material_homog/=0) -! do i=1_pInt, size(homogenization_name) +! do i=1, size(homogenization_name) ! write(homogID, '(i0)') i ! mapping_ID = results_openGroup('/current/homogenization/'//trim(homogID)//'_'//homogenization_name(i)) @@ -724,28 +735,28 @@ end subroutine results_mapping_constituent ! ! create dataspace ! call h5screate_simple_f(1, int([dataspace_size(i)],HSIZE_T), space_id, hdferr, & ! int([dataspace_size(i)],HSIZE_T)) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping') +! if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping') !!-------------------------------------------------------------------------------------------------- ! ! compound type ! call h5tget_size_f(H5T_STD_I32LE, type_size, hdferr) ! call h5tcreate_f(H5T_COMPOUND_F, type_size, dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') +! if (hdferr < 0) call IO_error(1,ext_msg='HDF5_writeBackwardMapping: h5tcreate_f dtype_id') ! call h5tinsert_f(dtype_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f 0') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tinsert_f 0') !!-------------------------------------------------------------------------------------------------- ! ! create Dataset ! call h5dcreate_f(mapping_id, 'mapGeometry', dtype_id, space_id, dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog') !!-------------------------------------------------------------------------------------------------- ! ! Create memory types (one compound datatype for each member) ! call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), position_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tcreate_f position_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tcreate_f position_id') ! call h5tinsert_f(position_id, "Position", 0_SIZE_T, H5T_STD_I32LE, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tinsert_f position_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tinsert_f position_id') !!-------------------------------------------------------------------------------------------------- ! ! Define and select hyperslabs @@ -753,41 +764,41 @@ end subroutine results_mapping_constituent ! fileOffset = mpiOffset_homog(i) ! where i start to write my data ! call h5screate_simple_f(1, counter, memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5screate_simple_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5screate_simple_f') ! call h5dget_space_f(dset_id, space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dget_space_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5dget_space_f') ! call h5sselect_hyperslab_f(space_id, H5S_SELECT_SET_F, fileOffset, counter, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sselect_hyperslab_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5sselect_hyperslab_f') !!-------------------------------------------------------------------------------------------------- ! ! Create property list for collective dataset write !#ifdef PETSc ! call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pcreate_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5pcreate_f') ! call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pset_dxpl_mpio_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5pset_dxpl_mpio_f') !#endif !!-------------------------------------------------------------------------------------------------- ! ! write data by fields in the datatype. Fields order is not important. ! call h5dwrite_f(dset_id, position_id, pack(arr(1,:),arr(2,:)==i)+mpiOffset,int([dataspace_size(i)],HSIZE_T),& ! hdferr, file_space_id = space_id, mem_space_id = memspace, xfer_prp = plist_id) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dwrite_f instance_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5dwrite_f instance_id') !!-------------------------------------------------------------------------------------------------- ! !close types, dataspaces ! call h5tclose_f(dtype_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f dtype_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tclose_f dtype_id') ! call h5tclose_f(position_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5tclose_f position_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5tclose_f position_id') ! call h5dclose_f(dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5dclose_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5dclose_f') ! call h5sclose_f(space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f space_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5sclose_f space_id') ! call h5sclose_f(memspace, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5sclose_f memspace') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5sclose_f memspace') ! call h5pclose_f(plist_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_backwardMappingHomog: h5pclose_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_backwardMappingHomog: h5pclose_f') ! call HDF5_closeGroup(mapping_ID) ! enddo @@ -814,24 +825,24 @@ end subroutine results_mapping_constituent !! create dataspace ! call h5screate_simple_f(1, int([Nnodes],HSIZE_T), space_id, hdferr, & ! int([Nnodes],HSIZE_T)) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5screate_simple_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingCells: h5screate_simple_f') !!-------------------------------------------------------------------------------------------------- !! create Dataset ! call h5dcreate_f(mapping_id, "Cell",H5T_NATIVE_INTEGER, space_id, dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingCells') !!-------------------------------------------------------------------------------------------------- !! write data by fields in the datatype. Fields order is not important. ! call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER, mapping, int([Nnodes],HSIZE_T), hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCells: h5dwrite_f instance_id') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingCells: h5dwrite_f instance_id') !!-------------------------------------------------------------------------------------------------- !!close types, dataspaces ! call h5dclose_f(dset_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5dclose_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingConstitutive: h5dclose_f') ! call h5sclose_f(space_id, hdferr) -! if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5sclose_f') +! if (hdferr < 0) call IO_error(1,ext_msg='IO_mappingConstitutive: h5sclose_f') ! call HDF5_closeGroup(mapping_ID) !end subroutine HDF5_mappingCells From adebbcf5dfee76420af7c07c4895dbfbe3440016 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 5 Apr 2019 20:14:01 +0200 Subject: [PATCH 11/97] preprocessor statements confuse cmake --- .gitlab-ci.yml | 2 -- PRIVATE | 2 +- src/plastic_isotropic.f90 | 7 ++++--- src/plastic_kinematichardening.f90 | 7 ++++--- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 45fb4e4f4..1e1b8fe49 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -444,8 +444,6 @@ J2_plasticBehavior: grid_all_example: stage: example script: grid_all_example/test.py - only: - - development ################################################################################################### SpectralRuntime: diff --git a/PRIVATE b/PRIVATE index c7bc54a26..1d1dc5c20 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit c7bc54a26c8b6ed404aabec4653227e93fa028e2 +Subproject commit 1d1dc5c200e4723f501c3cb7a09ce74f5d6fe6b2 diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 05a31ab75..d7b071baa 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -92,9 +92,6 @@ subroutine plastic_isotropic_init use IO, only: & IO_error use material, only: & -#ifdef DEBUG - phasememberAt, & -#endif phase_plasticity, & phase_plasticityInstance, & phase_Noutput, & @@ -103,6 +100,10 @@ subroutine plastic_isotropic_init PLASTICITY_ISOTROPIC_ID, & material_phase, & plasticState +#ifdef DEBUG + use material, only: & + phasememberAt +#endif use config, only: & config_phase use lattice diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 0a4a6b3bc..ed21b09f7 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -113,9 +113,6 @@ subroutine plastic_kinehardening_init use IO, only: & IO_error use material, only: & -#ifdef DEBUG - phasememberAt, & -#endif phase_plasticity, & phase_plasticityInstance, & phase_Noutput, & @@ -124,6 +121,10 @@ subroutine plastic_kinehardening_init PLASTICITY_kinehardening_ID, & material_phase, & plasticState +#ifdef DEBUG + use material, only: & + phasememberAt +#endif use config, only: & config_phase use lattice From 4aa52fa83f71cfb63f97bf5ce73571e32706c9e2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 5 Apr 2019 20:45:56 +0200 Subject: [PATCH 12/97] no pInt --- src/homogenization.f90 | 91 +++--- src/homogenization_RGC.f90 | 499 +++++++++++++++---------------- src/homogenization_isostrain.f90 | 22 +- 3 files changed, 297 insertions(+), 315 deletions(-) diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 06c8bd44c..919680d6e 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -6,7 +6,6 @@ !-------------------------------------------------------------------------------------------------- module homogenization use prec, only: & - pInt, & pReal !-------------------------------------------------------------------------------------------------- @@ -21,7 +20,7 @@ module homogenization materialpoint_dPdF !< tangent of first P--K stress at IP real(pReal), dimension(:,:,:), allocatable, public :: & materialpoint_results !< results array of material point - integer(pInt), public, protected :: & + integer, public, protected :: & materialpoint_sizeResults, & homogenization_maxSizePostResults, & thermal_maxSizePostResults, & @@ -92,10 +91,10 @@ subroutine homogenization_init worldrank implicit none - integer(pInt), parameter :: FILEUNIT = 200_pInt - integer(pInt) :: e,i,p - integer(pInt), dimension(:,:), pointer :: thisSize - integer(pInt), dimension(:) , pointer :: thisNoutput + integer, parameter :: FILEUNIT = 200 + integer :: e,i,p + integer, dimension(:,:), pointer :: thisSize + integer, dimension(:) , pointer :: thisNoutput character(len=64), dimension(:,:), pointer :: thisOutput character(len=32) :: outputName !< name of output, intermediate fix until HDF5 output is ready logical :: valid @@ -232,9 +231,9 @@ subroutine homogenization_init !-------------------------------------------------------------------------------------------------- ! allocate and initialize global state and postresutls variables - homogenization_maxSizePostResults = 0_pInt - thermal_maxSizePostResults = 0_pInt - damage_maxSizePostResults = 0_pInt + homogenization_maxSizePostResults = 0 + thermal_maxSizePostResults = 0 + damage_maxSizePostResults = 0 do p = 1,size(config_homogenization) homogenization_maxSizePostResults = max(homogenization_maxSizePostResults,homogState (p)%sizePostResults) thermal_maxSizePostResults = max(thermal_maxSizePostResults, thermalState (p)%sizePostResults) @@ -252,7 +251,7 @@ subroutine homogenization_init write(6,'(/,a)') ' <<<+- homogenization init -+>>>' - if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0) then #ifdef TODO write(6,'(a32,1x,7(i8,1x))') 'homogenization_state0: ', shape(homogenization_state0) write(6,'(a32,1x,7(i8,1x))') 'homogenization_subState0: ', shape(homogenization_subState0) @@ -275,7 +274,7 @@ subroutine homogenization_init flush(6) if (debug_g < 1 .or. debug_g > homogenization_Ngrains(mesh_element(3,debug_e))) & - call IO_error(602_pInt,ext_msg='constituent', el=debug_e, g=debug_g) + call IO_error(602,ext_msg='constituent', el=debug_e, g=debug_g) end subroutine homogenization_init @@ -344,7 +343,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) implicit none real(pReal), intent(in) :: dt !< time increment logical, intent(in) :: updateJaco !< initiating Jacobian update - integer(pInt) :: & + integer :: & NiterationHomog, & NiterationMPstate, & g, & !< grain number @@ -354,7 +353,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) myNgrains #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0) then write(6,'(/a,i5,1x,i2)') '<< HOMOG >> Material Point start at el ip ', debug_e, debug_i write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< HOMOG >> F0', & @@ -372,7 +371,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) plasticState (phaseAt(g,i,e))%partionedState0(:,phasememberAt(g,i,e)) = & plasticState (phaseAt(g,i,e))%state0( :,phasememberAt(g,i,e)) - do mySource = 1_pInt, phase_Nsources(phaseAt(g,i,e)) + do mySource = 1, phase_Nsources(phaseAt(g,i,e)) sourceState(phaseAt(g,i,e))%p(mySource)%partionedState0(:,phasememberAt(g,i,e)) = & sourceState(phaseAt(g,i,e))%p(mySource)%state0( :,phasememberAt(g,i,e)) enddo @@ -393,19 +392,19 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) materialpoint_requested(i,e) = .true. ! everybody requires calculation endforall forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - homogState(material_homogenizationAt(e))%sizeState > 0_pInt) & + homogState(material_homogenizationAt(e))%sizeState > 0) & homogState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & homogState(material_homogenizationAt(e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal homogenization state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - thermalState(material_homogenizationAt(e))%sizeState > 0_pInt) & + thermalState(material_homogenizationAt(e))%sizeState > 0) & thermalState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & thermalState(material_homogenizationAt(e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal thermal state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - damageState(material_homogenizationAt(e))%sizeState > 0_pInt) & + damageState(material_homogenizationAt(e))%sizeState > 0) & damageState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & damageState(material_homogenizationAt(e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal damage state enddo - NiterationHomog = 0_pInt + NiterationHomog = 0 cutBackLooping: do while (.not. terminallyIll .and. & any(materialpoint_subStep(:,FEsolving_execELem(1):FEsolving_execElem(2)) > subStepMinHomog)) @@ -417,9 +416,9 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) converged: if ( materialpoint_converged(i,e) ) then #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0 & .and. ((e == debug_e .and. i == debug_i) & - .or. .not. iand(debug_level(debug_homogenization),debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_homogenization),debug_levelSelective) /= 0)) then write(6,'(a,1x,f12.8,1x,a,1x,f12.8,1x,a,i8,1x,i2/)') '<< HOMOG >> winding forward from', & materialpoint_subFrac(i,e), 'to current materialpoint_subFrac', & materialpoint_subFrac(i,e)+materialpoint_subStep(i,e),'in materialpoint_stressAndItsTangent at el ip',e,i @@ -456,29 +455,29 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) do g = 1,myNgrains plasticState (phaseAt(g,i,e))%partionedState0(:,phasememberAt(g,i,e)) = & plasticState (phaseAt(g,i,e))%state( :,phasememberAt(g,i,e)) - do mySource = 1_pInt, phase_Nsources(phaseAt(g,i,e)) + do mySource = 1, phase_Nsources(phaseAt(g,i,e)) sourceState(phaseAt(g,i,e))%p(mySource)%partionedState0(:,phasememberAt(g,i,e)) = & sourceState(phaseAt(g,i,e))%p(mySource)%state( :,phasememberAt(g,i,e)) enddo enddo forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - homogState(material_homogenizationAt(e))%sizeState > 0_pInt) & + homogState(material_homogenizationAt(e))%sizeState > 0) & homogState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & homogState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) ! ...internal homogenization state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - thermalState(material_homogenizationAt(e))%sizeState > 0_pInt) & + thermalState(material_homogenizationAt(e))%sizeState > 0) & thermalState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & thermalState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) ! ...internal thermal state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - damageState(material_homogenizationAt(e))%sizeState > 0_pInt) & + damageState(material_homogenizationAt(e))%sizeState > 0) & damageState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) = & damageState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) ! ...internal damage state materialpoint_subF0(1:3,1:3,i,e) = materialpoint_subF(1:3,1:3,i,e) ! ...def grad endif steppingNeeded else converged - if ( (myNgrains == 1_pInt .and. materialpoint_subStep(i,e) <= 1.0 ) .or. & ! single grain already tried internal subStepping in crystallite + if ( (myNgrains == 1 .and. materialpoint_subStep(i,e) <= 1.0 ) .or. & ! single grain already tried internal subStepping in crystallite subStepSizeHomog * materialpoint_subStep(i,e) <= subStepMinHomog ) then ! would require too small subStep ! cutback makes no sense !$OMP FLUSH(terminallyIll) @@ -494,9 +493,9 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) materialpoint_subStep(i,e) = subStepSizeHomog * materialpoint_subStep(i,e) ! crystallite had severe trouble, so do a significant cutback #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0 & .and. ((e == debug_e .and. i == debug_i) & - .or. .not. iand(debug_level(debug_homogenization), debug_levelSelective) /= 0_pInt)) then + .or. .not. iand(debug_level(debug_homogenization), debug_levelSelective) /= 0)) then write(6,'(a,1x,f12.8,a,i8,1x,i2/)') & '<< HOMOG >> cutback step in materialpoint_stressAndItsTangent with new materialpoint_subStep:',& materialpoint_subStep(i,e),' at el ip',e,i @@ -518,21 +517,21 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) do g = 1, myNgrains plasticState (phaseAt(g,i,e))%state( :,phasememberAt(g,i,e)) = & plasticState (phaseAt(g,i,e))%partionedState0(:,phasememberAt(g,i,e)) - do mySource = 1_pInt, phase_Nsources(phaseAt(g,i,e)) + do mySource = 1, phase_Nsources(phaseAt(g,i,e)) sourceState(phaseAt(g,i,e))%p(mySource)%state( :,phasememberAt(g,i,e)) = & sourceState(phaseAt(g,i,e))%p(mySource)%partionedState0(:,phasememberAt(g,i,e)) enddo enddo forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - homogState(material_homogenizationAt(e))%sizeState > 0_pInt) & + homogState(material_homogenizationAt(e))%sizeState > 0) & homogState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) = & homogState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal homogenization state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - thermalState(material_homogenizationAt(e))%sizeState > 0_pInt) & + thermalState(material_homogenizationAt(e))%sizeState > 0) & thermalState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) = & thermalState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal thermal state forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & - damageState(material_homogenizationAt(e))%sizeState > 0_pInt) & + damageState(material_homogenizationAt(e))%sizeState > 0) & damageState(material_homogenizationAt(e))%State( :,mappingHomogenization(1,i,e)) = & damageState(material_homogenizationAt(e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal damage state endif @@ -550,7 +549,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) enddo elementLooping1 !$OMP END PARALLEL DO - NiterationMPstate = 0_pInt + NiterationMPstate = 0 convergenceLooping: do while (.not. terminallyIll .and. & any( materialpoint_requested(:,FEsolving_execELem(1):FEsolving_execElem(2)) & @@ -606,7 +605,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) enddo convergenceLooping - NiterationHomog = NiterationHomog + 1_pInt + NiterationHomog = NiterationHomog + 1 enddo cutBackLooping @@ -652,7 +651,7 @@ subroutine materialpoint_postResults crystallite_postResults implicit none - integer(pInt) :: & + integer :: & thePos, & theSize, & myNgrains, & @@ -666,21 +665,21 @@ subroutine materialpoint_postResults myNgrains = homogenization_Ngrains(mesh_element(3,e)) myCrystallite = microstructure_crystallite(mesh_element(4,e)) IpLooping: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - thePos = 0_pInt + thePos = 0 theSize = homogState (material_homogenizationAt(e))%sizePostResults & + thermalState (material_homogenizationAt(e))%sizePostResults & + damageState (material_homogenizationAt(e))%sizePostResults materialpoint_results(thePos+1,i,e) = real(theSize,pReal) ! tell size of homogenization results - thePos = thePos + 1_pInt + thePos = thePos + 1 - if (theSize > 0_pInt) then ! any homogenization results to mention? + if (theSize > 0) then ! any homogenization results to mention? materialpoint_results(thePos+1:thePos+theSize,i,e) = postResults(i,e) ! tell homogenization results thePos = thePos + theSize endif materialpoint_results(thePos+1,i,e) = real(myNgrains,pReal) ! tell number of grains at materialpoint - thePos = thePos + 1_pInt + thePos = thePos + 1 grainLooping :do g = 1,myNgrains theSize = 1 + crystallite_sizePostResults(myCrystallite) + & @@ -716,7 +715,7 @@ subroutine partitionDeformation(ip,el) homogenization_RGC_partitionDeformation implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ip, & !< integration point el !< element number @@ -769,7 +768,7 @@ function updateState(ip,el) damage_local_updateState implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ip, & !< integration point el !< element number logical, dimension(2) :: updateState @@ -831,7 +830,7 @@ subroutine averageStressAndItsTangent(ip,el) homogenization_RGC_averageStressAndItsTangent implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ip, & !< integration point el !< element number @@ -900,20 +899,20 @@ function postResults(ip,el) damage_nonlocal_postResults implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ip, & !< integration point el !< element number real(pReal), dimension( homogState (material_homogenizationAt(el))%sizePostResults & + thermalState (material_homogenizationAt(el))%sizePostResults & + damageState (material_homogenizationAt(el))%sizePostResults) :: & postResults - integer(pInt) :: & + integer :: & startPos, endPos ,& of, instance, homog postResults = 0.0_pReal - startPos = 1_pInt + startPos = 1 endPos = homogState(material_homogenizationAt(el))%sizePostResults chosenHomogenization: select case (homogenization_type(mesh_element(3,el))) @@ -924,7 +923,7 @@ function postResults(ip,el) end select chosenHomogenization - startPos = endPos + 1_pInt + startPos = endPos + 1 endPos = endPos + thermalState(material_homogenizationAt(el))%sizePostResults chosenThermal: select case (thermal_type(mesh_element(3,el))) @@ -939,7 +938,7 @@ function postResults(ip,el) end select chosenThermal - startPos = endPos + 1_pInt + startPos = endPos + 1 endPos = endPos + damageState(material_homogenizationAt(el))%sizePostResults chosenDamage: select case (damage_type(mesh_element(3,el))) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 6a513193b..26eadf4f9 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -13,9 +13,9 @@ module homogenization_RGC implicit none private - integer(pInt), dimension(:,:), allocatable,target, public :: & + integer, dimension(:,:), allocatable,target, public :: & homogenization_RGC_sizePostResult - character(len=64), dimension(:,:), allocatable,target, public :: & + character(len=64), dimension(:,:), allocatable,target, public :: & homogenization_RGC_output ! name of each post result output enum, bind(c) @@ -30,7 +30,7 @@ module homogenization_RGC end enum type, private :: tParameters - integer(pInt), dimension(:), allocatable :: & + integer, dimension(:), allocatable :: & Nconstituents real(pReal) :: & xiAlpha, & @@ -38,8 +38,8 @@ module homogenization_RGC real(pReal), dimension(:), allocatable :: & dAlpha, & angles - integer(pInt) :: & - of_debug = 0_pInt + integer :: & + of_debug = 0 integer(kind(undefined_ID)), dimension(:), allocatable :: & outputID end type tParameters @@ -121,7 +121,7 @@ subroutine homogenization_RGC_init() config_homogenization implicit none - integer(pInt) :: & + integer :: & Ninstance, & h, i, & NofMyHomog, outputSize, & @@ -152,11 +152,11 @@ subroutine homogenization_RGC_init() allocate(state0(Ninstance)) allocate(dependentState(Ninstance)) - allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),Ninstance),source=0_pInt) + allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),Ninstance),source=0) allocate(homogenization_RGC_output(maxval(homogenization_Noutput),Ninstance)) homogenization_RGC_output='' - do h = 1_pInt, size(homogenization_type) + do h = 1, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_RGC_ID) cycle associate(prm => param(homogenization_typeInstance(h)), & stt => state(homogenization_typeInstance(h)), & @@ -172,7 +172,7 @@ subroutine homogenization_RGC_init() prm%Nconstituents = config%getInts('clustersize',requiredSize=3) if (homogenization_Ngrains(h) /= product(prm%Nconstituents)) & - call IO_error(211_pInt,ext_msg='clustersize ('//HOMOGENIZATION_RGC_label//')') + call IO_error(211,ext_msg='clustersize ('//HOMOGENIZATION_RGC_label//')') prm%xiAlpha = config%getFloat('scalingparameter') prm%ciAlpha = config%getFloat('overproportionality') @@ -183,28 +183,28 @@ subroutine homogenization_RGC_init() outputs = config%getStrings('(output)',defaultVal=emptyStringArray) allocate(prm%outputID(0)) - do i=1_pInt, size(outputs) + do i=1, size(outputs) outputID = undefined_ID select case(outputs(i)) case('constitutivework') outputID = constitutivework_ID - outputSize = 1_pInt + outputSize = 1 case('penaltyenergy') outputID = penaltyenergy_ID - outputSize = 1_pInt + outputSize = 1 case('volumediscrepancy') outputID = volumediscrepancy_ID - outputSize = 1_pInt + outputSize = 1 case('averagerelaxrate') outputID = averagerelaxrate_ID - outputSize = 1_pInt + outputSize = 1 case('maximumrelaxrate') outputID = maximumrelaxrate_ID - outputSize = 1_pInt + outputSize = 1 case('magnitudemismatch') outputID = magnitudemismatch_ID - outputSize = 3_pInt + outputSize = 3 end select @@ -217,9 +217,9 @@ subroutine homogenization_RGC_init() enddo NofMyHomog = count(material_homogenizationAt == h) - nIntFaceTot = 3_pInt*( (prm%Nconstituents(1)-1_pInt)*prm%Nconstituents(2)*prm%Nconstituents(3) & - + prm%Nconstituents(1)*(prm%Nconstituents(2)-1_pInt)*prm%Nconstituents(3) & - + prm%Nconstituents(1)*prm%Nconstituents(2)*(prm%Nconstituents(3)-1_pInt)) + nIntFaceTot = 3*( (prm%Nconstituents(1)-1)*prm%Nconstituents(2)*prm%Nconstituents(3) & + + prm%Nconstituents(1)*(prm%Nconstituents(2)-1)*prm%Nconstituents(3) & + + prm%Nconstituents(1)*prm%Nconstituents(2)*(prm%Nconstituents(3)-1)) sizeState = nIntFaceTot & + size(['avg constitutive work ','average penalty energy']) @@ -266,36 +266,36 @@ subroutine homogenization_RGC_partitionDeformation(F,avgF,instance,of) real(pReal), dimension (:,:,:), intent(out) :: F !< partioned F per grain real(pReal), dimension (:,:), intent(in) :: avgF !< averaged F - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of - real(pReal), dimension (3) :: aVect,nVect - integer(pInt), dimension (4) :: intFace - integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: iGrain,iFace,i,j + real(pReal), dimension(3) :: aVect,nVect + integer, dimension(4) :: intFace + integer, dimension(3) :: iGrain3 + integer :: iGrain,iFace,i,j associate(prm => param(instance)) !-------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations F = 0.0_pReal - do iGrain = 1_pInt,product(prm%Nconstituents) + do iGrain = 1,product(prm%Nconstituents) iGrain3 = grain1to3(iGrain,prm%Nconstituents) - do iFace = 1_pInt,6_pInt + do iFace = 1,6 intFace = getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain aVect = relaxationVector(intFace,instance,of) ! get the relaxation vectors for each interface from global relaxation vector array nVect = interfaceNormal(intFace,instance,of) - forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + forall (i=1:3,j=1:3) & F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! calculating deformation relaxations due to interface relaxation enddo F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! resulting relaxed deformation gradient #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0) then write(6,'(1x,a32,1x,i3)')'Deformation gradient of grain: ',iGrain - do i = 1_pInt,3_pInt - write(6,'(1x,3(e15.8,1x))')(F(i,j,iGrain), j = 1_pInt,3_pInt) + do i = 1,3 + write(6,'(1x,3(e15.8,1x))')(F(i,j,iGrain), j = 1,3) enddo write(6,*)' ' flush(6) @@ -340,32 +340,32 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) implicit none - real(pReal), dimension (:,:,:), intent(in) :: & + real(pReal), dimension(:,:,:), intent(in) :: & P,& !< array of P F,& !< array of F F0 !< array of initial F - real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< array of current grain stiffness - real(pReal), dimension (3,3), intent(in) :: avgF !< average F - real(pReal), intent(in) :: dt !< time increment - integer(pInt), intent(in) :: & + real(pReal), dimension(:,:,:,:,:), intent(in) :: dPdF !< array of current grain stiffness + real(pReal), dimension(3,3), intent(in) :: avgF !< average F + real(pReal), intent(in) :: dt !< time increment + integer, intent(in) :: & ip, & !< integration point number el !< element number - logical, dimension(2) :: homogenization_RGC_updateState + logical, dimension(2) :: homogenization_RGC_updateState - integer(pInt), dimension (4) :: intFaceN,intFaceP,faceID - integer(pInt), dimension (3) :: nGDim,iGr3N,iGr3P - integer(pInt) :: instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain, of - real(pReal), dimension (3,3,size(P,3)) :: R,pF,pR,D,pD - real(pReal), dimension (3,size(P,3)) :: NN,devNull - real(pReal), dimension (3) :: normP,normN,mornP,mornN + integer, dimension(4) :: intFaceN,intFaceP,faceID + integer, dimension(3) :: nGDim,iGr3N,iGr3P + integer :: instance,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain, of + real(pReal), dimension(3,3,size(P,3)) :: R,pF,pR,D,pD + real(pReal), dimension(3,size(P,3)) :: NN,devNull + real(pReal), dimension(3) :: normP,normN,mornP,mornN real(pReal) :: residMax,stresMax logical :: error real(pReal), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix real(pReal), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax #ifdef DEBUG - integer(pInt), dimension (3) :: stresLoc - integer(pInt), dimension (2) :: residLoc + integer, dimension(3) :: stresLoc + integer, dimension(2) :: residLoc #endif zeroTimeStep: if(dEq0(dt)) then @@ -382,21 +382,21 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! get the dimension of the cluster (grains and interfaces) nGDim = prm%Nconstituents nGrain = product(nGDim) - nIntFaceTot = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) & - + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) & - + nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) + nIntFaceTot = (nGDim(1)-1)*nGDim(2)*nGDim(3) & + + nGDim(1)*(nGDim(2)-1)*nGDim(3) & + + nGDim(1)*nGDim(2)*(nGDim(3)-1) !-------------------------------------------------------------------------------------------------- ! allocate the size of the global relaxation arrays/jacobian matrices depending on the size of the cluster - allocate(resid(3_pInt*nIntFaceTot), source=0.0_pReal) + allocate(resid(3*nIntFaceTot), source=0.0_pReal) allocate(tract(nIntFaceTot,3), source=0.0_pReal) relax = stt%relaxationVector(:,of) drelax = stt%relaxationVector(:,of) - st0%relaxationVector(:,of) #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Obtained state: ' - do i = 1_pInt,size(stt%relaxationVector(:,of)) + do i = 1,size(stt%relaxationVector(:,of)) write(6,'(1x,2(e15.8,1x))') stt%relaxationVector(i,of) enddo write(6,*)' ' @@ -412,15 +412,15 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) call volumePenalty(D,dst%volumeDiscrepancy(of),avgF,F,nGrain,instance,of) #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then - do iGrain = 1_pInt,nGrain + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0) then + do iGrain = 1,nGrain write(6,'(1x,a30,1x,i3,1x,a4,3(1x,e15.8))')'Mismatch magnitude of grain(',iGrain,') :',& NN(1,iGrain),NN(2,iGrain),NN(3,iGrain) write(6,'(/,1x,a30,1x,i3)')'Stress and penalties of grain: ',iGrain - do i = 1_pInt,3_pInt - write(6,'(1x,3(e15.8,1x),1x,3(e15.8,1x),1x,3(e15.8,1x))')(P(i,j,iGrain), j = 1_pInt,3_pInt), & - (R(i,j,iGrain), j = 1_pInt,3_pInt), & - (D(i,j,iGrain), j = 1_pInt,3_pInt) + do i = 1,3 + write(6,'(1x,3(e15.8,1x),1x,3(e15.8,1x),1x,3(e15.8,1x))')(P(i,j,iGrain), j = 1,3), & + (R(i,j,iGrain), j = 1,3), & + (D(i,j,iGrain), j = 1,3) enddo write(6,*)' ' enddo @@ -429,40 +429,40 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !------------------------------------------------------------------------------------------------ ! computing the residual stress from the balance of traction at all (interior) interfaces - do iNum = 1_pInt,nIntFaceTot - faceID = interface1to4(iNum,param(instance)%Nconstituents) ! identifying the interface ID in local coordinate system (4-dimensional index) + do iNum = 1,nIntFaceTot + faceID = interface1to4(iNum,param(instance)%Nconstituents) ! identifying the interface ID in local coordinate system (4-dimensional index) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceN = getInterface(2_pInt*faceID(1),iGr3N) + iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceN = getInterface(2*faceID(1),iGr3N) normN = interfaceNormal(intFaceN,instance,of) !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) iGr3P = iGr3N - iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate system (3-dimensional index) - iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) + iGr3P(faceID(1)) = iGr3N(faceID(1))+1 ! identifying the grain ID in local coordinate system (3-dimensional index) + iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceP = getInterface(2*faceID(1)-1,iGr3P) normP = interfaceNormal(intFaceP,instance,of) !-------------------------------------------------------------------------------------------------- ! compute the residual of traction at the interface (in local system, 4-dimensional index) - do i = 1_pInt,3_pInt - tract(iNum,i) = sign(viscModus_RGC*(abs(drelax(i+3*(iNum-1_pInt)))/(refRelaxRate_RGC*dt))**viscPower_RGC, & - drelax(i+3*(iNum-1_pInt))) ! contribution from the relaxation viscosity - do j = 1_pInt,3_pInt + do i = 1,3 + tract(iNum,i) = sign(viscModus_RGC*(abs(drelax(i+3*(iNum-1)))/(refRelaxRate_RGC*dt))**viscPower_RGC, & + drelax(i+3*(iNum-1))) ! contribution from the relaxation viscosity + do j = 1,3 tract(iNum,i) = tract(iNum,i) + (P(i,j,iGrP) + R(i,j,iGrP) + D(i,j,iGrP))*normP(j) & ! contribution from material stress P, mismatch penalty R, and volume penalty D projected into the interface + (P(i,j,iGrN) + R(i,j,iGrN) + D(i,j,iGrN))*normN(j) - resid(i+3_pInt*(iNum-1_pInt)) = tract(iNum,i) ! translate the local residual into global 1-dimensional residual array + resid(i+3*(iNum-1)) = tract(iNum,i) ! translate the local residual into global 1-dimensional residual array enddo enddo #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0) then write(6,'(1x,a30,1x,i3)')'Traction at interface: ',iNum - write(6,'(1x,3(e15.8,1x))')(tract(iNum,j), j = 1_pInt,3_pInt) + write(6,'(1x,3(e15.8,1x))')(tract(iNum,j), j = 1,3) write(6,*)' ' endif #endif @@ -474,10 +474,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) residMax = maxval(abs(tract)) ! get the maximum of the residual #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of) then - stresLoc = int(maxloc(abs(P)),pInt) ! get the location of the maximum stress - residLoc = int(maxloc(abs(tract)),pInt) ! get the position of the maximum residual + stresLoc = maxloc(abs(P)) + residLoc = maxloc(abs(tract)) write(6,'(1x,a)')' ' write(6,'(1x,a,1x,i2,1x,i4)')'RGC residual check ...',ip,el write(6,'(1x,a15,1x,e15.8,1x,a7,i3,1x,a12,i2,i2)')'Max stress: ',stresMax, & @@ -495,15 +495,15 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) if (residMax < relTol_RGC*stresMax .or. residMax < absTol_RGC) then homogenization_RGC_updateState = .true. #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of) write(6,'(1x,a55,/)')'... done and happy' flush(6) #endif !-------------------------------------------------------------------------------------------------- ! compute/update the state for postResult, i.e., all energy densities computed by time-integration - do iGrain = 1_pInt,product(prm%Nconstituents) - do i = 1_pInt,3_pInt;do j = 1_pInt,3_pInt + do iGrain = 1,product(prm%Nconstituents) + do i = 1,3;do j = 1,3 stt%work(of) = stt%work(of) & + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) stt%penaltyEnergy(of) = stt%penaltyEnergy(of) & @@ -512,11 +512,11 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo dst%mismatch(1:3,of) = sum(NN,2)/real(nGrain,pReal) - dst%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) + dst%relaxationRate_avg(of) = sum(abs(drelax))/dt/real(3*nIntFaceTot,pReal) dst%relaxationRate_max(of) = maxval(abs(drelax))/dt #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of) then write(6,'(1x,a30,1x,e15.8)') 'Constitutive work: ',stt%work(of) write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',dst%mismatch(1,of), & @@ -538,7 +538,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) homogenization_RGC_updateState = [.true.,.false.] ! with direct cut-back #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of) write(6,'(1x,a,/)') '... broken' flush(6) #endif @@ -547,7 +547,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) else ! proceed with computing the Jacobian and state update #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of) write(6,'(1x,a,/)') '... not yet done' flush(6) #endif @@ -561,21 +561,21 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! ... of the constitutive stress tangent, assembled from dPdF or material constitutive model "smatrix" allocate(smatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) - do iNum = 1_pInt,nIntFaceTot + do iNum = 1,nIntFaceTot faceID = interface1to4(iNum,param(instance)%Nconstituents) ! assembling of local dPdF into global Jacobian matrix !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identifying the grain ID in local coordinate sytem iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate into global grain ID - intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system + intFaceN = getInterface(2*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system normN = interfaceNormal(intFaceN,instance,of) - do iFace = 1_pInt,6_pInt + do iFace = 1,6 intFaceN = getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface mornN = interfaceNormal(intFaceN,instance,of) iMun = interface4to1(intFaceN,param(instance)%Nconstituents) ! translate the interfaces ID into local 4-dimensional index if (iMun > 0) then ! get the corresponding tangent - do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt + do i=1,3; do j=1,3; do k=1,3; do l=1,3 smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) & + dPdF(i,k,j,l,iGrN)*normN(k)*mornN(l) enddo;enddo;enddo;enddo @@ -587,16 +587,16 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) iGr3P = iGr3N - iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identifying the grain ID in local coordinate sytem + iGr3P(faceID(1)) = iGr3N(faceID(1))+1 ! identifying the grain ID in local coordinate sytem iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate into global grain ID - intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system + intFaceP = getInterface(2*faceID(1)-1,iGr3P) ! identifying the connecting interface in local coordinate system normP = interfaceNormal(intFaceP,instance,of) - do iFace = 1_pInt,6_pInt + do iFace = 1,6 intFaceP = getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface mornP = interfaceNormal(intFaceP,instance,of) iMun = interface4to1(intFaceP,param(instance)%Nconstituents) ! translate the interfaces ID into local 4-dimensional index - if (iMun > 0_pInt) then ! get the corresponding tangent - do i=1_pInt,3_pInt; do j=1_pInt,3_pInt; do k=1_pInt,3_pInt; do l=1_pInt,3_pInt + if (iMun > 0) then ! get the corresponding tangent + do i=1,3; do j=1,3; do k=1,3; do l=1,3 smatrix(3*(iNum-1)+i,3*(iMun-1)+j) = smatrix(3*(iNum-1)+i,3*(iMun-1)+j) & + dPdF(i,k,j,l,iGrP)*normP(k)*mornP(l) enddo;enddo;enddo;enddo @@ -605,10 +605,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Jacobian matrix of stress' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,100(e11.4,1x))')(smatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) + do i = 1,3*nIntFaceTot + write(6,'(1x,100(e11.4,1x))')(smatrix(i,j), j = 1,3*nIntFaceTot) enddo write(6,*)' ' flush(6) @@ -622,7 +622,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) allocate(p_relax(3*nIntFaceTot), source=0.0_pReal) allocate(p_resid(3*nIntFaceTot), source=0.0_pReal) - do ipert = 1_pInt,3_pInt*nIntFaceTot + do ipert = 1,3*nIntFaceTot p_relax = relax p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector stt%relaxationVector(:,of) = p_relax @@ -633,28 +633,28 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing the global stress residual array from the perturbed state p_resid = 0.0_pReal - do iNum = 1_pInt,nIntFaceTot + do iNum = 1,nIntFaceTot faceID = interface1to4(iNum,param(instance)%Nconstituents) ! identifying the interface ID in local coordinate system (4-dimensional index) !-------------------------------------------------------------------------------------------------- ! identify the left/bottom/back grain (-|N) iGr3N = faceID(2:4) ! identify the grain ID in local coordinate system (3-dimensional index) iGrN = grain3to1(iGr3N,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceN = getInterface(2_pInt*faceID(1),iGr3N) ! identify the interface ID of the grain + intFaceN = getInterface(2*faceID(1),iGr3N) ! identify the interface ID of the grain normN = interfaceNormal(intFaceN,instance,of) !-------------------------------------------------------------------------------------------------- ! identify the right/up/front grain (+|P) iGr3P = iGr3N - iGr3P(faceID(1)) = iGr3N(faceID(1))+1_pInt ! identify the grain ID in local coordinate system (3-dimensional index) + iGr3P(faceID(1)) = iGr3N(faceID(1))+1 ! identify the grain ID in local coordinate system (3-dimensional index) iGrP = grain3to1(iGr3P,param(instance)%Nconstituents) ! translate the local grain ID into global coordinate system (1-dimensional index) - intFaceP = getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identify the interface ID of the grain + intFaceP = getInterface(2*faceID(1)-1,iGr3P) ! identify the interface ID of the grain normP = interfaceNormal(intFaceP,instance,of) !-------------------------------------------------------------------------------------------------- ! compute the residual stress (contribution of mismatch and volume penalties) from perturbed state ! at all interfaces - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt + do i = 1,3; do j = 1,3 p_resid(i+3*(iNum-1)) = p_resid(i+3*(iNum-1)) + (pR(i,j,iGrP) - R(i,j,iGrP))*normP(j) & + (pR(i,j,iGrN) - R(i,j,iGrN))*normN(j) & + (pD(i,j,iGrP) - D(i,j,iGrP))*normP(j) & @@ -665,10 +665,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) enddo #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Jacobian matrix of penalty' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,100(e11.4,1x))')(pmatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) + do i = 1,3*nIntFaceTot + write(6,'(1x,100(e11.4,1x))')(pmatrix(i,j), j = 1,3*nIntFaceTot) enddo write(6,*)' ' flush(6) @@ -678,15 +678,15 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! ... of the numerical viscosity traction "rmatrix" allocate(rmatrix(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pReal) - forall (i=1_pInt:3_pInt*nIntFaceTot) & + forall (i=1:3*nIntFaceTot) & rmatrix(i,i) = viscModus_RGC*viscPower_RGC/(refRelaxRate_RGC*dt)* & ! tangent due to numerical viscosity traction appears (abs(drelax(i))/(refRelaxRate_RGC*dt))**(viscPower_RGC - 1.0_pReal) ! only in the main diagonal term #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Jacobian matrix of penalty' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,100(e11.4,1x))')(rmatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) + do i = 1,3*nIntFaceTot + write(6,'(1x,100(e11.4,1x))')(rmatrix(i,j), j = 1,3*nIntFaceTot) enddo write(6,*)' ' flush(6) @@ -698,10 +698,10 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) allocate(jmatrix(3*nIntFaceTot,3*nIntFaceTot)); jmatrix = smatrix + pmatrix + rmatrix #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Jacobian matrix (total)' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,100(e11.4,1x))')(jmatrix(i,j), j = 1_pInt,3_pInt*nIntFaceTot) + do i = 1,3*nIntFaceTot + write(6,'(1x,100(e11.4,1x))')(jmatrix(i,j), j = 1,3*nIntFaceTot) enddo write(6,*)' ' flush(6) @@ -710,14 +710,14 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing the update of the state variable (relaxation vectors) using the Jacobian matrix - allocate(jnverse(3_pInt*nIntFaceTot,3_pInt*nIntFaceTot),source=0.0_pReal) + allocate(jnverse(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pReal) call math_invert2(jnverse,error,jmatrix) #ifdef DEBUG - if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0) then write(6,'(1x,a30)')'Jacobian inverse' - do i = 1_pInt,3_pInt*nIntFaceTot - write(6,'(1x,100(e11.4,1x))')(jnverse(i,j), j = 1_pInt,3_pInt*nIntFaceTot) + do i = 1,3*nIntFaceTot + write(6,'(1x,100(e11.4,1x))')(jnverse(i,j), j = 1,3*nIntFaceTot) enddo write(6,*)' ' flush(6) @@ -727,7 +727,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! calculate the state update (global relaxation vectors) for the next Newton-Raphson iteration drelax = 0.0_pReal - do i = 1_pInt,3_pInt*nIntFaceTot;do j = 1_pInt,3_pInt*nIntFaceTot + do i = 1,3*nIntFaceTot;do j = 1,3*nIntFaceTot drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable enddo; enddo stt%relaxationVector(:,of) = relax + drelax ! Updateing the state variable for the next iteration @@ -741,9 +741,9 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) endif #ifdef DEBUG - if (iand(debug_homogenization, debug_levelExtensive) > 0_pInt) then + if (iand(debug_homogenization, debug_levelExtensive) > 0) then write(6,'(1x,a30)')'Returned state: ' - do i = 1_pInt,size(stt%relaxationVector(:,of)) + do i = 1,size(stt%relaxationVector(:,of)) write(6,'(1x,2(e15.8,1x))') stt%relaxationVector(i,of) enddo write(6,*)' ' @@ -769,14 +769,14 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) real(pReal), dimension (:,:,:), intent(in) :: fDef !< deformation gradients real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor - integer(pInt), intent(in) :: ip,el,instance,of + integer, intent(in) :: ip,el,instance,of - integer(pInt), dimension (4) :: intFace - integer(pInt), dimension (3) :: iGrain3,iGNghb3,nGDim + integer, dimension (4) :: intFace + integer, dimension (3) :: iGrain3,iGNghb3,nGDim real(pReal), dimension (3,3) :: gDef,nDef real(pReal), dimension (3) :: nVect,surfCorr real(pReal), dimension (2) :: Gmoduli - integer(pInt) :: iGrain,iGNghb,iFace,i,j,k,l + integer :: iGrain,iGNghb,iFace,i,j,k,l real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb real(pReal), parameter :: nDefToler = 1.0e-10_pReal #ifdef DEBUG @@ -796,7 +796,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) associate(prm => param(instance)) #ifdef DEBUG - debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + debugActive = iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. prm%of_debug == of if (debugActive) then @@ -807,20 +807,20 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! computing the mismatch and penalty stress tensor of all grains - grainLoop: do iGrain = 1_pInt,product(prm%Nconstituents) + grainLoop: do iGrain = 1,product(prm%Nconstituents) Gmoduli = equivalentModuli(iGrain,ip,el) muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector iGrain3 = grain1to3(iGrain,prm%Nconstituents) ! get the grain ID in local 3-dimensional index (x,y,z)-position - interfaceLoop: do iFace = 1_pInt,6_pInt + interfaceLoop: do iFace = 1,6 intFace = getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain nVect = interfaceNormal(intFace,instance,of) iGNghb3 = iGrain3 ! identify the neighboring grain across the interface iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) & + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) where(iGNghb3 < 1) iGNghb3 = nGDim - where(iGNghb3 >nGDim) iGNghb3 = 1_pInt + where(iGNghb3 >nGDim) iGNghb3 = 1 iGNghb = grain3to1(iGNghb3,prm%Nconstituents) ! get the ID of the neighboring grain Gmoduli = equivalentModuli(iGNghb,ip,el) ! collect the shear modulus and Burgers vector of the neighbor muGNghb = Gmoduli(1) @@ -831,8 +831,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) ! compute the mismatch tensor of all interfaces nDefNorm = 0.0_pReal nDef = 0.0_pReal - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt - do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt + do i = 1,3; do j = 1,3 + do k = 1,3; do l = 1,3 nDef(i,j) = nDef(i,j) - nVect(k)*gDef(i,l)*math_civita(j,k,l) ! compute the interface mismatch tensor from the jump of deformation gradient enddo; enddo nDefNorm = nDefNorm + nDef(i,j)**2.0_pReal ! compute the norm of the mismatch tensor @@ -849,7 +849,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! compute the stress penalty of all interfaces - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt; do k = 1_pInt,3_pInt; do l = 1_pInt,3_pInt + do i = 1,3; do j = 1,3; do k = 1,3; do l = 1,3 rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*prm%xiAlpha & *surfCorr(abs(intFace(1)))/prm%dAlpha(abs(intFace(1))) & *cosh(prm%ciAlpha*nDefNorm) & @@ -889,18 +889,18 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) real(pReal), dimension (:,:,:), intent(in) :: fDef ! deformation gradients real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient - integer(pInt), intent(in) :: & + integer, intent(in) :: & Ngrain, & instance, & of real(pReal), dimension(size(vPen,3)) :: gVol - integer(pInt) :: i + integer :: i !-------------------------------------------------------------------------------------------------- ! compute the volumes of grains and of cluster vDiscrep = math_det33(fAvg) ! compute the volume of the cluster - do i = 1_pInt,nGrain + do i = 1,nGrain gVol(i) = math_det33(fDef(1:3,1:3,i)) ! compute the volume of individual grains vDiscrep = vDiscrep - gVol(i)/real(nGrain,pReal) ! calculate the difference/dicrepancy between ! the volume of the cluster and the the total volume of grains @@ -909,13 +909,13 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) !-------------------------------------------------------------------------------------------------- ! calculate the stress and penalty due to volume discrepancy vPen = 0.0_pReal - do i = 1_pInt,nGrain + do i = 1,nGrain vPen(:,:,i) = -1.0_pReal/real(nGrain,pReal)*volDiscrMod_RGC*volDiscrPow_RGC/maxVolDiscr_RGC* & sign((abs(vDiscrep)/maxVolDiscr_RGC)**(volDiscrPow_RGC - 1.0),vDiscrep)* & gVol(i)*transpose(math_inv33(fDef(:,:,i))) #ifdef DEBUG - if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0 & .and. param(instance)%of_debug == of) then write(6,'(1x,a30,i2)')'Volume penalty of grain: ',i write(6,*) transpose(vPen(:,:,i)) @@ -936,22 +936,23 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) implicit none real(pReal), dimension(3) :: surfaceCorrection + real(pReal), dimension(3,3), intent(in) :: avgF !< average F - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of real(pReal), dimension(3,3) :: invC real(pReal), dimension(3) :: nVect real(pReal) :: detF - integer(pInt) :: i,j,iBase + integer :: i,j,iBase logical :: error call math_invert33(matmul(transpose(avgF),avgF),invC,detF,error) surfaceCorrection = 0.0_pReal - do iBase = 1_pInt,3_pInt - nVect = interfaceNormal([iBase,1_pInt,1_pInt,1_pInt],instance,of) - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt + do iBase = 1,3 + nVect = interfaceNormal([iBase,1,1,1],instance,of) + do i = 1,3; do j = 1,3 surfaceCorrection(iBase) = surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) ! compute the component of (the inverse of) the stretch in the direction of the normal enddo; enddo surfaceCorrection(iBase) = sqrt(surfaceCorrection(iBase))*detF ! get the surface correction factor (area contraction/enlargement) @@ -969,7 +970,8 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) implicit none real(pReal), dimension(2) :: equivalentModuli - integer(pInt), intent(in) :: & + + integer, intent(in) :: & grainID,& ip, & !< integration point number el !< element number @@ -1003,17 +1005,17 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) subroutine grainDeformation(F, avgF, instance, of) implicit none - real(pReal), dimension (:,:,:), intent(out) :: F !< partioned F per grain + real(pReal), dimension(:,:,:), intent(out) :: F !< partioned F per grain - real(pReal), dimension (:,:), intent(in) :: avgF !< averaged F - integer(pInt), intent(in) :: & + real(pReal), dimension(:,:), intent(in) :: avgF !< averaged F + integer, intent(in) :: & instance, & of - real(pReal), dimension (3) :: aVect,nVect - integer(pInt), dimension (4) :: intFace - integer(pInt), dimension (3) :: iGrain3 - integer(pInt) :: iGrain,iFace,i,j + real(pReal), dimension(3) :: aVect,nVect + integer, dimension(4) :: intFace + integer, dimension(3) :: iGrain3 + integer :: iGrain,iFace,i,j !------------------------------------------------------------------------------------------------- ! compute the deformation gradient of individual grains due to relaxations @@ -1021,13 +1023,13 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) associate(prm => param(instance)) F = 0.0_pReal - do iGrain = 1_pInt,product(prm%Nconstituents) + do iGrain = 1,product(prm%Nconstituents) iGrain3 = grain1to3(iGrain,prm%Nconstituents) - do iFace = 1_pInt,6_pInt + do iFace = 1,6 intFace = getInterface(iFace,iGrain3) aVect = relaxationVector(intFace,instance,of) nVect = interfaceNormal(intFace,instance,of) - forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + forall (i=1:3,j=1:3) & F(i,j,iGrain) = F(i,j,iGrain) + aVect(i)*nVect(j) ! effective relaxations enddo F(1:3,1:3,iGrain) = F(1:3,1:3,iGrain) + avgF ! relaxed deformation gradient @@ -1046,12 +1048,12 @@ end function homogenization_RGC_updateState subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) implicit none - real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point - real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point + real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point + real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point - real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses - real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses - integer(pInt), intent(in) :: instance + real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses + real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses + integer, intent(in) :: instance avgP = sum(P,3) /real(product(param(instance)%Nconstituents),pReal) dAvgPdAvgF = sum(dPdF,5)/real(product(param(instance)%Nconstituents),pReal) @@ -1065,40 +1067,40 @@ end subroutine homogenization_RGC_averageStressAndItsTangent pure function homogenization_RGC_postResults(instance,of) result(postResults) implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & instance, & of - integer(pInt) :: & + integer :: & o,c real(pReal), dimension(sum(homogenization_RGC_sizePostResult(:,instance))) :: & postResults associate(stt => state(instance), dst => dependentState(instance), prm => param(instance)) - c = 0_pInt + c = 0 - outputsLoop: do o = 1_pInt,size(prm%outputID) + outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) case (constitutivework_ID) postResults(c+1) = stt%work(of) - c = c + 1_pInt + c = c + 1 case (magnitudemismatch_ID) postResults(c+1:c+3) = dst%mismatch(1:3,of) - c = c + 3_pInt + c = c + 3 case (penaltyenergy_ID) postResults(c+1) = stt%penaltyEnergy(of) - c = c + 1_pInt + c = c + 1 case (volumediscrepancy_ID) postResults(c+1) = dst%volumeDiscrepancy(of) - c = c + 1_pInt + c = c + 1 case (averagerelaxrate_ID) postResults(c+1) = dst%relaxationrate_avg(of) - c = c + 1_pInt + c = c + 1 case (maximumrelaxrate_ID) postResults(c+1) = dst%relaxationrate_max(of) - c = c + 1_pInt + c = c + 1 end select enddo outputsLoop @@ -1114,18 +1116,20 @@ end function homogenization_RGC_postResults pure function relaxationVector(intFace,instance,of) implicit none - integer(pInt), intent(in) :: instance,of + real(pReal), dimension (3) :: relaxationVector + + integer, intent(in) :: instance,of + integer, dimension(4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) - real(pReal), dimension (3) :: relaxationVector - integer(pInt), dimension (4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) - integer(pInt) :: & - iNum + integer :: iNum + + !-------------------------------------------------------------------------------------------------- ! collect the interface relaxation vector from the global state array iNum = interface4to1(intFace,param(instance)%Nconstituents) ! identify the position of the interface in global state array - if (iNum > 0_pInt) then + if (iNum > 0) then relaxationVector = state(instance)%relaxationVector((3*iNum-2):(3*iNum),of) else relaxationVector = 0.0_pReal @@ -1140,12 +1144,14 @@ end function relaxationVector pure function interfaceNormal(intFace,instance,of) implicit none - real(pReal), dimension (3) :: interfaceNormal - integer(pInt), dimension (4), intent(in) :: intFace !< interface ID in 4D array (normal and position) - integer(pInt), intent(in) :: & + real(pReal), dimension(3) :: interfaceNormal + + integer, dimension(4), intent(in) :: intFace !< interface ID in 4D array (normal and position) + integer, intent(in) :: & instance, & of - integer(pInt) :: nPos + + integer :: nPos !-------------------------------------------------------------------------------------------------- ! get the normal of the interface, identified from the value of intFace(1) @@ -1153,7 +1159,7 @@ pure function interfaceNormal(intFace,instance,of) nPos = abs(intFace(1)) ! identify the position of the interface in global state array interfaceNormal(nPos) = real(intFace(1)/abs(intFace(1)),pReal) ! get the normal vector w.r.t. cluster axis - interfaceNormal = matmul(dependentState(instance)%orientation(1:3,1:3,of),interfaceNormal) ! map the normal vector into sample coordinate system (basis) + interfaceNormal = matmul(dependentState(instance)%orientation(1:3,1:3,of),interfaceNormal) ! map the normal vector into sample coordinate system (basis) end function interfaceNormal @@ -1164,19 +1170,21 @@ end function interfaceNormal pure function getInterface(iFace,iGrain3) implicit none - integer(pInt), dimension (4) :: getInterface - integer(pInt), dimension (3), intent(in) :: iGrain3 !< grain ID in 3D array - integer(pInt), intent(in) :: iFace !< face index (1..6) mapped like (-e1,-e2,-e3,+e1,+e2,+e3) or iDir = (-1,-2,-3,1,2,3) - integer(pInt) :: iDir + integer, dimension(4) :: getInterface + + integer, dimension(3), intent(in) :: iGrain3 !< grain ID in 3D array + integer, intent(in) :: iFace !< face index (1..6) mapped like (-e1,-e2,-e3,+e1,+e2,+e3) or iDir = (-1,-2,-3,1,2,3) + + integer :: iDir !* Direction of interface normal - iDir = (int(real(iFace-1_pInt,pReal)/2.0_pReal,pInt)+1_pInt)*(-1_pInt)**iFace + iDir = (int(real(iFace-1,pReal)/2.0_pReal)+1)*(-1)**iFace getInterface(1) = iDir !-------------------------------------------------------------------------------------------------- ! identify the interface position by the direction of its normal getInterface(2:4) = iGrain3 - if (iDir < 0_pInt) getInterface(1_pInt-iDir) = getInterface(1_pInt-iDir)-1_pInt ! to have a correlation with coordinate/position in real space + if (iDir < 0) getInterface(1-iDir) = getInterface(1-iDir)-1 ! to have a correlation with coordinate/position in real space end function getInterface @@ -1187,13 +1195,14 @@ end function getInterface pure function grain1to3(grain1,nGDim) implicit none - integer(pInt), dimension(3) :: grain1to3 - integer(pInt), intent(in) :: grain1 !< grain ID in 1D array - integer(pInt), dimension(3), intent(in) :: nGDim + integer, dimension(3) :: grain1to3 - grain1to3 = 1_pInt + [mod((grain1-1_pInt),nGDim(1)), & - mod((grain1-1_pInt)/nGDim(1),nGDim(2)), & - (grain1-1_pInt)/(nGDim(1)*nGDim(2))] + integer, intent(in) :: grain1 !< grain ID in 1D array + integer, dimension(3), intent(in) :: nGDim + + grain1to3 = 1 + [mod((grain1-1),nGDim(1)), & + mod((grain1-1)/nGDim(1),nGDim(2)), & + (grain1-1)/(nGDim(1)*nGDim(2))] end function grain1to3 @@ -1201,15 +1210,15 @@ end function grain1to3 !-------------------------------------------------------------------------------------------------- !> @brief map grain ID from in 3D (local position) to in 1D (global array) !-------------------------------------------------------------------------------------------------- -integer(pInt) pure function grain3to1(grain3,nGDim) +integer pure function grain3to1(grain3,nGDim) implicit none - integer(pInt), dimension(3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) - integer(pInt), dimension(3), intent(in) :: nGDim + integer, dimension(3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) + integer, dimension(3), intent(in) :: nGDim grain3to1 = grain3(1) & - + nGDim(1)*(grain3(2)-1_pInt) & - + nGDim(1)*nGDim(2)*(grain3(3)-1_pInt) + + nGDim(1)*(grain3(2)-1) & + + nGDim(1)*nGDim(2)*(grain3(3)-1) end function grain3to1 @@ -1217,44 +1226,44 @@ end function grain3to1 !-------------------------------------------------------------------------------------------------- !> @brief maps interface ID from 4D (normal and local position) into 1D (global array) !-------------------------------------------------------------------------------------------------- -integer(pInt) pure function interface4to1(iFace4D, nGDim) +integer pure function interface4to1(iFace4D, nGDim) implicit none - integer(pInt), dimension(4), intent(in) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z) - integer(pInt), dimension(3), intent(in) :: nGDim + integer, dimension(4), intent(in) :: iFace4D !< interface ID in 4D array (n.dir,pos.x,pos.y,pos.z) + integer, dimension(3), intent(in) :: nGDim select case(abs(iFace4D(1))) - case(1_pInt) - if ((iFace4D(2) == 0_pInt) .or. (iFace4D(2) == nGDim(1))) then - interface4to1 = 0_pInt + case(1) + if ((iFace4D(2) == 0) .or. (iFace4D(2) == nGDim(1))) then + interface4to1 = 0 else - interface4to1 = iFace4D(3) + nGDim(2)*(iFace4D(4)-1_pInt) & - + nGDim(2)*nGDim(3)*(iFace4D(2)-1_pInt) + interface4to1 = iFace4D(3) + nGDim(2)*(iFace4D(4)-1) & + + nGDim(2)*nGDim(3)*(iFace4D(2)-1) endif - case(2_pInt) - if ((iFace4D(3) == 0_pInt) .or. (iFace4D(3) == nGDim(2))) then - interface4to1 = 0_pInt + case(2) + if ((iFace4D(3) == 0) .or. (iFace4D(3) == nGDim(2))) then + interface4to1 = 0 else - interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1_pInt) & - + nGDim(3)*nGDim(1)*(iFace4D(3)-1_pInt) & - + (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) ! total number of interfaces normal //e1 + interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1) & + + nGDim(3)*nGDim(1)*(iFace4D(3)-1) & + + (nGDim(1)-1)*nGDim(2)*nGDim(3) ! total number of interfaces normal //e1 endif - case(3_pInt) - if ((iFace4D(4) == 0_pInt) .or. (iFace4D(4) == nGDim(3))) then - interface4to1 = 0_pInt + case(3) + if ((iFace4D(4) == 0) .or. (iFace4D(4) == nGDim(3))) then + interface4to1 = 0 else - interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1_pInt) & - + nGDim(1)*nGDim(2)*(iFace4D(4)-1_pInt) & - + (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) & ! total number of interfaces normal //e1 - + nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) ! total number of interfaces normal //e2 + interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1) & + + nGDim(1)*nGDim(2)*(iFace4D(4)-1) & + + (nGDim(1)-1)*nGDim(2)*nGDim(3) & ! total number of interfaces normal //e1 + + nGDim(1)*(nGDim(2)-1)*nGDim(3) ! total number of interfaces normal //e2 endif case default - interface4to1 = -1_pInt + interface4to1 = -1 end select @@ -1267,61 +1276,35 @@ end function interface4to1 pure function interface1to4(iFace1D, nGDim) implicit none - integer(pInt), dimension(4) :: interface1to4 - integer(pInt), intent(in) :: iFace1D !< interface ID in 1D array - integer(pInt), dimension(3), intent(in) :: nGDim - integer(pInt), dimension(3) :: nIntFace + integer, dimension(4) :: interface1to4 + + integer, intent(in) :: iFace1D !< interface ID in 1D array + integer, dimension(3), intent(in) :: nGDim + integer, dimension(3) :: nIntFace !-------------------------------------------------------------------------------------------------- ! compute the total number of interfaces, which ... - nIntFace = [(nGDim(1)-1_pInt)*nGDim(2)*nGDim(3), & ! ... normal //e1 - nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3), & ! ... normal //e2 - nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt)] ! ... normal //e3 + nIntFace = [(nGDim(1)-1)*nGDim(2)*nGDim(3), & ! ... normal //e1 + nGDim(1)*(nGDim(2)-1)*nGDim(3), & ! ... normal //e2 + nGDim(1)*nGDim(2)*(nGDim(3)-1)] ! ... normal //e3 !-------------------------------------------------------------------------------------------------- ! get the corresponding interface ID in 4D (normal and local position) if (iFace1D > 0 .and. iFace1D <= nIntFace(1)) then ! interface with normal //e1 - interface1to4(1) = 1_pInt - interface1to4(3) = mod((iFace1D-1_pInt),nGDim(2))+1_pInt - interface1to4(4) = mod(& - int(& - real(iFace1D-1_pInt,pReal)/& - real(nGDim(2),pReal)& - ,pInt)& - ,nGDim(3))+1_pInt - interface1to4(2) = int(& - real(iFace1D-1_pInt,pReal)/& - real(nGDim(2),pReal)/& - real(nGDim(3),pReal)& - ,pInt)+1_pInt + interface1to4(1) = 1 + interface1to4(3) = mod((iFace1D-1),nGDim(2))+1 + interface1to4(4) = mod(int(real(iFace1D-1,pReal)/real(nGDim(2),pReal)),nGDim(3))+1 + interface1to4(2) = int(real(iFace1D-1,pReal)/real(nGDim(2),pReal)/real(nGDim(3),pReal))+1 elseif (iFace1D > nIntFace(1) .and. iFace1D <= (nIntFace(2) + nIntFace(1))) then ! interface with normal //e2 - interface1to4(1) = 2_pInt - interface1to4(4) = mod((iFace1D-nIntFace(1)-1_pInt),nGDim(3))+1_pInt - interface1to4(2) = mod(& - int(& - real(iFace1D-nIntFace(1)-1_pInt,pReal)/& - real(nGDim(3),pReal)& - ,pInt)& - ,nGDim(1))+1_pInt - interface1to4(3) = int(& - real(iFace1D-nIntFace(1)-1_pInt,pReal)/& - real(nGDim(3),pReal)/& - real(nGDim(1),pReal)& - ,pInt)+1_pInt + interface1to4(1) = 2 + interface1to4(4) = mod((iFace1D-nIntFace(1)-1),nGDim(3))+1 + interface1to4(2) = mod(int(real(iFace1D-nIntFace(1)-1,pReal)/real(nGDim(3),pReal)),nGDim(1))+1 + interface1to4(3) = int(real(iFace1D-nIntFace(1)-1,pReal)/real(nGDim(3),pReal)/real(nGDim(1),pReal))+1 elseif (iFace1D > nIntFace(2) + nIntFace(1) .and. iFace1D <= (nIntFace(3) + nIntFace(2) + nIntFace(1))) then ! interface with normal //e3 - interface1to4(1) = 3_pInt - interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1_pInt),nGDim(1))+1_pInt - interface1to4(3) = mod(& - int(& - real(iFace1D-nIntFace(2)-nIntFace(1)-1_pInt,pReal)/& - real(nGDim(1),pReal)& - ,pInt)& - ,nGDim(2))+1_pInt - interface1to4(4) = int(& - real(iFace1D-nIntFace(2)-nIntFace(1)-1_pInt,pReal)/& - real(nGDim(1),pReal)/& - real(nGDim(2),pReal)& - ,pInt)+1_pInt + interface1to4(1) = 3 + interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1),nGDim(1))+1 + interface1to4(3) = mod(int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pReal)/real(nGDim(1),pReal)),nGDim(2))+1 + interface1to4(4) = int(real(iFace1D-nIntFace(2)-nIntFace(1)-1,pReal)/real(nGDim(1),pReal)/real(nGDim(2),pReal))+1 endif end function interface1to4 diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 index 366d76b59..f668f2396 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_isostrain.f90 @@ -17,7 +17,7 @@ module homogenization_isostrain end enum type, private :: tParameters !< container type for internal constitutive parameters - integer(pInt) :: & + integer :: & Nconstituents integer(kind(average_ID)) :: & mapping @@ -53,7 +53,7 @@ subroutine homogenization_isostrain_init() config_homogenization implicit none - integer(pInt) :: & + integer :: & Ninstance, & h, & NofMyHomog @@ -63,12 +63,12 @@ subroutine homogenization_isostrain_init() write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_ISOSTRAIN_label//' init -+>>>' Ninstance = int(count(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID),pInt) - if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & + if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0) & write(6,'(a16,1x,i5,/)') '# instances:',Ninstance allocate(param(Ninstance)) ! one container of parameters per instance - do h = 1_pInt, size(homogenization_type) + do h = 1, size(homogenization_type) if (homogenization_type(h) /= HOMOGENIZATION_ISOSTRAIN_ID) cycle associate(prm => param(homogenization_typeInstance(h)),& @@ -82,15 +82,15 @@ subroutine homogenization_isostrain_init() case ('avg') prm%mapping = average_ID case default - call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_isostrain_label//')') + call IO_error(211,ext_msg=trim(tag)//' ('//HOMOGENIZATION_isostrain_label//')') end select NofMyHomog = count(material_homogenizationAt == h) - homogState(h)%sizeState = 0_pInt - homogState(h)%sizePostResults = 0_pInt - allocate(homogState(h)%state0 (0_pInt,NofMyHomog)) - allocate(homogState(h)%subState0(0_pInt,NofMyHomog)) - allocate(homogState(h)%state (0_pInt,NofMyHomog)) + homogState(h)%sizeState = 0 + homogState(h)%sizePostResults = 0 + allocate(homogState(h)%state0 (0,NofMyHomog)) + allocate(homogState(h)%subState0(0,NofMyHomog)) + allocate(homogState(h)%state (0,NofMyHomog)) end associate @@ -129,7 +129,7 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses - integer(pInt), intent(in) :: instance + integer, intent(in) :: instance associate(prm => param(instance)) From 148440c16e5da78bd221bcb82e05700b2088ad9c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 5 Apr 2019 20:48:20 +0200 Subject: [PATCH 13/97] consistent indentation --- src/homogenization_RGC.f90 | 5 +- src/homogenization_isostrain.f90 | 218 +++++++++++++++---------------- 2 files changed, 110 insertions(+), 113 deletions(-) diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 index 26eadf4f9..ea1dd39a6 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_RGC.f90 @@ -8,8 +8,7 @@ !-------------------------------------------------------------------------------------------------- module homogenization_RGC use prec, only: & - pReal, & - pInt + pReal implicit none private @@ -818,7 +817,7 @@ function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) nVect = interfaceNormal(intFace,instance,of) iGNghb3 = iGrain3 ! identify the neighboring grain across the interface iGNghb3(abs(intFace(1))) = iGNghb3(abs(intFace(1))) & - + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal),pInt) + + int(real(intFace(1),pReal)/real(abs(intFace(1)),pReal)) where(iGNghb3 < 1) iGNghb3 = nGDim where(iGNghb3 >nGDim) iGNghb3 = 1 iGNghb = grain3to1(iGNghb3,prm%Nconstituents) ! get the ID of the neighboring grain diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 index f668f2396..3ccbbf5ab 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_isostrain.f90 @@ -5,96 +5,94 @@ !> @brief Isostrain (full constraint Taylor assuption) homogenization scheme !-------------------------------------------------------------------------------------------------- module homogenization_isostrain - use prec, only: & - pInt - implicit none - private - enum, bind(c) - enumerator :: & - parallel_ID, & - average_ID - end enum - - type, private :: tParameters !< container type for internal constitutive parameters - integer :: & - Nconstituents - integer(kind(average_ID)) :: & - mapping - end type - - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - - public :: & - homogenization_isostrain_init, & - homogenization_isostrain_partitionDeformation, & - homogenization_isostrain_averageStressAndItsTangent + implicit none + private + enum, bind(c) + enumerator :: & + parallel_ID, & + average_ID + end enum + + type, private :: tParameters !< container type for internal constitutive parameters + integer :: & + Nconstituents + integer(kind(average_ID)) :: & + mapping + end type + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) + + public :: & + homogenization_isostrain_init, & + homogenization_isostrain_partitionDeformation, & + homogenization_isostrain_averageStressAndItsTangent contains !-------------------------------------------------------------------------------------------------- !> @brief allocates all neccessary fields, reads information from material configuration file !-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_init() - use debug, only: & - debug_HOMOGENIZATION, & - debug_level, & - debug_levelBasic - use IO, only: & - IO_error - use material, only: & - homogenization_type, & - material_homogenizationAt, & - homogState, & - HOMOGENIZATION_ISOSTRAIN_ID, & - HOMOGENIZATION_ISOSTRAIN_LABEL, & - homogenization_typeInstance - use config, only: & - config_homogenization - - implicit none - integer :: & - Ninstance, & - h, & - NofMyHomog - character(len=65536) :: & - tag = '' - - write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_ISOSTRAIN_label//' init -+>>>' - - Ninstance = int(count(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID),pInt) - if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0) & - write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - - allocate(param(Ninstance)) ! one container of parameters per instance - - do h = 1, size(homogenization_type) - if (homogenization_type(h) /= HOMOGENIZATION_ISOSTRAIN_ID) cycle - - associate(prm => param(homogenization_typeInstance(h)),& - config => config_homogenization(h)) +subroutine homogenization_isostrain_init + use debug, only: & + debug_HOMOGENIZATION, & + debug_level, & + debug_levelBasic + use IO, only: & + IO_error + use material, only: & + homogenization_type, & + material_homogenizationAt, & + homogState, & + HOMOGENIZATION_ISOSTRAIN_ID, & + HOMOGENIZATION_ISOSTRAIN_LABEL, & + homogenization_typeInstance + use config, only: & + config_homogenization - prm%Nconstituents = config_homogenization(h)%getInt('nconstituents') - tag = 'sum' - select case(trim(config%getString('mapping',defaultVal = tag))) - case ('sum') - prm%mapping = parallel_ID - case ('avg') - prm%mapping = average_ID - case default - call IO_error(211,ext_msg=trim(tag)//' ('//HOMOGENIZATION_isostrain_label//')') - end select - - NofMyHomog = count(material_homogenizationAt == h) - homogState(h)%sizeState = 0 - homogState(h)%sizePostResults = 0 - allocate(homogState(h)%state0 (0,NofMyHomog)) - allocate(homogState(h)%subState0(0,NofMyHomog)) - allocate(homogState(h)%state (0,NofMyHomog)) + implicit none + integer :: & + Ninstance, & + h, & + NofMyHomog + character(len=65536) :: & + tag = '' + + write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_ISOSTRAIN_label//' init -+>>>' + + Ninstance = count(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID) + if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0) & + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + + allocate(param(Ninstance)) ! one container of parameters per instance + + do h = 1, size(homogenization_type) + if (homogenization_type(h) /= HOMOGENIZATION_ISOSTRAIN_ID) cycle + + associate(prm => param(homogenization_typeInstance(h)),& + config => config_homogenization(h)) - end associate - - enddo + prm%Nconstituents = config_homogenization(h)%getInt('nconstituents') + tag = 'sum' + select case(trim(config%getString('mapping',defaultVal = tag))) + case ('sum') + prm%mapping = parallel_ID + case ('avg') + prm%mapping = average_ID + case default + call IO_error(211,ext_msg=trim(tag)//' ('//HOMOGENIZATION_isostrain_label//')') + end select + + NofMyHomog = count(material_homogenizationAt == h) + homogState(h)%sizeState = 0 + homogState(h)%sizePostResults = 0 + allocate(homogState(h)%state0 (0,NofMyHomog)) + allocate(homogState(h)%subState0(0,NofMyHomog)) + allocate(homogState(h)%state (0,NofMyHomog)) + + end associate + + enddo end subroutine homogenization_isostrain_init @@ -103,15 +101,15 @@ end subroutine homogenization_isostrain_init !> @brief partitions the deformation gradient onto the constituents !-------------------------------------------------------------------------------------------------- subroutine homogenization_isostrain_partitionDeformation(F,avgF) - use prec, only: & - pReal + use prec, only: & + pReal + + implicit none + real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient + + real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point - implicit none - real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient - - real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point - - F = spread(avgF,3,size(F,3)) + F = spread(avgF,3,size(F,3)) end subroutine homogenization_isostrain_partitionDeformation @@ -120,29 +118,29 @@ end subroutine homogenization_isostrain_partitionDeformation !> @brief derive average stress and stiffness from constituent quantities !-------------------------------------------------------------------------------------------------- subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) - use prec, only: & - pReal + use prec, only: & + pReal + + implicit none + real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point + real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point - implicit none - real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point - real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point - - real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses - real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses - integer, intent(in) :: instance - - associate(prm => param(instance)) + real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses + real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses + integer, intent(in) :: instance - select case (prm%mapping) - case (parallel_ID) - avgP = sum(P,3) - dAvgPdAvgF = sum(dPdF,5) - case (average_ID) - avgP = sum(P,3) /real(prm%Nconstituents,pReal) - dAvgPdAvgF = sum(dPdF,5)/real(prm%Nconstituents,pReal) - end select - - end associate + associate(prm => param(instance)) + + select case (prm%mapping) + case (parallel_ID) + avgP = sum(P,3) + dAvgPdAvgF = sum(dPdF,5) + case (average_ID) + avgP = sum(P,3) /real(prm%Nconstituents,pReal) + dAvgPdAvgF = sum(dPdF,5)/real(prm%Nconstituents,pReal) + end select + + end associate end subroutine homogenization_isostrain_averageStressAndItsTangent From 489a24afd8c161361cc28e10890ad150801cd6d5 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 5 Apr 2019 20:58:56 +0200 Subject: [PATCH 14/97] consistent names --- src/commercialFEM_fileList.f90 | 6 +++--- src/{homogenization_RGC.f90 => homogenization_mech_RGC.f90} | 4 ++-- ...tion_isostrain.f90 => homogenization_mech_isostrain.f90} | 4 ++-- ...homogenization_none.f90 => homogenization_mech_none.f90} | 4 ++-- 4 files changed, 9 insertions(+), 9 deletions(-) rename src/{homogenization_RGC.f90 => homogenization_mech_RGC.f90} (99%) rename src/{homogenization_isostrain.f90 => homogenization_mech_isostrain.f90} (98%) rename src/{homogenization_none.f90 => homogenization_mech_none.f90} (96%) diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 301274897..5108fe853 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -46,9 +46,9 @@ #include "plastic_nonlocal.f90" #include "constitutive.f90" #include "crystallite.f90" -#include "homogenization_none.f90" -#include "homogenization_isostrain.f90" -#include "homogenization_RGC.f90" +#include "homogenization_mech_none.f90" +#include "homogenization_mech_isostrain.f90" +#include "homogenization_mech_RGC.f90" #include "thermal_isothermal.f90" #include "thermal_adiabatic.f90" #include "thermal_conduction.f90" diff --git a/src/homogenization_RGC.f90 b/src/homogenization_mech_RGC.f90 similarity index 99% rename from src/homogenization_RGC.f90 rename to src/homogenization_mech_RGC.f90 index ea1dd39a6..012ad6086 100644 --- a/src/homogenization_RGC.f90 +++ b/src/homogenization_mech_RGC.f90 @@ -6,7 +6,7 @@ !> @brief Relaxed grain cluster (RGC) homogenization scheme !> Nconstituents is defined as p x q x r (cluster) !-------------------------------------------------------------------------------------------------- -module homogenization_RGC +module homogenization_mech_RGC use prec, only: & pReal @@ -1309,4 +1309,4 @@ pure function interface1to4(iFace1D, nGDim) end function interface1to4 -end module homogenization_RGC +end module homogenization_mech_RGC diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_mech_isostrain.f90 similarity index 98% rename from src/homogenization_isostrain.f90 rename to src/homogenization_mech_isostrain.f90 index 3ccbbf5ab..071420f6e 100644 --- a/src/homogenization_isostrain.f90 +++ b/src/homogenization_mech_isostrain.f90 @@ -4,7 +4,7 @@ !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @brief Isostrain (full constraint Taylor assuption) homogenization scheme !-------------------------------------------------------------------------------------------------- -module homogenization_isostrain +module homogenization_mech_isostrain implicit none private @@ -144,4 +144,4 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P end subroutine homogenization_isostrain_averageStressAndItsTangent -end module homogenization_isostrain +end module homogenization_mech_isostrain diff --git a/src/homogenization_none.f90 b/src/homogenization_mech_none.f90 similarity index 96% rename from src/homogenization_none.f90 rename to src/homogenization_mech_none.f90 index cbbfa4cac..a528203b1 100644 --- a/src/homogenization_none.f90 +++ b/src/homogenization_mech_none.f90 @@ -4,7 +4,7 @@ !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @brief dummy homogenization homogenization scheme for 1 constituent per material point !-------------------------------------------------------------------------------------------------- -module homogenization_none +module homogenization_mech_none implicit none private @@ -57,4 +57,4 @@ subroutine homogenization_none_init() end subroutine homogenization_none_init -end module homogenization_none +end module homogenization_mech_none From 72b30729bbba8adb028bc2f3c529252d31a37163 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 5 Apr 2019 21:42:07 +0200 Subject: [PATCH 15/97] submodule for homogenization first draft, RGC not included because of name clash with isostrain --- CMakeLists.txt | 3 -- src/commercialFEM_fileList.f90 | 4 +-- src/homogenization.f90 | 48 ++++++++++++++++++--------- src/homogenization_mech_isostrain.f90 | 34 ++++++++----------- src/homogenization_mech_none.f90 | 12 +++---- 5 files changed, 52 insertions(+), 49 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 8be07198a..0cfe47248 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -337,9 +337,6 @@ elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") set (COMPILE_FLAGS "${COMPILE_FLAGS} -fimplicit-none") # assume "implicit none" even if not present in source - set (COMPILE_FLAGS "${COMPILE_FLAGS} -fmodule-private") - # assume "private" even if not present in source - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wall") # sets the following Fortran options: # -Waliasing: warn about possible aliasing of dummy arguments. Specifically, it warns if the same actual argument is associated with a dummy argument with "INTENT(IN)" and a dummy argument with "INTENT(OUT)" in a call with an explicit interface. diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 5108fe853..5131eeaa9 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -46,8 +46,6 @@ #include "plastic_nonlocal.f90" #include "constitutive.f90" #include "crystallite.f90" -#include "homogenization_mech_none.f90" -#include "homogenization_mech_isostrain.f90" #include "homogenization_mech_RGC.f90" #include "thermal_isothermal.f90" #include "thermal_adiabatic.f90" @@ -56,4 +54,6 @@ #include "damage_local.f90" #include "damage_nonlocal.f90" #include "homogenization.f90" +#include "homogenization_mech_none.f90" +#include "homogenization_mech_isostrain.f90" #include "CPFEM.f90" diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 919680d6e..06da6ab2e 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -38,6 +38,30 @@ module homogenization materialpoint_converged logical, dimension(:,:,:), allocatable, private :: & materialpoint_doneAndHappy + + interface + + module subroutine mech_none_init + end subroutine mech_none_init + + module subroutine mech_isostrain_init + end subroutine mech_isostrain_init + + module subroutine mech_isostrain_partitionDeformation(F,avgF) + real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient + real(pReal), dimension (3,3), intent(in) :: avgF !< average deformation gradient at material point + end subroutine mech_isostrain_partitionDeformation + + module subroutine mech_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) + real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point + real(pReal), dimension (3,3,3,3), intent(out) :: dAvgPdAvgF !< average stiffness at material point + + real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses + real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses + integer, intent(in) :: instance + end subroutine mech_isostrain_averageStressAndItsTangent + + end interface public :: & homogenization_init, & @@ -77,9 +101,7 @@ subroutine homogenization_init config_homogenization, & homogenization_name use material - use homogenization_none - use homogenization_isostrain - use homogenization_RGC + use homogenization_mech_RGC use thermal_isothermal use thermal_adiabatic use thermal_conduction @@ -100,8 +122,8 @@ subroutine homogenization_init logical :: valid - if (any(homogenization_type == HOMOGENIZATION_NONE_ID)) call homogenization_none_init - if (any(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID)) call homogenization_isostrain_init + if (any(homogenization_type == HOMOGENIZATION_NONE_ID)) call mech_none_init + if (any(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID)) call mech_isostrain_init if (any(homogenization_type == HOMOGENIZATION_RGC_ID)) call homogenization_RGC_init if (any(thermal_type == THERMAL_isothermal_ID)) call thermal_isothermal_init @@ -709,9 +731,7 @@ subroutine partitionDeformation(ip,el) HOMOGENIZATION_RGC_ID use crystallite, only: & crystallite_partionedF - use homogenization_isostrain, only: & - homogenization_isostrain_partitionDeformation - use homogenization_RGC, only: & + use homogenization_mech_RGC, only: & homogenization_RGC_partitionDeformation implicit none @@ -725,7 +745,7 @@ subroutine partitionDeformation(ip,el) crystallite_partionedF(1:3,1:3,1,ip,el) = materialpoint_subF(1:3,1:3,ip,el) case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization - call homogenization_isostrain_partitionDeformation(& + call mech_isostrain_partitionDeformation(& crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & materialpoint_subF(1:3,1:3,ip,el)) @@ -760,7 +780,7 @@ function updateState(ip,el) crystallite_dPdF, & crystallite_partionedF,& crystallite_partionedF0 - use homogenization_RGC, only: & + use homogenization_mech_RGC, only: & homogenization_RGC_updateState use thermal_adiabatic, only: & thermal_adiabatic_updateState @@ -824,9 +844,7 @@ subroutine averageStressAndItsTangent(ip,el) HOMOGENIZATION_RGC_ID use crystallite, only: & crystallite_P,crystallite_dPdF - use homogenization_isostrain, only: & - homogenization_isostrain_averageStressAndItsTangent - use homogenization_RGC, only: & + use homogenization_mech_RGC, only: & homogenization_RGC_averageStressAndItsTangent implicit none @@ -840,7 +858,7 @@ subroutine averageStressAndItsTangent(ip,el) materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el) = crystallite_dPdF(1:3,1:3,1:3,1:3,1,ip,el) case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization - call homogenization_isostrain_averageStressAndItsTangent(& + call mech_isostrain_averageStressAndItsTangent(& materialpoint_P(1:3,1:3,ip,el), & materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el),& crystallite_P(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & @@ -887,7 +905,7 @@ function postResults(ip,el) DAMAGE_none_ID, & DAMAGE_local_ID, & DAMAGE_nonlocal_ID - use homogenization_RGC, only: & + use homogenization_mech_RGC, only: & homogenization_RGC_postResults use thermal_adiabatic, only: & thermal_adiabatic_postResults diff --git a/src/homogenization_mech_isostrain.f90 b/src/homogenization_mech_isostrain.f90 index 071420f6e..1fdf5435c 100644 --- a/src/homogenization_mech_isostrain.f90 +++ b/src/homogenization_mech_isostrain.f90 @@ -4,36 +4,32 @@ !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @brief Isostrain (full constraint Taylor assuption) homogenization scheme !-------------------------------------------------------------------------------------------------- -module homogenization_mech_isostrain +submodule(homogenization) homogenization_mech_isostrain implicit none - private + enum, bind(c) enumerator :: & parallel_ID, & average_ID end enum - type, private :: tParameters !< container type for internal constitutive parameters + type :: tParameters !< container type for internal constitutive parameters integer :: & Nconstituents integer(kind(average_ID)) :: & mapping end type - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) - - public :: & - homogenization_isostrain_init, & - homogenization_isostrain_partitionDeformation, & - homogenization_isostrain_averageStressAndItsTangent + type(tParameters), dimension(:), allocatable :: param !< containers of constitutive parameters (len Ninstance) + contains !-------------------------------------------------------------------------------------------------- !> @brief allocates all neccessary fields, reads information from material configuration file !-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_init +module subroutine mech_isostrain_init use debug, only: & debug_HOMOGENIZATION, & debug_level, & @@ -94,15 +90,13 @@ subroutine homogenization_isostrain_init enddo -end subroutine homogenization_isostrain_init +end subroutine mech_isostrain_init !-------------------------------------------------------------------------------------------------- !> @brief partitions the deformation gradient onto the constituents !-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_partitionDeformation(F,avgF) - use prec, only: & - pReal +module subroutine mech_isostrain_partitionDeformation(F,avgF) implicit none real(pReal), dimension (:,:,:), intent(out) :: F !< partitioned deformation gradient @@ -111,15 +105,13 @@ subroutine homogenization_isostrain_partitionDeformation(F,avgF) F = spread(avgF,3,size(F,3)) -end subroutine homogenization_isostrain_partitionDeformation +end subroutine mech_isostrain_partitionDeformation !-------------------------------------------------------------------------------------------------- !> @brief derive average stress and stiffness from constituent quantities !-------------------------------------------------------------------------------------------------- -subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) - use prec, only: & - pReal +module subroutine mech_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,instance) implicit none real(pReal), dimension (3,3), intent(out) :: avgP !< average stress at material point @@ -128,7 +120,7 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P real(pReal), dimension (:,:,:), intent(in) :: P !< partitioned stresses real(pReal), dimension (:,:,:,:,:), intent(in) :: dPdF !< partitioned stiffnesses integer, intent(in) :: instance - + associate(prm => param(instance)) select case (prm%mapping) @@ -142,6 +134,6 @@ subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P end associate -end subroutine homogenization_isostrain_averageStressAndItsTangent +end subroutine mech_isostrain_averageStressAndItsTangent -end module homogenization_mech_isostrain +end submodule homogenization_mech_isostrain diff --git a/src/homogenization_mech_none.f90 b/src/homogenization_mech_none.f90 index a528203b1..4ac509363 100644 --- a/src/homogenization_mech_none.f90 +++ b/src/homogenization_mech_none.f90 @@ -4,20 +4,16 @@ !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @brief dummy homogenization homogenization scheme for 1 constituent per material point !-------------------------------------------------------------------------------------------------- -module homogenization_mech_none +submodule(homogenization) homogenization_mech_none implicit none - private - - public :: & - homogenization_none_init contains !-------------------------------------------------------------------------------------------------- !> @brief allocates all neccessary fields, reads information from material configuration file !-------------------------------------------------------------------------------------------------- -subroutine homogenization_none_init() +module subroutine mech_none_init use debug, only: & debug_HOMOGENIZATION, & debug_level, & @@ -55,6 +51,6 @@ subroutine homogenization_none_init() enddo -end subroutine homogenization_none_init +end subroutine mech_none_init -end module homogenization_mech_none +end submodule homogenization_mech_none From 8cc2a540f1aa934da26aa7b00fbf3b50512be247 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 5 Apr 2019 21:49:24 +0200 Subject: [PATCH 16/97] fixed test using old keyword --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index 1d1dc5c20..df55b24d7 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 1d1dc5c200e4723f501c3cb7a09ce74f5d6fe6b2 +Subproject commit df55b24d793c0fe71e3a3aaf038ff249e4878d57 From b52d5ab20be10a8813dfc8060e84fe1bc8cc4a78 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 5 Apr 2019 22:23:02 +0200 Subject: [PATCH 17/97] some more outputs mainly done by Vitesh, copied it from other branch --- src/plastic_disloUCLA.f90 | 2 +- src/plastic_dislotwin.f90 | 6 +-- src/plastic_kinematichardening.f90 | 21 ++++++++ src/plastic_none.f90 | 82 +++++++++++++++--------------- src/plastic_nonlocal.f90 | 35 ++++++++++++- src/plastic_phenopowerlaw.f90 | 13 +++-- 6 files changed, 109 insertions(+), 50 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 4fb83a6ce..8add0c025 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -580,7 +580,7 @@ subroutine plastic_disloUCLA_results(instance,group) 'dislocation dipole density''1/m²') case (dot_gamma_sl_ID) call results_writeDataset(group,stt%gamma_sl,'dot_gamma_sl',& - 'plastic slip','1') + 'plastic shear','1') case (Lambda_sl_ID) call results_writeDataset(group,dst%Lambda_sl,'Lambda_sl',& 'mean free path for slip','m') diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 1ad6f9763..3a3013304 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -1077,13 +1077,13 @@ subroutine plastic_dislotwin_results(instance,group) case (rho_mob_ID) call results_writeDataset(group,stt%rho_mob,'rho_mob',& - 'mobile dislocation density','1/m²') + 'mobile dislocation density','1/m²') case (rho_dip_ID) call results_writeDataset(group,stt%rho_dip,'rho_dip',& 'dislocation dipole density''1/m²') case (dot_gamma_sl_ID) call results_writeDataset(group,stt%gamma_sl,'dot_gamma_sl',& - 'plastic slip','1') + 'plastic shear','1') case (Lambda_sl_ID) call results_writeDataset(group,dst%Lambda_sl,'Lambda_sl',& 'mean free path for slip','m') @@ -1099,7 +1099,7 @@ subroutine plastic_dislotwin_results(instance,group) 'mean free path for twinning','m') case (tau_hat_tw_ID) call results_writeDataset(group,dst%tau_hat_tw,'tau_hat_tw',& - 'threshold stress for twinnin','Pa') + 'threshold stress for twinning','Pa') case (f_tr_ID) call results_writeDataset(group,stt%f_tr,'f_tr',& diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index ed1031354..77b8c9c6e 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -562,6 +562,27 @@ subroutine plastic_kinehardening_results(instance,group) associate(prm => param(instance), stt => state(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + case (crss_ID) + call results_writeDataset(group,stt%crss,'xi_sl', & + 'resistance against plastic slip','Pa') + + case(crss_back_ID) + call results_writeDataset(group,stt%crss_back,'tau_back', & + 'back stress against plastic slip','Pa') + + case (sense_ID) + call results_writeDataset(group,stt%sense,'sense_of_shear','tbd','1') + + case (chi0_ID) + call results_writeDataset(group,stt%chi0,'chi0','tbd','Pa') + + case (gamma0_ID) + call results_writeDataset(group,stt%gamma0,'gamma0','tbd','1') + + case (accshear_ID) + call results_writeDataset(group,stt%accshear,'gamma_sl', & + 'plastic shear','1') + end select enddo outputsLoop end associate diff --git a/src/plastic_none.f90 b/src/plastic_none.f90 index f8a64b55b..b73bd20ab 100644 --- a/src/plastic_none.f90 +++ b/src/plastic_none.f90 @@ -5,13 +5,13 @@ !> @brief Dummy plasticity for purely elastic material !-------------------------------------------------------------------------------------------------- module plastic_none - - implicit none - private - - public :: & - plastic_none_init - + + implicit none + private + + public :: & + plastic_none_init + contains !-------------------------------------------------------------------------------------------------- @@ -19,41 +19,39 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine plastic_none_init - use debug, only: & - debug_level, & - debug_constitutive, & - debug_levelBasic - use material, only: & - phase_plasticity, & - material_allocatePlasticState, & - PLASTICITY_NONE_label, & - PLASTICITY_NONE_ID, & - material_phase, & - plasticState - - implicit none - integer :: & - Ninstance, & - p, & - NipcMyPhase - - write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_NONE_label//' init -+>>>' - - Ninstance = count(phase_plasticity == PLASTICITY_NONE_ID) - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & - write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - - do p = 1, size(phase_plasticity) - if (phase_plasticity(p) /= PLASTICITY_NONE_ID) cycle - -!-------------------------------------------------------------------------------------------------- -! allocate state arrays - NipcMyPhase = count(material_phase == p) - call material_allocatePlasticState(p,NipcMyPhase,0,0,0, & - 0,0,0) - plasticState(p)%sizePostResults = 0 - - enddo + use debug, only: & + debug_level, & + debug_constitutive, & + debug_levelBasic + use material, only: & + phase_plasticity, & + material_allocatePlasticState, & + PLASTICITY_NONE_label, & + PLASTICITY_NONE_ID, & + material_phase, & + plasticState + + implicit none + integer :: & + Ninstance, & + p, & + NipcMyPhase + + write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_NONE_label//' init -+>>>' + + Ninstance = count(phase_plasticity == PLASTICITY_NONE_ID) + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + + do p = 1, size(phase_plasticity) + if (phase_plasticity(p) /= PLASTICITY_NONE_ID) cycle + + NipcMyPhase = count(material_phase == p) + call material_allocatePlasticState(p,NipcMyPhase,0,0,0, & + 0,0,0) + plasticState(p)%sizePostResults = 0 + + enddo end subroutine plastic_none_init diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index 0eec39ba1..662d7e973 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -2316,7 +2316,7 @@ outputsLoop: do o = 1,size(param(instance)%outputID) case (rho_dot_ann_ath_ID) postResults(cs+1:cs+ns) = results(instance)%rhoDotAthermalAnnihilation(1:ns,1,of) & - + results(instance)%rhoDotAthermalAnnihilation(1:ns,2,of) + + results(instance)%rhoDotAthermalAnnihilation(1:ns,2,of) cs = cs + ns case (rho_dot_ann_the_edge_ID) @@ -2413,6 +2413,39 @@ subroutine plastic_nonlocal_results(instance,group) associate(prm => param(instance), stt => state(instance)) outputsLoop: do o = 1,size(prm%outputID) select case(prm%outputID(o)) + case (rho_sgl_mob_edg_pos_ID) + call results_writeDataset(group,stt%rho_sgl_mob_edg_pos, 'rho_sgl_mob_edg_pos', & + 'positive mobile edge density','1/m²') + case (rho_sgl_imm_edg_pos_ID) + call results_writeDataset(group,stt%rho_sgl_imm_edg_pos, 'rho_sgl_imm_edg_pos',& + 'positive immobile edge density','1/m²') + case (rho_sgl_mob_edg_neg_ID) + call results_writeDataset(group,stt%rho_sgl_mob_edg_neg, 'rho_sgl_mob_edg_neg',& + 'negative mobile edge density','1/m²') + case (rho_sgl_imm_edg_neg_ID) + call results_writeDataset(group,stt%rho_sgl_imm_edg_neg, 'rho_sgl_imm_edg_neg',& + 'negative immobile edge density','1/m²') + case (rho_dip_edg_ID) + call results_writeDataset(group,stt%rho_dip_edg, 'rho_dip_edg',& + 'edge dipole density','1/m²') + case (rho_sgl_mob_scr_pos_ID) + call results_writeDataset(group,stt%rho_sgl_mob_scr_pos, 'rho_sgl_mob_scr_pos',& + 'positive mobile screw density','1/m²') + case (rho_sgl_imm_scr_pos_ID) + call results_writeDataset(group,stt%rho_sgl_imm_scr_pos, 'rho_sgl_imm_scr_pos',& + 'positive immobile screw density','1/m²') + case (rho_sgl_mob_scr_neg_ID) + call results_writeDataset(group,stt%rho_sgl_mob_scr_neg, 'rho_sgl_mob_scr_neg',& + 'negative mobile screw density','1/m²') + case (rho_sgl_imm_scr_neg_ID) + call results_writeDataset(group,stt%rho_sgl_imm_scr_neg, 'rho_sgl_imm_scr_neg',& + 'negative immobile screw density','1/m²') + case (rho_dip_scr_ID) + call results_writeDataset(group,stt%rho_dip_scr, 'rho_dip_scr',& + 'screw dipole density','1/m²') + case (rho_forest_ID) + call results_writeDataset(group,stt%rho_forest, 'rho_forest',& + 'forest density','1/m²') end select enddo outputsLoop end associate diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index de84fb12d..39e884dae 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -577,11 +577,18 @@ subroutine plastic_phenopowerlaw_results(instance,group) select case(prm%outputID(o)) case (resistance_slip_ID) - call results_writeDataset(group,stt%xi_slip, 'xi_slip', & + call results_writeDataset(group,stt%xi_slip, 'xi_sl', & 'resistance against plastic slip','Pa') case (accumulatedshear_slip_ID) - call results_writeDataset(group,stt%gamma_slip,'gamma_slip', & - 'plastic slip','1') + call results_writeDataset(group,stt%gamma_slip,'gamma_sl', & + 'plastic shear','1') + + case (resistance_twin_ID) + call results_writeDataset(group,stt%xi_twin, 'xi_tw', & + 'resistance against twinning','Pa') + case (accumulatedshear_twin_ID) + call results_writeDataset(group,stt%gamma_twin,'gamma_tw', & + 'twinning shear','1') end select enddo outputsLoop From 20a715116713879f4fc82e02519f6b2a1adec863 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 6 Apr 2019 07:09:46 +0000 Subject: [PATCH 18/97] test working for grid FEM --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index df55b24d7..f342bc7da 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit df55b24d793c0fe71e3a3aaf038ff249e4878d57 +Subproject commit f342bc7dabddf5a9c7786d14115145ef4b0f330b From 6553fe815edb1aedb4767f8752d544068effc07a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 6 Apr 2019 07:56:47 +0000 Subject: [PATCH 19/97] proper indentation --- src/constitutive.f90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index ada022e37..c4b9570b1 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -1126,22 +1126,22 @@ subroutine constitutive_results() select case(material_phase_plasticity_type(p)) case(PLASTICITY_ISOTROPIC_ID) - call plastic_isotropic_results(phase_plasticityInstance(p),group) + call plastic_isotropic_results(phase_plasticityInstance(p),group) case(PLASTICITY_PHENOPOWERLAW_ID) - call plastic_phenopowerlaw_results(phase_plasticityInstance(p),group) + call plastic_phenopowerlaw_results(phase_plasticityInstance(p),group) case(PLASTICITY_KINEHARDENING_ID) - call plastic_kinehardening_results(phase_plasticityInstance(p),group) + call plastic_kinehardening_results(phase_plasticityInstance(p),group) case(PLASTICITY_DISLOTWIN_ID) - call plastic_dislotwin_results(phase_plasticityInstance(p),group) + call plastic_dislotwin_results(phase_plasticityInstance(p),group) case(PLASTICITY_DISLOUCLA_ID) - call plastic_disloUCLA_results(phase_plasticityInstance(p),group) + call plastic_disloUCLA_results(phase_plasticityInstance(p),group) case(PLASTICITY_NONLOCAL_ID) - call plastic_nonlocal_results(phase_plasticityInstance(p),group) + call plastic_nonlocal_results(phase_plasticityInstance(p),group) end select enddo From ab5a29b559e7cabe308c61ed56331b836f99c48b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 6 Apr 2019 08:01:10 +0000 Subject: [PATCH 20/97] explicit import for some reasons, ifort does not resolve the specific subroutine for the writeDataset interace otherwise --- src/plastic_disloUCLA.f90 | 3 ++- src/plastic_dislotwin.f90 | 3 ++- src/plastic_isotropic.f90 | 3 ++- src/plastic_kinematichardening.f90 | 3 ++- src/plastic_nonlocal.f90 | 3 ++- src/plastic_phenopowerlaw.f90 | 3 ++- 6 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 8add0c025..19df4bdce 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -561,7 +561,8 @@ end function plastic_disloUCLA_postResults !-------------------------------------------------------------------------------------------------- subroutine plastic_disloUCLA_results(instance,group) #if defined(PETSc) || defined(DAMASK_HDF5) - use results + use results, only: & + results_writeDataset implicit none integer, intent(in) :: instance diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 3a3013304..8e52b3f41 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -1064,7 +1064,8 @@ end function plastic_dislotwin_postResults !-------------------------------------------------------------------------------------------------- subroutine plastic_dislotwin_results(instance,group) #if defined(PETSc) || defined(DAMASK_HDF5) - use results + use results, only: & + results_writeDataset implicit none integer, intent(in) :: instance diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 5134f866c..facfa6d80 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -485,7 +485,8 @@ end function plastic_isotropic_postResults !-------------------------------------------------------------------------------------------------- subroutine plastic_isotropic_results(instance,group) #if defined(PETSc) || defined(DAMASK_HDF5) - use results + use results, only: & + results_writeDataset implicit none integer, intent(in) :: instance diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 77b8c9c6e..04927c85b 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -552,7 +552,8 @@ end function plastic_kinehardening_postResults !-------------------------------------------------------------------------------------------------- subroutine plastic_kinehardening_results(instance,group) #if defined(PETSc) || defined(DAMASK_HDF5) - use results + use results, only: & + results_writeDataset implicit none integer, intent(in) :: instance diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index 662d7e973..a9ef98b06 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -2403,7 +2403,8 @@ end function getRho !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_results(instance,group) #if defined(PETSc) || defined(DAMASK_HDF5) - use results + use results, only: & + results_writeDataset implicit none integer, intent(in) :: instance diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 39e884dae..272c4d631 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -564,7 +564,8 @@ end function plastic_phenopowerlaw_postResults !-------------------------------------------------------------------------------------------------- subroutine plastic_phenopowerlaw_results(instance,group) #if defined(PETSc) || defined(DAMASK_HDF5) - use results + use results, only: & + results_writeDataset implicit none integer, intent(in) :: instance From a0c1822b9d30905732743dfb202a9638bb56e023 Mon Sep 17 00:00:00 2001 From: Test User Date: Sat, 6 Apr 2019 11:24:31 +0200 Subject: [PATCH 21/97] [skip ci] updated version information after successful test of v2.0.3-92-g20a71511 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index b1cf69273..5463ead9a 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.3-36-gbe387ab8 +v2.0.3-92-g20a71511 From 7af3e70061d4043dcb1fe85b9290b0221017a221 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 5 Apr 2019 22:26:23 +0200 Subject: [PATCH 22/97] no pInt --- src/constitutive.f90 | 100 +++++++++++++++++++++---------------------- 1 file changed, 50 insertions(+), 50 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index c4b9570b1..3c837c6ed 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -9,7 +9,7 @@ module constitutive implicit none private - integer(pInt), public, protected :: & + integer, public, protected :: & constitutive_plasticity_maxSizePostResults, & constitutive_plasticity_maxSizeDotState, & constitutive_source_maxSizePostResults, & @@ -37,7 +37,7 @@ contains !-------------------------------------------------------------------------------------------------- !> @brief allocates arrays pointing to array of the various constitutive modules !-------------------------------------------------------------------------------------------------- -subroutine constitutive_init() +subroutine constitutive_init use prec, only: & pReal use debug, only: & @@ -111,14 +111,14 @@ subroutine constitutive_init() use kinematics_thermal_expansion implicit none - integer(pInt), parameter :: FILEUNIT = 204_pInt - integer(pInt) :: & + integer, parameter :: FILEUNIT = 204 + integer :: & o, & !< counter in output loop ph, & !< counter in phase loop s, & !< counter in source loop ins !< instance of plasticity/source - integer(pInt), dimension(:,:), pointer :: thisSize + integer, dimension(:,:), pointer :: thisSize character(len=64), dimension(:,:), pointer :: thisOutput character(len=32) :: outputName !< name of output, intermediate fix until HDF5 output is ready logical :: knownPlasticity, knownSource, nonlocalConstitutionPresent @@ -157,7 +157,7 @@ subroutine constitutive_init() !-------------------------------------------------------------------------------------------------- ! write description file for constitutive output call IO_write_jobFile(FILEUNIT,'outputConstitutive') - PhaseLoop: do ph = 1_pInt,material_Nphase + PhaseLoop: do ph = 1,material_Nphase activePhase: if (any(material_phase == ph)) then ins = phase_plasticityInstance(ph) knownPlasticity = .true. ! assume valid @@ -197,14 +197,14 @@ subroutine constitutive_init() if (knownPlasticity) then write(FILEUNIT,'(a)') '(plasticity)'//char(9)//trim(outputName) if (phase_plasticity(ph) /= PLASTICITY_NONE_ID) then - OutputPlasticityLoop: do o = 1_pInt,size(thisOutput(:,ins)) - if(len(trim(thisOutput(o,ins))) > 0_pInt) & + OutputPlasticityLoop: do o = 1,size(thisOutput(:,ins)) + if(len(trim(thisOutput(o,ins))) > 0) & write(FILEUNIT,'(a,i4)') trim(thisOutput(o,ins))//char(9),thisSize(o,ins) enddo OutputPlasticityLoop endif endif - SourceLoop: do s = 1_pInt, phase_Nsources(ph) + SourceLoop: do s = 1, phase_Nsources(ph) knownSource = .true. ! assume valid sourceType: select case (phase_source(s,ph)) case (SOURCE_thermal_dissipation_ID) sourceType @@ -242,8 +242,8 @@ subroutine constitutive_init() end select sourceType if (knownSource) then write(FILEUNIT,'(a)') '(source)'//char(9)//trim(outputName) - OutputSourceLoop: do o = 1_pInt,size(thisOutput(:,ins)) - if(len(trim(thisOutput(o,ins))) > 0_pInt) & + OutputSourceLoop: do o = 1,size(thisOutput(:,ins)) + if(len(trim(thisOutput(o,ins))) > 0) & write(FILEUNIT,'(a,i4)') trim(thisOutput(o,ins))//char(9),thisSize(o,ins) enddo OutputSourceLoop endif @@ -253,17 +253,17 @@ subroutine constitutive_init() close(FILEUNIT) endif mainProcess - constitutive_plasticity_maxSizeDotState = 0_pInt - constitutive_plasticity_maxSizePostResults = 0_pInt - constitutive_source_maxSizeDotState = 0_pInt - constitutive_source_maxSizePostResults = 0_pInt + constitutive_plasticity_maxSizeDotState = 0 + constitutive_plasticity_maxSizePostResults = 0 + constitutive_source_maxSizeDotState = 0 + constitutive_source_maxSizePostResults = 0 - PhaseLoop2:do ph = 1_pInt,material_Nphase + PhaseLoop2:do ph = 1,material_Nphase !-------------------------------------------------------------------------------------------------- ! partition and inititalize state plasticState(ph)%partionedState0 = plasticState(ph)%state0 plasticState(ph)%state = plasticState(ph)%partionedState0 - forall(s = 1_pInt:phase_Nsources(ph)) + forall(s = 1:phase_Nsources(ph)) sourceState(ph)%p(s)%partionedState0 = sourceState(ph)%p(s)%state0 sourceState(ph)%p(s)%state = sourceState(ph)%p(s)%partionedState0 end forall @@ -302,7 +302,7 @@ function constitutive_homogenizedC(ipc,ip,el) implicit none real(pReal), dimension(6,6) :: constitutive_homogenizedC - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -341,14 +341,14 @@ subroutine constitutive_microstructure(Fe, Fp, ipc, ip, el) plastic_disloUCLA_dependentState implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element real(pReal), intent(in), dimension(3,3) :: & Fe, & !< elastic deformation gradient Fp !< plastic deformation gradient - integer(pInt) :: & + integer :: & ho, & !< homogenization tme, & !< thermal member position instance, of @@ -412,7 +412,7 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & plastic_nonlocal_LpAndItsTangent implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -428,10 +428,10 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & dLp_dMp !< derivative of Lp with respect to Mandel stress real(pReal), dimension(3,3) :: & Mp !< Mandel stress work conjugate with Lp - integer(pInt) :: & + integer :: & ho, & !< homogenization tme !< thermal member position - integer(pInt) :: & + integer :: & i, j, instance, of ho = material_homogenizationAt(el) @@ -519,7 +519,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & kinematics_thermal_expansion_LiAndItsTangent implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -541,7 +541,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & my_dLi_dS real(pReal) :: & detFi - integer(pInt) :: & + integer :: & k, i, j, & instance, of @@ -562,7 +562,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & Li = Li + my_Li dLi_dS = dLi_dS + my_dLi_dS - KinematicsLoop: do k = 1_pInt, phase_Nkinematics(material_phase(ipc,ip,el)) + KinematicsLoop: do k = 1, phase_Nkinematics(material_phase(ipc,ip,el)) kinematicsType: select case (phase_kinematics(k,material_phase(ipc,ip,el))) case (KINEMATICS_cleavage_opening_ID) kinematicsType call kinematics_cleavage_opening_LiAndItsTangent(my_Li, my_dLi_dS, S, ipc, ip, el) @@ -583,7 +583,7 @@ subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & Li = matmul(matmul(Fi,Li),FiInv)*detFi !< push forward to intermediate configuration temp_33 = matmul(FiInv,Li) - do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt + do i = 1,3; do j = 1,3 dLi_dS(1:3,1:3,i,j) = matmul(matmul(Fi,dLi_dS(1:3,1:3,i,j)),FiInv)*detFi dLi_dFi(1:3,1:3,i,j) = dLi_dFi(1:3,1:3,i,j) + Li*FiInv(j,i) dLi_dFi(1:3,i,1:3,j) = dLi_dFi(1:3,i,1:3,j) + math_I3*temp_33(j,i) + Li*FiInv(j,i) @@ -612,22 +612,22 @@ pure function constitutive_initialFi(ipc, ip, el) kinematics_thermal_expansion_initialStrain implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element real(pReal), dimension(3,3) :: & constitutive_initialFi !< composite initial intermediate deformation gradient - integer(pInt) :: & + integer :: & k !< counter in kinematics loop - integer(pInt) :: & + integer :: & phase, & homog, offset constitutive_initialFi = math_I3 phase = material_phase(ipc,ip,el) - KinematicsLoop: do k = 1_pInt, phase_Nkinematics(phase) !< Warning: small initial strain assumption + KinematicsLoop: do k = 1, phase_Nkinematics(phase) !< Warning: small initial strain assumption kinematicsType: select case (phase_kinematics(k,phase)) case (KINEMATICS_thermal_expansion_ID) kinematicsType homog = material_homogenizationAt(el) @@ -650,7 +650,7 @@ subroutine constitutive_SandItsTangents(S, dS_dFe, dS_dFi, Fe, Fi, ipc, ip, el) pReal implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -691,7 +691,7 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & STIFFNESS_DEGRADATION_damage_ID implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -705,19 +705,19 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & dS_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient real(pReal), dimension(3,3) :: E real(pReal), dimension(3,3,3,3) :: C - integer(pInt) :: & + integer :: & ho, & !< homogenization d !< counter in degradation loop - integer(pInt) :: & + integer :: & i, j ho = material_homogenizationAt(el) C = math_66toSym3333(constitutive_homogenizedC(ipc,ip,el)) - DegradationLoop: do d = 1_pInt, phase_NstiffnessDegradations(material_phase(ipc,ip,el)) + DegradationLoop: do d = 1, phase_NstiffnessDegradations(material_phase(ipc,ip,el)) degradationType: select case(phase_stiffnessDegradation(d,material_phase(ipc,ip,el))) case (STIFFNESS_DEGRADATION_damage_ID) degradationType - C = C * damage(ho)%p(damageMapping(ho)%p(ip,el))**2_pInt + C = C * damage(ho)%p(damageMapping(ho)%p(ip,el))**2 end select degradationType enddo DegradationLoop @@ -725,7 +725,7 @@ subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & S = math_mul3333xx33(C,matmul(matmul(transpose(Fi),E),Fi)) !< 2PK stress in lattice configuration in work conjugate with GL strain pulled back to lattice configuration dS_dFe = 0.0_pReal - forall (i=1_pInt:3_pInt, j=1_pInt:3_pInt) + forall (i=1:3, j=1:3) dS_dFe(i,j,1:3,1:3) = & matmul(Fe,matmul(matmul(Fi,C(i,j,1:3,1:3)),transpose(Fi))) !< dS_ij/dFe_kl = C_ijmn * Fi_lm * Fi_on * Fe_ko dS_dFi(i,j,1:3,1:3) = 2.0_pReal*matmul(matmul(E,Fi),C(i,j,1:3,1:3)) !< dS_ij/dFi_kl = C_ijln * E_km * Fe_mn @@ -790,7 +790,7 @@ subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, source_thermal_externalheat_dotState implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -805,7 +805,7 @@ subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, S !< 2nd Piola Kirchhoff stress (vector notation) real(pReal), dimension(3,3) :: & Mp - integer(pInt) :: & + integer :: & ho, & !< homogenization tme, & !< thermal member position i, & !< counter in source loop @@ -848,7 +848,7 @@ subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, subdt,ip,el) end select plasticityType - SourceLoop: do i = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) + SourceLoop: do i = 1, phase_Nsources(material_phase(ipc,ip,el)) sourceType: select case (phase_source(i,material_phase(ipc,ip,el))) @@ -900,7 +900,7 @@ subroutine constitutive_collectDeltaState(S, Fe, Fi, ipc, ip, el) source_damage_isoBrittle_deltaState implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -910,7 +910,7 @@ subroutine constitutive_collectDeltaState(S, Fe, Fi, ipc, ip, el) Fi !< intermediate deformation gradient real(pReal), dimension(3,3) :: & Mp - integer(pInt) :: & + integer :: & i, & instance, of @@ -928,7 +928,7 @@ subroutine constitutive_collectDeltaState(S, Fe, Fi, ipc, ip, el) end select plasticityType - sourceLoop: do i = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) + sourceLoop: do i = 1, phase_Nsources(material_phase(ipc,ip,el)) sourceType: select case (phase_source(i,material_phase(ipc,ip,el))) @@ -994,7 +994,7 @@ function constitutive_postResults(S, Fi, ipc, ip, el) source_damage_anisoDuctile_postResults implicit none - integer(pInt), intent(in) :: & + integer, intent(in) :: & ipc, & !< component-ID of integration point ip, & !< integration point el !< element @@ -1007,9 +1007,9 @@ function constitutive_postResults(S, Fi, ipc, ip, el) S !< 2nd Piola Kirchhoff stress real(pReal), dimension(3,3) :: & Mp !< Mandel stress - integer(pInt) :: & + integer :: & startPos, endPos - integer(pInt) :: & + integer :: & ho, & !< homogenization tme, & !< thermal member position i, of, instance !< counter in source loop @@ -1021,7 +1021,7 @@ function constitutive_postResults(S, Fi, ipc, ip, el) ho = material_homogenizationAt(el) tme = thermalMapping(ho)%p(ip,el) - startPos = 1_pInt + startPos = 1 endPos = plasticState(material_phase(ipc,ip,el))%sizePostResults of = phasememberAt(ipc,ip,el) @@ -1054,8 +1054,8 @@ function constitutive_postResults(S, Fi, ipc, ip, el) end select plasticityType - SourceLoop: do i = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) - startPos = endPos + 1_pInt + SourceLoop: do i = 1, phase_Nsources(material_phase(ipc,ip,el)) + startPos = endPos + 1 endPos = endPos + sourceState(material_phase(ipc,ip,el))%p(i)%sizePostResults of = phasememberAt(ipc,ip,el) sourceType: select case (phase_source(i,material_phase(ipc,ip,el))) From bfb6ad557ffda360236d6491c0e590b0ba9e4d98 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 6 Apr 2019 06:31:02 +0200 Subject: [PATCH 23/97] WIP: crystallite HDF5 results will be stored according to the phase sections --- src/CPFEM2.f90 | 5 ++- src/constitutive.f90 | 7 ++--- src/crystallite.f90 | 74 ++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 78 insertions(+), 8 deletions(-) diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index c6f08cbf6..45e423fe3 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -300,6 +300,8 @@ subroutine CPFEM_results(inc,time) use HDF5_utilities use constitutive, only: & constitutive_results + use crystallite, only: & + crystallite_results implicit none integer(pInt), intent(in) :: inc @@ -307,7 +309,8 @@ subroutine CPFEM_results(inc,time) call results_openJobFile call results_addIncrement(inc,time) - call constitutive_results() + call constitutive_results + call crystallite_results call results_removeLink('current') ! ToDo: put this into closeJobFile call results_closeJobFile diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 3c837c6ed..ea349e7ac 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -50,8 +50,7 @@ subroutine constitutive_init IO_write_jobFile use config, only: & material_Nphase, & - phase_name, & - config_deallocate + phase_name use material, only: & material_phase, & phase_plasticity, & @@ -149,8 +148,6 @@ subroutine constitutive_init if (any(phase_kinematics == KINEMATICS_slipplane_opening_ID)) call kinematics_slipplane_opening_init if (any(phase_kinematics == KINEMATICS_thermal_expansion_ID)) call kinematics_thermal_expansion_init - call config_deallocate('material.config/phase') - write(6,'(/,a)') ' <<<+- constitutive init -+>>>' mainProcess: if (worldrank == 0) then @@ -1077,7 +1074,7 @@ end function constitutive_postResults !-------------------------------------------------------------------------------------------------- !> @brief writes constitutive results to HDF5 output file !-------------------------------------------------------------------------------------------------- -subroutine constitutive_results() +subroutine constitutive_results use material, only: & PLASTICITY_ISOTROPIC_ID, & PLASTICITY_PHENOPOWERLAW_ID, & diff --git a/src/crystallite.f90 b/src/crystallite.f90 index b234d133d..b68cdc86e 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -10,7 +10,8 @@ module crystallite use prec, only: & - pReal + pReal, & + pStringLen use rotations, only: & rotation use FEsolving, only: & @@ -103,6 +104,8 @@ module crystallite end enum integer(kind(undefined_ID)),dimension(:,:), allocatable, private :: & crystallite_outputID !< ID of each post result output + character(len=pStringLen), dimension(:), allocatable, private :: & + constituent_output procedure(), pointer :: integrateState public :: & @@ -111,7 +114,8 @@ module crystallite crystallite_stressTangent, & crystallite_orientations, & crystallite_push33ToRef, & - crystallite_postResults + crystallite_postResults, & + crystallite_results private :: & integrateStress, & integrateState, & @@ -156,6 +160,7 @@ subroutine crystallite_init use config, only: & config_deallocate, & config_crystallite, & + config_phase, & crystallite_name use constitutive, only: & constitutive_initialFi, & @@ -296,6 +301,21 @@ subroutine crystallite_init end select outputName enddo enddo + + allocate(constituent_output(size(config_phase))) + do c = 1, size(config_phase) +#if defined(__GFORTRAN__) + str = ['GfortranBug86277'] + str = config_crystallite(c)%getStrings('(output)',defaultVal=str) + if (str(1) == 'GfortranBug86277') str = [character(len=65536)::] +#else + str = config_crystallite(c)%getStrings('(output)',defaultVal=[character(len=65536)::]) +#endif + constituent_output(c) = '+' + do o = 1, size(str) + constituent_output(c) = trim(constituent_output(c))//trim(str(o))//'+' + enddo + enddo do r = 1,size(config_crystallite) @@ -340,6 +360,7 @@ subroutine crystallite_init close(FILEUNIT) endif + call config_deallocate('material.config/phase') call config_deallocate('material.config/crystallite') !-------------------------------------------------------------------------------------------------- @@ -1053,6 +1074,55 @@ function crystallite_postResults(ipc, ip, el) end function crystallite_postResults +!-------------------------------------------------------------------------------------------------- +!> @brief writes constitutive results to HDF5 output file +!-------------------------------------------------------------------------------------------------- +subroutine crystallite_results +#if defined(PETSc) || defined(DAMASK_HDF5) + use results + use HDF5_utilities + use config, only: & + config_name_phase => phase_name ! anticipate logical name + + use material, only: & + material_phaseAt, & + phase_plasticityInstance, & + material_phase_plasticity_type => phase_plasticity + + implicit none + integer :: p + real(pReal), allocatable, dimension(:,:,:) :: packe + character(len=256) :: group + character(len=16) :: i + + call HDF5_closeGroup(results_addGroup('current/constituent')) + + do p=1,size(config_name_phase) + write(i,('(i2.2)')) p ! allow 99 groups + group = trim('current/constituent')//'/'//trim(i)//'_'//trim(config_name_phase(p)) + if (index(constituent_output(p),'+f+') /= 0) then + print*, 'f' + endif + if (index(constituent_output(p),'+p+') /= 0) then + print*, 'p' + endif + enddo + + contains + + function packed(res) + + real(pReal), dimension(:,:,:,:,:), intent(in) :: res + real(pReal), allocatable, dimension(:,:,:) :: packed + + + end function packed +#endif + + +end subroutine crystallite_results + + !-------------------------------------------------------------------------------------------------- !> @brief calculation of stress (P) with time integration based on a residuum in Lp and !> intermediate acceleration of the Newton-Raphson correction From 1aed224c3b0a249fe33babe6eb0839da8d0bbe9a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 6 Apr 2019 11:23:31 +0200 Subject: [PATCH 24/97] numerically more stable avoids division by zero --- src/rotations.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/rotations.f90 b/src/rotations.f90 index b899adacb..7c29b03bc 100644 --- a/src/rotations.f90 +++ b/src/rotations.f90 @@ -777,12 +777,12 @@ pure function qu2ax(qu) result(ax) real(pReal) :: omega, s - omega = 2.0 * acos(math_clip(qu%w,-1.0_pReal,1.0_pReal)) ! if the angle equals zero, then we return the rotation axis as [001] - if (dEq0(omega)) then - ax = [ 0.0, 0.0, 1.0, 0.0 ] + if (dEq0(sqrt(qu%x**2+qu%y**2+qu%z**2))) then + ax = [ 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal ] elseif (dNeq0(qu%w)) then s = sign(1.0_pReal,qu%w)/sqrt(qu%x**2+qu%y**2+qu%z**2) + omega = 2.0_pReal * acos(math_clip(qu%w,-1.0_pReal,1.0_pReal)) ax = [ qu%x*s, qu%y*s, qu%z*s, omega ] else ax = [ qu%x, qu%y, qu%z, PI ] From 5075e1c2fbe130ec1375ffcfb571f4643eab0bc7 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 6 Apr 2019 12:06:34 +0200 Subject: [PATCH 25/97] constituent (ex crystallite) results are stored in HDF5 currently, not the best code but new structure for crystallite data will fix that output of orientations still missing --- src/crystallite.f90 | 102 +++++++++++++++++++++++++++++++++----------- 1 file changed, 77 insertions(+), 25 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index b68cdc86e..1057ec4c6 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -104,8 +104,13 @@ module crystallite end enum integer(kind(undefined_ID)),dimension(:,:), allocatable, private :: & crystallite_outputID !< ID of each post result output - character(len=pStringLen), dimension(:), allocatable, private :: & - constituent_output + + type, private :: tOutput !< new requested output (per phase) + character(len=65536), allocatable, dimension(:) :: & + label + end type tOutput + type(tOutput), allocatable, dimension(:), private :: output_constituent + procedure(), pointer :: integrateState public :: & @@ -302,19 +307,16 @@ subroutine crystallite_init enddo enddo - allocate(constituent_output(size(config_phase))) + allocate(output_constituent(size(config_phase))) do c = 1, size(config_phase) #if defined(__GFORTRAN__) - str = ['GfortranBug86277'] - str = config_crystallite(c)%getStrings('(output)',defaultVal=str) - if (str(1) == 'GfortranBug86277') str = [character(len=65536)::] + allocate(output_constituent(c)%label(1)) + output_constituent(c)%label(1)= 'GfortranBug86277' + output_constituent(c)%label = config_phase(c)%getStrings('(output)',defaultVal=output_constituent(c)%label ) + if (output_constituent(c)%label (1) == 'GfortranBug86277') output_constituent(c)%label = [character(len=pStringLen)::] #else - str = config_crystallite(c)%getStrings('(output)',defaultVal=[character(len=65536)::]) + output_constituent(c)%label = config_phase(c)%getStrings('(output)',defaultVal=[character(len=pStringLen)::]) #endif - constituent_output(c) = '+' - do o = 1, size(str) - constituent_output(c) = trim(constituent_output(c))//trim(str(o))//'+' - enddo enddo @@ -1085,35 +1087,85 @@ subroutine crystallite_results config_name_phase => phase_name ! anticipate logical name use material, only: & - material_phaseAt, & - phase_plasticityInstance, & material_phase_plasticity_type => phase_plasticity implicit none - integer :: p - real(pReal), allocatable, dimension(:,:,:) :: packe + integer :: p,o + real(pReal), allocatable, dimension(:,:,:) :: selected character(len=256) :: group - character(len=16) :: i + character(len=16) :: j call HDF5_closeGroup(results_addGroup('current/constituent')) do p=1,size(config_name_phase) - write(i,('(i2.2)')) p ! allow 99 groups - group = trim('current/constituent')//'/'//trim(i)//'_'//trim(config_name_phase(p)) - if (index(constituent_output(p),'+f+') /= 0) then - print*, 'f' - endif - if (index(constituent_output(p),'+p+') /= 0) then - print*, 'p' - endif + write(j,('(i2.2)')) p ! allow 99 groups + group = trim('current/constituent')//'/'//trim(j)//'_'//trim(config_name_phase(p)) + call HDF5_closeGroup(results_addGroup(group)) + do o = 1, size(output_constituent(p)%label) + select case (output_constituent(p)%label(o)) + case('f') + selected = packed(crystallite_partionedF,p) + call results_writeDataset(group,selected,'F',& + 'deformation gradient','1') + case('fe') + selected = packed(crystallite_Fe,p) + call results_writeDataset(group,selected,'Fe',& + 'elastic deformation gradient','1') + case('fp') + selected = packed(crystallite_Fp,p) + call results_writeDataset(group,selected,'Fp',& + 'plastic deformation gradient','1') + case('fi') + selected = packed(crystallite_Fi,p) + call results_writeDataset(group,selected,'Fi',& + 'inelastic deformation gradient','1') + case('lp') + selected = packed(crystallite_Lp,p) + call results_writeDataset(group,selected,'Lp',& + 'plastic velocity gradient','1/s') + case('li') + selected = packed(crystallite_Li,p) + call results_writeDataset(group,selected,'Li',& + 'inelastic velocity gradient','1/s') + case('p') + selected = packed(crystallite_P,p) + call results_writeDataset(group,selected,'P',& + '1st Piola-Kirchoff stress','Pa') + case('s') + selected = packed(crystallite_S,p) + call results_writeDataset(group,selected,'S',& + '2nd Piola-Kirchoff stress','Pa') + end select + enddo enddo contains - function packed(res) + function packed(res,instance) + use material, only: & + homogenization_maxNgrains, & + material_phaseAt + + integer, intent(in) :: instance real(pReal), dimension(:,:,:,:,:), intent(in) :: res real(pReal), allocatable, dimension(:,:,:) :: packed + integer :: e,i,c,j + + allocate(packed(3,3,count(material_phaseAt==instance)*homogenization_maxNgrains)) +!--------------------------------------------------------------------------------------------------- +! expand phaseAt to consider IPs (is not stored per IP) + j=1 + do e = 1, size(material_phaseAt,2) + do i = 1, homogenization_maxNgrains + do c = 1, size(material_phaseAt,1) + if (material_phaseAt(c,e) == instance) then + packed(1:3,1:3,j) = res(1:3,1:3,c,i,e) + j = j + 1 + endif + enddo + enddo + enddo end function packed From 0b2c6c69c27198990ea58ce4f9d6abd78670f978 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 7 Apr 2019 13:20:44 +0200 Subject: [PATCH 26/97] number ID as prefix to section names enables unique and consistent section names for output --- src/config.f90 | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/config.f90 b/src/config.f90 index 23268d1de..f86057b25 100644 --- a/src/config.f90 +++ b/src/config.f90 @@ -231,15 +231,21 @@ end function read_materialConfig !-------------------------------------------------------------------------------------------------- subroutine parse_materialConfig(sectionNames,part,line, & fileContent) + use prec, only: & + pStringLen + use IO, only: & + IO_intOut + implicit none character(len=64), allocatable, dimension(:), intent(out) :: sectionNames type(tPartitionedStringList), allocatable, dimension(:), intent(inout) :: part character(len=pStringLen), intent(inout) :: line character(len=pStringLen), dimension(:), intent(in) :: fileContent - integer, allocatable, dimension(:) :: partPosition ! position of [] tags + last line in section - integer :: i, j - logical :: echo + integer, allocatable, dimension(:) :: partPosition !< position of [] tags + last line in section + integer :: i, j + logical :: echo + character(len=pStringLen) :: section_ID echo = .false. @@ -263,7 +269,8 @@ subroutine parse_materialConfig(sectionNames,part,line, & partPosition = [partPosition, i] ! needed when actually storing content do i = 1, size(partPosition) -1 - sectionNames(i) = trim(adjustl(IO_getTag(fileContent(partPosition(i)),'[',']'))) + write(section_ID,'('//IO_intOut(size(partPosition))//')') i + sectionNames(i) = trim(section_ID)//'_'//trim(adjustl(IO_getTag(fileContent(partPosition(i)),'[',']'))) do j = partPosition(i) + 1, partPosition(i+1) -1 call part(i)%add(trim(adjustl(fileContent(j)))) enddo From d6d3f7aad7896d919ebb3fd8f0643b29d9f0f623 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 7 Apr 2019 13:26:23 +0200 Subject: [PATCH 27/97] write rotation as quaternion to HDF5 in named type --- src/HDF5_utilities.f90 | 82 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index dd1746f5c..8ce8bd4cc 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -58,6 +58,8 @@ module HDF5_utilities module procedure HDF5_write_int5 module procedure HDF5_write_int6 module procedure HDF5_write_int7 + + module procedure HDF5_write_rotation end interface HDF5_write @@ -1621,6 +1623,86 @@ subroutine HDF5_write_int7(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_int7 +!-------------------------------------------------------------------------------------------------- +!> @brief writes a scalar orientation dataset +! ToDo: It might be possible to write the dataset as a whole +! ToDo: We could add the crystal structure as an attribute +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_write_rotation(loc_id,dataset,datasetName,parallel) + use rotations + use numerics, only: & + worldrank, & + worldsize + + implicit none + type(rotation), intent(in), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel + + integer :: hdferr + real(pReal), dimension(4,size(dataset)) :: dataset_asArray + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id,dtype_id,w_id,x_id,y_id,z_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer(SIZE_T) :: type_size_real + integer :: i + + do i = 1, size(dataset) + dataset_asArray(1:4,i) = dataset(i)%asQuaternion() + enddo + +!--------------------------------------------------------------------------------------------------- +! determine shape of dataset + myShape = int(shape(dataset),HSIZE_T) + +!--------------------------------------------------------------------------------------------------- +! compound type: name of phase section + position/index within results array + call h5tget_size_f(H5T_NATIVE_DOUBLE, type_size_real, hdferr) + + call h5tcreate_f(H5T_COMPOUND_F, type_size_real*4_SIZE_T, dtype_id, hdferr) + call h5tinsert_f(dtype_id, "w", type_size_real*0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tinsert_f(dtype_id, "x", type_size_real*1_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tinsert_f(dtype_id, "y", type_size_real*2_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tinsert_f(dtype_id, "z", type_size_real*3_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,dtype_id,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,dtype_id,.false.) + endif + call h5pset_preserve_f(plist_id, .TRUE., hdferr) + + if (product(totalShape) /= 0) then + call h5tcreate_f(H5T_COMPOUND_F, type_size_real, x_id, hdferr) + call h5tinsert_f(x_id, "x", 0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tcreate_f(H5T_COMPOUND_F, type_size_real, w_id, hdferr) + call h5tinsert_f(w_id, "w", 0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tcreate_f(H5T_COMPOUND_F, type_size_real, y_id, hdferr) + call h5tinsert_f(y_id, "y", 0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + call h5tcreate_f(H5T_COMPOUND_F, type_size_real, z_id, hdferr) + call h5tinsert_f(z_id, "z", 0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) + + call h5dwrite_f(dset_id, w_id,dataset_asArray(1,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + call h5dwrite_f(dset_id, x_id,dataset_asArray(2,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + call h5dwrite_f(dset_id, y_id,dataset_asArray(3,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + call h5dwrite_f(dset_id, z_id,dataset_asArray(4,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_rotation: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + +end subroutine HDF5_write_rotation + + !-------------------------------------------------------------------------------------------------- !> @brief initialize HDF5 handles, determines global shape and start for parallel read !-------------------------------------------------------------------------------------------------- From b2e293057a5fe0f2a3c693836d3488020858e261 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 7 Apr 2019 14:02:24 +0200 Subject: [PATCH 28/97] write rotation to results file --- src/results.f90 | 38 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 36 insertions(+), 2 deletions(-) diff --git a/src/results.f90 b/src/results.f90 index 0580436b8..ce4105b73 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -16,11 +16,16 @@ module results integer(HID_T), private :: resultsFile, currentIncID, plist_id interface results_writeDataset + module procedure results_writeTensorDataset_real - module procedure results_writeTensorDataset_int module procedure results_writeVectorDataset_real - module procedure results_writeVectorDataset_int module procedure results_writeScalarDataset_real + + module procedure results_writeTensorDataset_int + module procedure results_writeVectorDataset_int + + module procedure results_writeScalarDataset_rotation + end interface results_writeDataset public :: & @@ -307,6 +312,35 @@ subroutine results_writeTensorDataset_int(group,dataset,label,description,SIunit end subroutine results_writeTensorDataset_int +!-------------------------------------------------------------------------------------------------- +!> @brief stores a vector dataset in a group +!-------------------------------------------------------------------------------------------------- +subroutine results_writeScalarDataset_rotation(group,dataset,label,description,SIunit) + use rotations, only: & + rotation + + implicit none + character(len=*), intent(in) :: label,group,description + character(len=*), intent(in), optional :: lattice_structure + type(rotation), intent(inout), dimension(:) :: dataset + + integer(HID_T) :: groupHandle + + groupHandle = results_openGroup(group) + +#ifdef PETSc + call HDF5_write(groupHandle,dataset,label,.true.) +#endif + + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Description',description,label) + if (HDF5_objectExists(groupHandle,label) .and. present(lattice_structure)) & + call HDF5_addAttribute(groupHandle,'Lattice',lattice_structure,label) + call HDF5_closeGroup(groupHandle) + +end subroutine results_writeScalarDataset_rotation + + !-------------------------------------------------------------------------------------------------- !> @brief adds the unique mapping from spatial position and constituent ID to results !-------------------------------------------------------------------------------------------------- From 7d0ebc4dedd5b0a268351a0a281da476f96714f8 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 7 Apr 2019 14:05:31 +0200 Subject: [PATCH 29/97] implicit none only needed once per module --- src/HDF5_utilities.f90 | 837 ++++++++++++++++++++--------------------- src/results.f90 | 176 ++++----- 2 files changed, 478 insertions(+), 535 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 8ce8bd4cc..0b92b9b1e 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -94,7 +94,6 @@ contains !-------------------------------------------------------------------------------------------------- subroutine HDF5_utilities_init - implicit none integer :: hdferr integer(SIZE_T) :: typeSize @@ -123,7 +122,6 @@ end subroutine HDF5_utilities_init !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_openFile(fileName,mode,parallel) ! ToDo: simply "open" is enough - implicit none character(len=*), intent(in) :: fileName character, intent(in), optional :: mode logical, intent(in), optional :: parallel @@ -172,7 +170,6 @@ end function HDF5_openFile !-------------------------------------------------------------------------------------------------- subroutine HDF5_closeFile(fileHandle) - implicit none integer(HID_T), intent(in) :: fileHandle integer :: hdferr @@ -188,7 +185,6 @@ end subroutine HDF5_closeFile !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_addGroup(fileHandle,groupName) - implicit none integer(HID_T), intent(in) :: fileHandle character(len=*), intent(in) :: groupName @@ -212,6 +208,8 @@ integer(HID_T) function HDF5_addGroup(fileHandle,groupName) call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') + call h5pclose_f(aplist_id) + end function HDF5_addGroup @@ -220,7 +218,6 @@ end function HDF5_addGroup !-------------------------------------------------------------------------------------------------- integer(HID_T) function HDF5_openGroup(fileHandle,groupName) - implicit none integer(HID_T), intent(in) :: fileHandle character(len=*), intent(in) :: groupName @@ -247,6 +244,8 @@ integer(HID_T) function HDF5_openGroup(fileHandle,groupName) call h5gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') + call h5pclose_f(aplist_id) + end function HDF5_openGroup @@ -255,7 +254,6 @@ end function HDF5_openGroup !-------------------------------------------------------------------------------------------------- subroutine HDF5_closeGroup(group_id) - implicit none integer(HID_T), intent(in) :: group_id integer :: hdferr @@ -270,7 +268,6 @@ end subroutine HDF5_closeGroup !-------------------------------------------------------------------------------------------------- logical function HDF5_objectExists(loc_id,path) - implicit none integer(HID_T), intent(in) :: loc_id character(len=*), intent(in), optional :: path integer :: hdferr @@ -298,7 +295,6 @@ end function HDF5_objectExists !-------------------------------------------------------------------------------------------------- subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path) - implicit none integer(HID_T), intent(in) :: loc_id character(len=*), intent(in) :: attrLabel, attrValue character(len=*), intent(in), optional :: path @@ -344,7 +340,6 @@ end subroutine HDF5_addAttribute_str !-------------------------------------------------------------------------------------------------- subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path) - implicit none integer(HID_T), intent(in) :: loc_id character(len=*), intent(in) :: attrLabel integer(pInt), intent(in) :: attrValue @@ -391,7 +386,6 @@ end subroutine HDF5_addAttribute_int !-------------------------------------------------------------------------------------------------- subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path) - implicit none integer(HID_T), intent(in) :: loc_id character(len=*), intent(in) :: attrLabel real(pReal), intent(in) :: attrValue @@ -438,7 +432,6 @@ end subroutine HDF5_addAttribute_real !-------------------------------------------------------------------------------------------------- subroutine HDF5_setLink(loc_id,target_name,link_name) - implicit none character(len=*), intent(in) :: target_name, link_name integer(HID_T), intent(in) :: loc_id integer :: hdferr @@ -461,7 +454,6 @@ end subroutine HDF5_setLink !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real1(loc_id,dataset,datasetName,parallel) - implicit none real(pReal), intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -502,7 +494,6 @@ end subroutine HDF5_read_real1 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real2(loc_id,dataset,datasetName,parallel) - implicit none real(pReal), intent(inout), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -543,7 +534,6 @@ end subroutine HDF5_read_real2 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real3(loc_id,dataset,datasetName,parallel) - implicit none real(pReal), intent(inout), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -584,7 +574,6 @@ end subroutine HDF5_read_real3 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real4(loc_id,dataset,datasetName,parallel) - implicit none real(pReal), intent(inout), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -625,7 +614,6 @@ end subroutine HDF5_read_real4 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real5(loc_id,dataset,datasetName,parallel) - implicit none real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -666,7 +654,6 @@ end subroutine HDF5_read_real5 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real6(loc_id,dataset,datasetName,parallel) - implicit none real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -707,7 +694,6 @@ end subroutine HDF5_read_real6 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real7(loc_id,dataset,datasetName,parallel) - implicit none real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -749,7 +735,6 @@ end subroutine HDF5_read_real7 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int1(loc_id,dataset,datasetName,parallel) - implicit none integer, intent(inout), dimension(:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -790,7 +775,6 @@ end subroutine HDF5_read_int1 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int2(loc_id,dataset,datasetName,parallel) - implicit none integer, intent(inout), dimension(:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -831,7 +815,6 @@ end subroutine HDF5_read_int2 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int3(loc_id,dataset,datasetName,parallel) - implicit none integer, intent(inout), dimension(:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -872,7 +855,6 @@ end subroutine HDF5_read_int3 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int4(loc_id,dataset,datasetName,parallel) - implicit none integer, intent(inout), dimension(:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -913,7 +895,6 @@ end subroutine HDF5_read_int4 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int5(loc_id,dataset,datasetName,parallel) - implicit none integer, intent(inout), dimension(:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -954,7 +935,6 @@ end subroutine HDF5_read_int5 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int6(loc_id,dataset,datasetName,parallel) - implicit none integer, intent(inout), dimension(:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -995,7 +975,6 @@ end subroutine HDF5_read_int6 !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int7(loc_id,dataset,datasetName,parallel) - implicit none integer, intent(inout), dimension(:,:,:,:,:,:,:) :: dataset integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file @@ -1037,40 +1016,39 @@ end subroutine HDF5_read_int7 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real1(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape,loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real1: h5dwrite_f') - endif + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real1: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_real1 @@ -1079,40 +1057,39 @@ end subroutine HDF5_write_real1 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real2(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real2: h5dwrite_f') - endif + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real2: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_real2 @@ -1121,40 +1098,39 @@ end subroutine HDF5_write_real2 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real3(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real3: h5dwrite_f') - endif + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real3: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_real3 @@ -1163,40 +1139,39 @@ end subroutine HDF5_write_real3 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real4(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif - - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real4: h5dwrite_f') - endif + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif + + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real4: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_real4 @@ -1206,40 +1181,39 @@ end subroutine HDF5_write_real4 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real5(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif - - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real5: h5dwrite_f') - endif + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif + + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real5: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_real5 @@ -1248,40 +1222,39 @@ end subroutine HDF5_write_real5 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real6(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real6: h5dwrite_f') - endif - - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real6: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_real6 @@ -1290,40 +1263,39 @@ end subroutine HDF5_write_real6 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real7(loc_id,dataset,datasetName,parallel) - implicit none - real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + real(pReal), intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_DOUBLE,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real7: h5dwrite_f') - endif - - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real7: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_real7 @@ -1333,40 +1305,39 @@ end subroutine HDF5_write_real7 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int1(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int1: h5dwrite_f') - endif - - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int1: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_int1 @@ -1375,40 +1346,39 @@ end subroutine HDF5_write_int1 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int2(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int2: h5dwrite_f') - endif + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int2: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_int2 @@ -1417,40 +1387,39 @@ end subroutine HDF5_write_int2 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int3(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int3: h5dwrite_f') - endif - - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int3: h5dwrite_f') + endif + + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_int3 @@ -1459,40 +1428,39 @@ end subroutine HDF5_write_int3 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int4(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int4: h5dwrite_f') - endif + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int4: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_int4 @@ -1501,40 +1469,39 @@ end subroutine HDF5_write_int4 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int5(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int5: h5dwrite_f') - endif + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int5: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_int5 @@ -1543,40 +1510,39 @@ end subroutine HDF5_write_int5 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int6(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int6: h5dwrite_f') - endif + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int6: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_int6 @@ -1585,40 +1551,39 @@ end subroutine HDF5_write_int6 !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int7(loc_id,dataset,datasetName,parallel) - implicit none - integer, intent(inout), dimension(:,:,:,:,:,:,:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + integer, intent(inout), dimension(:,:,:,:,:,:,:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) + integer :: hdferr + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) - if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) + myShape = int(shape(dataset),HSIZE_T) + if (any(myShape(1:size(myShape)-1) == 0)) return !< empty dataset (last dimension can be empty) - if (present(parallel)) then - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) - else - call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & - myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) - endif + if (present(parallel)) then + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,parallel) + else + call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & + myStart, totalShape, loc_id,myShape,datasetName,H5T_NATIVE_INTEGER,.false.) + endif - if (product(totalShape) /= 0) then - call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int7: h5dwrite_f') - endif + if (product(totalShape) /= 0) then + call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int7: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_int7 @@ -1626,40 +1591,37 @@ end subroutine HDF5_write_int7 !-------------------------------------------------------------------------------------------------- !> @brief writes a scalar orientation dataset ! ToDo: It might be possible to write the dataset as a whole -! ToDo: We could add the crystal structure as an attribute +! ToDo: We could optionally write out other representations (axis angle, euler, ...) !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_rotation(loc_id,dataset,datasetName,parallel) - use rotations - use numerics, only: & - worldrank, & - worldsize + use rotations, only: & + rotation - implicit none - type(rotation), intent(in), dimension(:) :: dataset - integer(HID_T), intent(in) :: loc_id !< file or group handle - character(len=*), intent(in) :: datasetName !< name of the dataset in the file - logical, intent(in), optional :: parallel + type(rotation), intent(in), dimension(:) :: dataset + integer(HID_T), intent(in) :: loc_id !< file or group handle + character(len=*), intent(in) :: datasetName !< name of the dataset in the file + logical, intent(in), optional :: parallel - integer :: hdferr - real(pReal), dimension(4,size(dataset)) :: dataset_asArray - integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id,dtype_id,w_id,x_id,y_id,z_id - integer(HSIZE_T), dimension(size(shape(dataset))) :: & - myStart, & - myShape, & !< shape of the dataset (this process) - totalShape !< shape of the dataset (all processes) - integer(SIZE_T) :: type_size_real - integer :: i + integer :: hdferr + real(pReal), dimension(4,size(dataset)) :: dataset_asArray + integer(HID_T) :: dset_id, filespace_id, memspace_id, plist_id,dtype_id,w_id,x_id,y_id,z_id + integer(HSIZE_T), dimension(size(shape(dataset))) :: & + myStart, & + myShape, & !< shape of the dataset (this process) + totalShape !< shape of the dataset (all processes) + integer(SIZE_T) :: type_size_real + integer :: i - do i = 1, size(dataset) - dataset_asArray(1:4,i) = dataset(i)%asQuaternion() - enddo + do i = 1, size(dataset) + dataset_asArray(1:4,i) = dataset(i)%asQuaternion() + enddo !--------------------------------------------------------------------------------------------------- ! determine shape of dataset - myShape = int(shape(dataset),HSIZE_T) + myShape = int(shape(dataset),HSIZE_T) !--------------------------------------------------------------------------------------------------- -! compound type: name of phase section + position/index within results array +! compound type: name of each quaternion component call h5tget_size_f(H5T_NATIVE_DOUBLE, type_size_real, hdferr) call h5tcreate_f(H5T_COMPOUND_F, type_size_real*4_SIZE_T, dtype_id, hdferr) @@ -1674,8 +1636,9 @@ subroutine HDF5_write_rotation(loc_id,dataset,datasetName,parallel) else call initialize_write(dset_id, filespace_id, memspace_id, plist_id, & myStart, totalShape, loc_id,myShape,datasetName,dtype_id,.false.) - endif - call h5pset_preserve_f(plist_id, .TRUE., hdferr) + endif + + call h5pset_preserve_f(plist_id, .TRUE., hdferr) if (product(totalShape) /= 0) then call h5tcreate_f(H5T_COMPOUND_F, type_size_real, x_id, hdferr) @@ -1687,18 +1650,18 @@ subroutine HDF5_write_rotation(loc_id,dataset,datasetName,parallel) call h5tcreate_f(H5T_COMPOUND_F, type_size_real, z_id, hdferr) call h5tinsert_f(z_id, "z", 0_SIZE_T, H5T_NATIVE_DOUBLE, hdferr) - call h5dwrite_f(dset_id, w_id,dataset_asArray(1,:),int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - call h5dwrite_f(dset_id, x_id,dataset_asArray(2,:),int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - call h5dwrite_f(dset_id, y_id,dataset_asArray(3,:),int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - call h5dwrite_f(dset_id, z_id,dataset_asArray(4,:),int(totalShape,HSIZE_T), hdferr,& - file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_rotation: h5dwrite_f') - endif + call h5dwrite_f(dset_id, w_id,dataset_asArray(1,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + call h5dwrite_f(dset_id, x_id,dataset_asArray(2,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + call h5dwrite_f(dset_id, y_id,dataset_asArray(3,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + call h5dwrite_f(dset_id, z_id,dataset_asArray(4,:),int(totalShape,HSIZE_T), hdferr,& + file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_rotation: h5dwrite_f') + endif - call finalize_write(plist_id, dset_id, filespace_id, memspace_id) + call finalize_write(plist_id, dset_id, filespace_id, memspace_id) end subroutine HDF5_write_rotation @@ -1713,7 +1676,6 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ worldrank, & worldsize - implicit none integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in) :: parallel @@ -1783,12 +1745,13 @@ end subroutine initialize_read !-------------------------------------------------------------------------------------------------- subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) - implicit none integer(HID_T), intent(in) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id integer :: hdferr call h5pclose_f(plist_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: plist_id') + call h5pclose_f(aplist_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: aplist_id') call h5dclose_f(dset_id, hdferr) if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: h5dclose_f') call h5sclose_f(filespace_id, hdferr) @@ -1809,7 +1772,6 @@ subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & worldrank, & worldsize - implicit none integer(HID_T), intent(in) :: loc_id !< file or group handle character(len=*), intent(in) :: datasetName !< name of the dataset in the file logical, intent(in) :: parallel @@ -1874,7 +1836,6 @@ end subroutine initialize_write !-------------------------------------------------------------------------------------------------- subroutine finalize_write(plist_id, dset_id, filespace_id, memspace_id) - implicit none integer(HID_T), intent(in) :: dset_id, filespace_id, memspace_id, plist_id integer :: hdferr diff --git a/src/results.f90 b/src/results.f90 index ce4105b73..4ed5cc751 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -47,7 +47,6 @@ subroutine results_init use DAMASK_interface, only: & getSolverJobName - implicit none character(len=pStringLen) :: commandLine write(6,'(/,a)') ' <<<+- results init -+>>>' @@ -76,7 +75,6 @@ subroutine results_openJobFile use DAMASK_interface, only: & getSolverJobName - implicit none resultsFile = HDF5_openFile(trim(getSolverJobName())//'.hdf5','a',.true.) @@ -87,7 +85,6 @@ end subroutine results_openJobFile !> @brief closes the results file !-------------------------------------------------------------------------------------------------- subroutine results_closeJobFile - implicit none call HDF5_closeFile(resultsFile) @@ -99,7 +96,6 @@ end subroutine results_closeJobFile !-------------------------------------------------------------------------------------------------- subroutine results_addIncrement(inc,time) - implicit none integer(pInt), intent(in) :: inc real(pReal), intent(in) :: time character(len=pStringLen) :: incChar @@ -116,7 +112,6 @@ end subroutine results_addIncrement !-------------------------------------------------------------------------------------------------- integer(HID_T) function results_openGroup(groupName) - implicit none character(len=*), intent(in) :: groupName results_openGroup = HDF5_openGroup(resultsFile,groupName) @@ -129,7 +124,6 @@ end function results_openGroup !-------------------------------------------------------------------------------------------------- integer(HID_T) function results_addGroup(groupName) - implicit none character(len=*), intent(in) :: groupName results_addGroup = HDF5_addGroup(resultsFile,groupName) @@ -142,7 +136,6 @@ end function results_addGroup !-------------------------------------------------------------------------------------------------- subroutine results_setLink(path,link) - implicit none character(len=*), intent(in) :: path, link call HDF5_setLink(resultsFile,path,link) @@ -155,7 +148,6 @@ end subroutine results_setLink !-------------------------------------------------------------------------------------------------- subroutine results_addAttribute(attrLabel,attrValue,path) - implicit none character(len=*), intent(in) :: attrLabel, attrValue, path call HDF5_addAttribute_str(resultsFile,attrLabel, attrValue, path) @@ -168,7 +160,6 @@ end subroutine results_addAttribute !-------------------------------------------------------------------------------------------------- subroutine results_removeLink(link) - implicit none character(len=*), intent(in) :: link integer :: hdferr @@ -183,7 +174,6 @@ end subroutine results_removeLink !-------------------------------------------------------------------------------------------------- subroutine results_writeScalarDataset_real(group,dataset,label,description,SIunit) - implicit none character(len=*), intent(in) :: label,group,description character(len=*), intent(in), optional :: SIunit real(pReal), intent(inout), dimension(:) :: dataset @@ -209,7 +199,6 @@ end subroutine results_writeScalarDataset_real !-------------------------------------------------------------------------------------------------- subroutine results_writeVectorDataset_real(group,dataset,label,description,SIunit) - implicit none character(len=*), intent(in) :: label,group,description character(len=*), intent(in), optional :: SIunit real(pReal), intent(inout), dimension(:,:) :: dataset @@ -236,7 +225,6 @@ end subroutine results_writeVectorDataset_real !-------------------------------------------------------------------------------------------------- subroutine results_writeTensorDataset_real(group,dataset,label,description,SIunit) - implicit none character(len=*), intent(in) :: label,group,description character(len=*), intent(in), optional :: SIunit real(pReal), intent(inout), dimension(:,:,:) :: dataset @@ -263,7 +251,6 @@ end subroutine results_writeTensorDataset_real !-------------------------------------------------------------------------------------------------- subroutine results_writeVectorDataset_int(group,dataset,label,description,SIunit) - implicit none character(len=*), intent(in) :: label,group,description character(len=*), intent(in), optional :: SIunit integer, intent(inout), dimension(:,:) :: dataset @@ -290,7 +277,6 @@ end subroutine results_writeVectorDataset_int !-------------------------------------------------------------------------------------------------- subroutine results_writeTensorDataset_int(group,dataset,label,description,SIunit) - implicit none character(len=*), intent(in) :: label,group,description character(len=*), intent(in), optional :: SIunit integer, intent(inout), dimension(:,:,:) :: dataset @@ -315,11 +301,10 @@ end subroutine results_writeTensorDataset_int !-------------------------------------------------------------------------------------------------- !> @brief stores a vector dataset in a group !-------------------------------------------------------------------------------------------------- -subroutine results_writeScalarDataset_rotation(group,dataset,label,description,SIunit) +subroutine results_writeScalarDataset_rotation(group,dataset,label,description,lattice_structure) use rotations, only: & rotation - implicit none character(len=*), intent(in) :: label,group,description character(len=*), intent(in), optional :: lattice_structure type(rotation), intent(inout), dimension(:) :: dataset @@ -413,30 +398,30 @@ subroutine results_mapping_constituent(phaseAt,memberAt,label) !-------------------------------------------------------------------------------------------------- ! MPI settings and communication #ifdef PETSc - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, ierr) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5pset_dxpl_mpio_f') - - call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get output at each process - if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_constituent: MPI_allreduce/writeSize') - - call MPI_allreduce(MPI_IN_PLACE,memberOffset,size(memberOffset),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get offset at each process - if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_constituent: MPI_allreduce/memberOffset') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5pset_dxpl_mpio_f') + + call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get output at each process + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_constituent: MPI_allreduce/writeSize') + + call MPI_allreduce(MPI_IN_PLACE,memberOffset,size(memberOffset),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr)! get offset at each process + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_constituent: MPI_allreduce/memberOffset') #endif - myShape = int([size(phaseAt,1),writeSize(worldrank)], HSIZE_T) - myOffset = int([0,sum(writeSize(0:worldrank-1))], HSIZE_T) - totalShape = int([size(phaseAt,1),sum(writeSize)], HSIZE_T) + myShape = int([size(phaseAt,1),writeSize(worldrank)], HSIZE_T) + myOffset = int([0,sum(writeSize(0:worldrank-1))], HSIZE_T) + totalShape = int([size(phaseAt,1),sum(writeSize)], HSIZE_T) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape = hyperslab) and in file (global shape) - call h5screate_simple_f(2,myShape,memspace_id,ierr,myShape) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5screate_simple_f/memspace_id') - - call h5screate_simple_f(2,totalShape,filespace_id,ierr,totalShape) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5screate_simple_f/filespace_id') - - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, ierr) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5sselect_hyperslab_f') + call h5screate_simple_f(2,myShape,memspace_id,ierr,myShape) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5screate_simple_f/memspace_id') + + call h5screate_simple_f(2,totalShape,filespace_id,ierr,totalShape) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5screate_simple_f/filespace_id') + + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5sselect_hyperslab_f') !--------------------------------------------------------------------------------------------------- ! expand phaseAt to consider IPs (is not stored per IP) @@ -452,29 +437,29 @@ subroutine results_mapping_constituent(phaseAt,memberAt,label) !-------------------------------------------------------------------------------------------------- ! write the components of the compound type individually - call h5pset_preserve_f(plist_id, .TRUE., ierr) - - loc_id = results_openGroup('/mapping/cellResults') - call h5dcreate_f(loc_id, 'constituent', dtype_id, filespace_id, dset_id, ierr) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dcreate_f') - - call h5dwrite_f(dset_id, name_id, reshape(label(pack(phaseAt_perIP,.true.)),myShape), & - myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dwrite_f/name_id') - call h5dwrite_f(dset_id, position_id, reshape(pack(memberAt_total,.true.),myShape), & - myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dwrite_f/position_id') + call h5pset_preserve_f(plist_id, .TRUE., ierr) + + loc_id = results_openGroup('/mapping/cellResults') + call h5dcreate_f(loc_id, 'constituent', dtype_id, filespace_id, dset_id, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dcreate_f') + + call h5dwrite_f(dset_id, name_id, reshape(label(pack(phaseAt_perIP,.true.)),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dwrite_f/name_id') + call h5dwrite_f(dset_id, position_id, reshape(pack(memberAt_total,.true.),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_constituent: h5dwrite_f/position_id') !-------------------------------------------------------------------------------------------------- ! close all - call HDF5_closeGroup(loc_id) - call h5pclose_f(plist_id, ierr) - call h5sclose_f(filespace_id, ierr) - call h5sclose_f(memspace_id, ierr) - call h5dclose_f(dset_id, ierr) - call h5tclose_f(dtype_id, ierr) - call h5tclose_f(name_id, ierr) - call h5tclose_f(position_id, ierr) + call HDF5_closeGroup(loc_id) + call h5pclose_f(plist_id, ierr) + call h5sclose_f(filespace_id, ierr) + call h5sclose_f(memspace_id, ierr) + call h5dclose_f(dset_id, ierr) + call h5tclose_f(dtype_id, ierr) + call h5tclose_f(name_id, ierr) + call h5tclose_f(position_id, ierr) end subroutine results_mapping_constituent @@ -551,30 +536,30 @@ subroutine results_mapping_materialpoint(homogenizationAt,memberAt,label) !-------------------------------------------------------------------------------------------------- ! MPI settings and communication #ifdef PETSc - call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, ierr) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5pset_dxpl_mpio_f') - - call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get output at each process - if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_materialpoint: MPI_allreduce/writeSize') - - call MPI_allreduce(MPI_IN_PLACE,memberOffset,size(memberOffset),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get offset at each process - if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_materialpoint: MPI_allreduce/memberOffset') + call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5pset_dxpl_mpio_f') + + call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get output at each process + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_materialpoint: MPI_allreduce/writeSize') + + call MPI_allreduce(MPI_IN_PLACE,memberOffset,size(memberOffset),MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr)! get offset at each process + if (ierr /= 0) call IO_error(894,ext_msg='results_mapping_materialpoint: MPI_allreduce/memberOffset') #endif - myShape = int([writeSize(worldrank)], HSIZE_T) - myOffset = int([sum(writeSize(0:worldrank-1))], HSIZE_T) - totalShape = int([sum(writeSize)], HSIZE_T) + myShape = int([writeSize(worldrank)], HSIZE_T) + myOffset = int([sum(writeSize(0:worldrank-1))], HSIZE_T) + totalShape = int([sum(writeSize)], HSIZE_T) !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape = hyperslab) and in file (global shape) - call h5screate_simple_f(1,myShape,memspace_id,ierr,myShape) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5screate_simple_f/memspace_id') - - call h5screate_simple_f(1,totalShape,filespace_id,ierr,totalShape) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5screate_simple_f/filespace_id') - - call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, ierr) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5sselect_hyperslab_f') + call h5screate_simple_f(1,myShape,memspace_id,ierr,myShape) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5screate_simple_f/memspace_id') + + call h5screate_simple_f(1,totalShape,filespace_id,ierr,totalShape) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5screate_simple_f/filespace_id') + + call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myOffset, myShape, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5sselect_hyperslab_f') !--------------------------------------------------------------------------------------------------- ! expand phaseAt to consider IPs (is not stored per IP) @@ -590,29 +575,29 @@ subroutine results_mapping_materialpoint(homogenizationAt,memberAt,label) !-------------------------------------------------------------------------------------------------- ! write the components of the compound type individually - call h5pset_preserve_f(plist_id, .TRUE., ierr) - - loc_id = results_openGroup('/mapping/cellResults') - call h5dcreate_f(loc_id, 'materialpoint', dtype_id, filespace_id, dset_id, ierr) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dcreate_f') - - call h5dwrite_f(dset_id, name_id, reshape(label(pack(homogenizationAt_perIP,.true.)),myShape), & - myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dwrite_f/name_id') - call h5dwrite_f(dset_id, position_id, reshape(pack(memberAt_total,.true.),myShape), & - myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dwrite_f/position_id') + call h5pset_preserve_f(plist_id, .TRUE., ierr) + + loc_id = results_openGroup('/mapping/cellResults') + call h5dcreate_f(loc_id, 'materialpoint', dtype_id, filespace_id, dset_id, ierr) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dcreate_f') + + call h5dwrite_f(dset_id, name_id, reshape(label(pack(homogenizationAt_perIP,.true.)),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dwrite_f/name_id') + call h5dwrite_f(dset_id, position_id, reshape(pack(memberAt_total,.true.),myShape), & + myShape, ierr, file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) + if (ierr < 0) call IO_error(1,ext_msg='results_mapping_materialpoint: h5dwrite_f/position_id') !-------------------------------------------------------------------------------------------------- ! close all - call HDF5_closeGroup(loc_id) - call h5pclose_f(plist_id, ierr) - call h5sclose_f(filespace_id, ierr) - call h5sclose_f(memspace_id, ierr) - call h5dclose_f(dset_id, ierr) - call h5tclose_f(dtype_id, ierr) - call h5tclose_f(name_id, ierr) - call h5tclose_f(position_id, ierr) + call HDF5_closeGroup(loc_id) + call h5pclose_f(plist_id, ierr) + call h5sclose_f(filespace_id, ierr) + call h5sclose_f(memspace_id, ierr) + call h5dclose_f(dset_id, ierr) + call h5tclose_f(dtype_id, ierr) + call h5tclose_f(name_id, ierr) + call h5tclose_f(position_id, ierr) end subroutine results_mapping_materialpoint @@ -623,7 +608,6 @@ end subroutine results_mapping_materialpoint !subroutine HDF5_backwardMappingPhase(material_phase,phasememberat,phase_name,dataspace_size,mpiOffset,mpiOffset_phase) ! use hdf5 -! implicit none ! integer(pInt), intent(in), dimension(:,:,:) :: material_phase, phasememberat ! character(len=*), intent(in), dimension(:) :: phase_name ! integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_phase @@ -738,7 +722,6 @@ end subroutine results_mapping_materialpoint !subroutine HDF5_backwardMappingHomog(material_homog,homogmemberat,homogenization_name,dataspace_size,mpiOffset,mpiOffset_homog) ! use hdf5 -! implicit none ! integer(pInt), intent(in), dimension(:,:) :: material_homog, homogmemberat ! character(len=*), intent(in), dimension(:) :: homogenization_name ! integer(pInt), intent(in), dimension(:) :: dataspace_size, mpiOffset_homog @@ -846,7 +829,6 @@ end subroutine results_mapping_materialpoint !subroutine HDF5_mappingCells(mapping) ! use hdf5 -! implicit none ! integer(pInt), intent(in), dimension(:) :: mapping ! integer :: hdferr, Nnodes From 2fa869133565a5b585bddc3626e096a8d68b58dd Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 7 Apr 2019 14:26:01 +0200 Subject: [PATCH 30/97] prefix is added centrally already --- src/constitutive.f90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index ea349e7ac..1158ddc07 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -1105,16 +1105,13 @@ subroutine constitutive_results use plastic_nonlocal, only: & plastic_nonlocal_results - implicit none integer :: p character(len=256) :: group - character(len=16) :: i call HDF5_closeGroup(results_addGroup('current/constitutive')) do p=1,size(config_name_phase) - write(i,('(i2.2)')) p ! allow 99 groups - group = trim('current/constitutive')//'/'//trim(i)//'_'//trim(config_name_phase(p)) + group = trim('current/constitutive')//'/'//trim(config_name_phase(p)) call HDF5_closeGroup(results_addGroup(group)) group = trim(group)//'/'//'plastic' From 0b70f01e045da6a908accda9fac4c1e3be62b133 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 7 Apr 2019 14:28:08 +0200 Subject: [PATCH 31/97] polishing --- src/HDF5_utilities.f90 | 4 +- src/crystallite.f90 | 100 ++++++++++++++++++++++++++++------------- 2 files changed, 71 insertions(+), 33 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 0b92b9b1e..a2593e1cb 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -208,7 +208,7 @@ integer(HID_T) function HDF5_addGroup(fileHandle,groupName) call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') - call h5pclose_f(aplist_id) + call h5pclose_f(aplist_id,hdferr) end function HDF5_addGroup @@ -244,7 +244,7 @@ integer(HID_T) function HDF5_openGroup(fileHandle,groupName) call h5gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') - call h5pclose_f(aplist_id) + call h5pclose_f(aplist_id,hdferr) end function HDF5_openGroup diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 1057ec4c6..7ebfee8bf 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1083,6 +1083,7 @@ subroutine crystallite_results #if defined(PETSc) || defined(DAMASK_HDF5) use results use HDF5_utilities + use rotations use config, only: & config_name_phase => phase_name ! anticipate logical name @@ -1091,76 +1092,81 @@ subroutine crystallite_results implicit none integer :: p,o - real(pReal), allocatable, dimension(:,:,:) :: selected + real(pReal), allocatable, dimension(:,:,:) :: selected_tensors + type(rotation), allocatable, dimension(:) :: selected_rotations character(len=256) :: group - character(len=16) :: j call HDF5_closeGroup(results_addGroup('current/constituent')) do p=1,size(config_name_phase) - write(j,('(i2.2)')) p ! allow 99 groups - group = trim('current/constituent')//'/'//trim(j)//'_'//trim(config_name_phase(p)) + group = trim('current/constituent')//'/'//trim(config_name_phase(p)) call HDF5_closeGroup(results_addGroup(group)) do o = 1, size(output_constituent(p)%label) select case (output_constituent(p)%label(o)) case('f') - selected = packed(crystallite_partionedF,p) - call results_writeDataset(group,selected,'F',& + selected_tensors = select_tensors(crystallite_partionedF,p) + call results_writeDataset(group,selected_tensors,'F',& 'deformation gradient','1') case('fe') - selected = packed(crystallite_Fe,p) - call results_writeDataset(group,selected,'Fe',& + selected_tensors = select_tensors(crystallite_Fe,p) + call results_writeDataset(group,selected_tensors,'Fe',& 'elastic deformation gradient','1') case('fp') - selected = packed(crystallite_Fp,p) - call results_writeDataset(group,selected,'Fp',& + selected_tensors = select_tensors(crystallite_Fp,p) + call results_writeDataset(group,selected_tensors,'Fp',& 'plastic deformation gradient','1') case('fi') - selected = packed(crystallite_Fi,p) - call results_writeDataset(group,selected,'Fi',& + selected_tensors = select_tensors(crystallite_Fi,p) + call results_writeDataset(group,selected_tensors,'Fi',& 'inelastic deformation gradient','1') case('lp') - selected = packed(crystallite_Lp,p) - call results_writeDataset(group,selected,'Lp',& + selected_tensors = select_tensors(crystallite_Lp,p) + call results_writeDataset(group,selected_tensors,'Lp',& 'plastic velocity gradient','1/s') case('li') - selected = packed(crystallite_Li,p) - call results_writeDataset(group,selected,'Li',& + selected_tensors = select_tensors(crystallite_Li,p) + call results_writeDataset(group,selected_tensors,'Li',& 'inelastic velocity gradient','1/s') case('p') - selected = packed(crystallite_P,p) - call results_writeDataset(group,selected,'P',& + selected_tensors = select_tensors(crystallite_P,p) + call results_writeDataset(group,selected_tensors,'P',& '1st Piola-Kirchoff stress','Pa') case('s') - selected = packed(crystallite_S,p) - call results_writeDataset(group,selected,'S',& - '2nd Piola-Kirchoff stress','Pa') + selected_tensors = select_tensors(crystallite_S,p) + call results_writeDataset(group,selected_tensors,'S',& + '2nd Piola-Kirchoff stress','Pa') + case('orientation') + selected_rotations = select_rotations(crystallite_orientation,p) + call results_writeDataset(group,selected_rotations,'orientation',& + 'crystal orientation as quaternion','1') end select enddo enddo contains - - function packed(res,instance) + +!-------------------------------------------------------------------------------------------------- +!> @brief select tensors for output +!-------------------------------------------------------------------------------------------------- + function select_tensors(dataset,instance) use material, only: & homogenization_maxNgrains, & material_phaseAt integer, intent(in) :: instance - real(pReal), dimension(:,:,:,:,:), intent(in) :: res - real(pReal), allocatable, dimension(:,:,:) :: packed + real(pReal), dimension(:,:,:,:,:), intent(in) :: dataset + real(pReal), allocatable, dimension(:,:,:) :: select_tensors integer :: e,i,c,j - allocate(packed(3,3,count(material_phaseAt==instance)*homogenization_maxNgrains)) -!--------------------------------------------------------------------------------------------------- -! expand phaseAt to consider IPs (is not stored per IP) + allocate(select_tensors(3,3,count(material_phaseAt==instance)*homogenization_maxNgrains)) + j=1 do e = 1, size(material_phaseAt,2) - do i = 1, homogenization_maxNgrains + do i = 1, homogenization_maxNgrains !ToDo: this needs to be changed for varying Ngrains do c = 1, size(material_phaseAt,1) if (material_phaseAt(c,e) == instance) then - packed(1:3,1:3,j) = res(1:3,1:3,c,i,e) + select_tensors(1:3,1:3,j) = dataset(1:3,1:3,c,i,e) j = j + 1 endif enddo @@ -1168,7 +1174,39 @@ subroutine crystallite_results enddo - end function packed + end function select_tensors + + +!-------------------------------------------------------------------------------------------------- +!> @brief select rotations for output +!-------------------------------------------------------------------------------------------------- + function select_rotations(dataset,instance) + + use material, only: & + homogenization_maxNgrains, & + material_phaseAt + + integer, intent(in) :: instance + type(rotation), dimension(:,:,:), intent(in) :: dataset + type(rotation), allocatable, dimension(:) :: select_rotations + integer :: e,i,c,j + + allocate(select_rotations(count(material_phaseAt==instance)*homogenization_maxNgrains)) + + j=1 + do e = 1, size(material_phaseAt,2) + do i = 1, homogenization_maxNgrains !ToDo: this needs to be changed for varying Ngrains + do c = 1, size(material_phaseAt,1) + if (material_phaseAt(c,e) == instance) then + select_rotations(j) = dataset(c,i,e) + j = j + 1 + endif + enddo + enddo + enddo + + + end function select_rotations #endif From c3925b3497dd66e5218bb8ac5bdae6eee2af3782 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 7 Apr 2019 14:47:21 +0200 Subject: [PATCH 32/97] small polishing --- src/crystallite.f90 | 19 +++++++++++++++++-- src/lattice.f90 | 10 ++++++---- 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 7ebfee8bf..69c7839c7 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1081,6 +1081,7 @@ end function crystallite_postResults !-------------------------------------------------------------------------------------------------- subroutine crystallite_results #if defined(PETSc) || defined(DAMASK_HDF5) + use lattice use results use HDF5_utilities use rotations @@ -1094,7 +1095,7 @@ subroutine crystallite_results integer :: p,o real(pReal), allocatable, dimension(:,:,:) :: selected_tensors type(rotation), allocatable, dimension(:) :: selected_rotations - character(len=256) :: group + character(len=256) :: group,lattice_label call HDF5_closeGroup(results_addGroup('current/constituent')) @@ -1136,9 +1137,23 @@ subroutine crystallite_results call results_writeDataset(group,selected_tensors,'S',& '2nd Piola-Kirchoff stress','Pa') case('orientation') + select case(lattice_structure(p)) + case(LATTICE_iso_ID) + lattice_label = 'iso' + case(LATTICE_fcc_ID) + lattice_label = 'fcc' + case(LATTICE_bcc_ID) + lattice_label = 'bcc' + case(LATTICE_bct_ID) + lattice_label = 'bct' + case(LATTICE_hex_ID) + lattice_label = 'hex' + case(LATTICE_ort_ID) + lattice_label = 'ort' + end select selected_rotations = select_rotations(crystallite_orientation,p) call results_writeDataset(group,selected_rotations,'orientation',& - 'crystal orientation as quaternion','1') + 'crystal orientation as quaternion',lattice_label) end select enddo enddo diff --git a/src/lattice.f90 b/src/lattice.f90 index 1b844c31f..d11932c29 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -507,10 +507,12 @@ module lattice public :: & lattice_init, & lattice_qDisorientation, & + LATTICE_iso_ID, & LATTICE_fcc_ID, & LATTICE_bcc_ID, & LATTICE_bct_ID, & LATTICE_hex_ID, & + LATTICE_ort_ID, & lattice_SchmidMatrix_slip, & lattice_SchmidMatrix_twin, & lattice_SchmidMatrix_trans, & @@ -581,18 +583,18 @@ subroutine lattice_init do p = 1, size(config_phase) tag = config_phase(p)%getString('lattice_structure') - select case(trim(tag)) - case('iso','isotropic') + select case(trim(tag(1:3))) + case('iso') lattice_structure(p) = LATTICE_iso_ID case('fcc') lattice_structure(p) = LATTICE_fcc_ID case('bcc') lattice_structure(p) = LATTICE_bcc_ID - case('hex','hexagonal') + case('hex') lattice_structure(p) = LATTICE_hex_ID case('bct') lattice_structure(p) = LATTICE_bct_ID - case('ort','orthorhombic') + case('ort') lattice_structure(p) = LATTICE_ort_ID end select From c2cb8e2033fe00cfdc6014624e9b4e1fc9bd77ae Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 7 Apr 2019 17:46:35 +0200 Subject: [PATCH 33/97] HDF5/results need rotation --- src/commercialFEM_fileList.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index 342fbab0f..872932c7b 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -9,10 +9,6 @@ #include "list.f90" #include "future.f90" #include "config.f90" -#ifdef DAMASK_HDF5 -#include "HDF5_utilities.f90" -#include "results.f90" -#endif #include "math.f90" #include "quaternions.f90" #include "Lambert.f90" @@ -26,6 +22,10 @@ #ifdef Marc4DAMASK #include "mesh_marc.f90" #endif +#ifdef DAMASK_HDF5 +#include "HDF5_utilities.f90" +#include "results.f90" +#endif #include "material.f90" #include "lattice.f90" #include "source_thermal_dissipation.f90" From 019d1a9c5c4d6ebc593ed384e872bc4ccf3e89e0 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 8 Apr 2019 22:23:40 +0200 Subject: [PATCH 34/97] [skip ci] reference was wrong --- python/damask/orientation.py | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/python/damask/orientation.py b/python/damask/orientation.py index 7cb05af40..252f39420 100644 --- a/python/damask/orientation.py +++ b/python/damask/orientation.py @@ -754,8 +754,8 @@ class Lattice: # Kurdjomov--Sachs orientation relationship for fcc <-> bcc transformation - # from S. Morito et al./Journal of Alloys and Compounds 5775 (2013) S587-S592 - # also see K. Kitahara et al./Acta Materialia 54 (2006) 1279-1288 + # from S. Morito et al. Journal of Alloys and Compounds 577 (2013) 587-S592 + # also see K. Kitahara et al. Acta Materialia 54 (2006) 1279-1288 KS = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 1, 1, 1],[ 0, 1, 1]], @@ -809,7 +809,7 @@ class Lattice: [[ 1, 0, 1],[ -1, 1, -1]]],dtype='float')} # Greninger--Troiano orientation relationship for fcc <-> bcc transformation - # from Y. He et al./Journal of Applied Crystallography (2006). 39, 72-81 + # from Y. He et al. Journal of Applied Crystallography 39 (2006) 72-81 GT = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 1, 1, 1],[ 1, 0, 1]], @@ -863,7 +863,7 @@ class Lattice: [[-17,-12, 5],[-17, 7, 17]]],dtype='float')} # Greninger--Troiano' orientation relationship for fcc <-> bcc transformation - # from Y. He et al./Journal of Applied Crystallography (2006). 39, 72-81 + # from Y. He et al. Journal of Applied Crystallography 39 (2006) 72-81 GTdash = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 7, 17, 17],[ 12, 5, 17]], @@ -917,7 +917,7 @@ class Lattice: [[ 1, 1, 0],[ 1, 1, -1]]],dtype='float')} # Nishiyama--Wassermann orientation relationship for fcc <-> bcc transformation - # from H. Kitahara et al./Materials Characterization 54 (2005) 378-386 + # from H. Kitahara et al. Materials Characterization 54 (2005) 378-386 NW = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 1, 1, 1],[ 0, 1, 1]], @@ -947,7 +947,7 @@ class Lattice: [[ -1, -1, -2],[ 0, -1, 1]]],dtype='float')} # Pitsch orientation relationship for fcc <-> bcc transformation - # from Y. He et al./Acta Materialia 53 (2005) 1179-1190 + # from Y. He et al. Acta Materialia 53 (2005) 1179-1190 Pitsch = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 0, 1, 0],[ -1, 0, 1]], @@ -977,7 +977,7 @@ class Lattice: [[ 1, 1, 0],[ 1, 1, -1]]],dtype='float')} # Bain orientation relationship for fcc <-> bcc transformation - # from Y. He et al./Journal of Applied Crystallography (2006). 39, 72-81 + # from Y. He et al. Journal of Applied Crystallography 39 (2006) 72-81 Bain = {'mapping':{'fcc':0,'bcc':1}, 'planes': np.array([ [[ 1, 0, 0],[ 1, 0, 0]], From 21f308deec322064fb669d0fad14075acade314c Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 10 Apr 2019 12:24:40 +0200 Subject: [PATCH 35/97] [skip ci] updated version information after successful test of v2.0.3-100-g6270e6f8 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 5463ead9a..103e1d432 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.3-92-g20a71511 +v2.0.3-100-g6270e6f8 From 59890750099ad650e0f7e310cea7bd74126c4fc6 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 10 Apr 2019 13:23:57 +0200 Subject: [PATCH 36/97] working for grid_mech_spectral_basic --- src/CPFEM2.f90 | 2 +- src/grid_mech_spectral_basic.f90 | 70 ++++++++++++++------------------ 2 files changed, 32 insertions(+), 40 deletions(-) diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 13d7f06c4..aba6006b2 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -257,7 +257,7 @@ subroutine CPFEM_age() write(6,'(a)') '<< CPFEM >> writing restart variables of last converged step to hdf5 file' write(rankStr,'(a1,i0)')'_',worldrank - fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','a') call HDF5_write(fileHandle,material_phase, 'recordedPhase') call HDF5_write(fileHandle,crystallite_F0, 'convergedF') diff --git a/src/grid_mech_spectral_basic.f90 b/src/grid_mech_spectral_basic.f90 index 99839e50f..2ed8bc683 100644 --- a/src/grid_mech_spectral_basic.f90 +++ b/src/grid_mech_spectral_basic.f90 @@ -7,6 +7,8 @@ module grid_mech_spectral_basic #include #include + use DAMASK_interface + use HDF5_utilities use PETScdmda use PETScsnes use prec, only: & @@ -114,8 +116,9 @@ subroutine grid_mech_spectral_basic_init PetscErrorCode :: ierr PetscScalar, pointer, dimension(:,:,:,:) :: & - F ! pointer to solution data + F ! pointer to solution data PetscInt, dimension(worldsize) :: localK + integer(HID_T) :: fileHandle integer :: fileUnit character(len=1024) :: rankStr @@ -174,19 +177,13 @@ subroutine grid_mech_spectral_basic_init restart: if (restartInc > 0) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading values of increment ', restartInc, ' from file' - fileUnit = IO_open_jobFile_binary('F_aim') - read(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc') - read(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot') - read(fileUnit) F_aimDot; close(fileUnit) - write(rankStr,'(a1,i0)')'_',worldrank - - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr)) - read(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr)) - read(fileUnit) F_lastInc; close (fileUnit) + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') + call HDF5_read(fileHandle,F_aim, 'F_aim') + call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') + call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_read(fileHandle,F, 'F') + call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') elseif (restartInc == 0) then restart F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity @@ -203,10 +200,10 @@ subroutine grid_mech_spectral_basic_init restartRead: if (restartInc > 0) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading more values of increment ', restartInc, ' from file' - fileUnit = IO_open_jobFile_binary('C_volAvg') - read(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') - read(fileUnit) C_volAvgLastInc; close(fileUnit) + call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_closeFile(fileHandle) + fileUnit = IO_open_jobFile_binary('C_ref') read(fileUnit) C_minMaxAvg; close(fileUnit) endif restartRead @@ -321,7 +318,7 @@ subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTi PetscErrorCode :: ierr PetscScalar, dimension(:,:,:,:), pointer :: F - integer :: fileUnit + integer(HID_T) :: fileHandle character(len=32) :: rankStr call DMDAVecGetArrayF90(da,solution_vec,F,ierr); CHKERRQ(ierr) @@ -331,29 +328,24 @@ subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTi C_minMaxAvg = C_minMaxAvgLastInc ! QUESTION: where is this required? else !-------------------------------------------------------------------------------------------------- - ! restart information for spectral solver + ! restart information for spectral solver if (restartWrite) then ! QUESTION: where is this logical properly set? - write(6,'(/,a)') ' writing converged results for restart' - flush(6) - - if (worldrank == 0) then - fileUnit = IO_open_jobFile_binary('C_volAvg','w') - write(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') - write(fileUnit) C_volAvgLastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim','w') - write(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') - write(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot','w') - write(fileUnit) F_aimDot; close(fileUnit) - endif - + write(6,'(/,a)') ' writing converged results for restart';flush(6) + write(rankStr,'(a1,i0)')'_',worldrank - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr),'w') - write(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr),'w') - write(fileUnit) F_lastInc; close (fileUnit) + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') + + print*, trim(getSolverJobName())//trim(rankStr)//'.hdf5';flush(6) + call HDF5_write(fileHandle,F_aim, 'F_aim') + call HDF5_write(fileHandle,F_aim_lastInc,'F_aim_lastInc') + call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_write(fileHandle,F, 'F') + call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') + + call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_write(fileHandle,C_minMaxAvg, 'C_minMaxAvg') + call HDF5_closeFile(fileHandle) endif call CPFEM_age ! age state and kinematics From 1852f580adf220b3bead9c2b13cd1e4f2ade4dce Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Wed, 10 Apr 2019 18:19:10 +0200 Subject: [PATCH 37/97] grid_mech_FEM works --- src/grid_mech_FEM.f90 | 70 ++++++++++++++++++------------------------- 1 file changed, 29 insertions(+), 41 deletions(-) diff --git a/src/grid_mech_FEM.f90 b/src/grid_mech_FEM.f90 index e31d93637..adcbb626b 100644 --- a/src/grid_mech_FEM.f90 +++ b/src/grid_mech_FEM.f90 @@ -7,6 +7,8 @@ module grid_mech_FEM #include #include + use DAMASK_interface + use HDF5_utilities use PETScdmda use PETScsnes use prec, only: & @@ -115,6 +117,7 @@ subroutine grid_mech_FEM_init PetscErrorCode :: ierr integer(pInt) :: rank integer :: fileUnit + integer(HID_T) :: fileHandle character(len=1024) :: rankStr real(pReal), dimension(3,3,3,3) :: devNull PetscScalar, pointer, dimension(:,:,:,:) :: & @@ -203,24 +206,16 @@ subroutine grid_mech_FEM_init restart: if (restartInc > 0) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading values of increment ', restartInc, ' from file' - fileUnit = IO_open_jobFile_binary('F_aim') - read(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc') - read(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot') - read(fileUnit) F_aimDot; close(fileUnit) - write(rankStr,'(a1,i0)')'_',worldrank - - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr)) - read(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr)) - read(fileUnit) F_lastInc; close (fileUnit) - fileUnit = IO_open_jobFile_binary('u'//trim(rankStr)) - read(fileUnit) u_current; close (fileUnit) - fileUnit = IO_open_jobFile_binary('u_lastInc'//trim(rankStr)) - read(fileUnit) u_lastInc; close (fileUnit) - + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') + call HDF5_read(fileHandle,F_aim, 'F_aim') + call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') + call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_read(fileHandle,F, 'F') + call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_read(fileHandle,u_current, 'u') + call HDF5_read(fileHandle,u_lastInc, 'u_lastInc') + elseif (restartInc == 0) then restart F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity F = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) @@ -238,10 +233,9 @@ subroutine grid_mech_FEM_init restartRead: if (restartInc > 0_pInt) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading more values of increment ', restartInc, ' from file' - fileUnit = IO_open_jobFile_binary('C_volAvg') - read(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') - read(fileUnit) C_volAvgLastInc; close(fileUnit) + call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_closeFile(fileHandle) endif restartRead end subroutine grid_mech_FEM_init @@ -348,6 +342,7 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat real(pReal), dimension(3,3), intent(in) :: & rotation_BC PetscErrorCode :: ierr + integer(HID_T) :: fileHandle integer :: fileUnit character(len=32) :: rankStr PetscScalar, pointer, dimension(:,:,:,:) :: & @@ -364,30 +359,23 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat if (restartWrite) then ! QUESTION: where is this logical properly set? write(6,'(/,a)') ' writing converged results for restart' flush(6) + + write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') if (worldrank == 0) then - fileUnit = IO_open_jobFile_binary('C_volAvg','w') - write(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') - write(fileUnit) C_volAvgLastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim','w') - write(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') - write(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot','w') - write(fileUnit) F_aimDot; close(fileUnit) + call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_write(fileHandle,F_aim, 'F_aim') + call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') + call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_write(fileHandle,F, 'F') + call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_write(fileHandle,u_current, 'u') + call HDF5_write(fileHandle,u_lastInc, 'u_lastInc') + call HDF5_closeFile(fileHandle) endif - write(rankStr,'(a1,i0)')'_',worldrank - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr),'w') - write(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr),'w') - write(fileUnit) F_lastInc; close (fileUnit) - fileUnit = IO_open_jobFile_binary('u'//trim(rankStr),'w') - write(fileUnit) u_current; close (fileUnit) - fileUnit = IO_open_jobFile_binary('u_lastInc'//trim(rankStr),'w') - write(fileUnit) u_lastInc; close (fileUnit) - endif call CPFEM_age() ! age state and kinematics call utilities_updateIPcoords(F) From 43a59a5e9ffde78d3fdc09174db10288aa119179 Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 10 Apr 2019 22:53:31 +0200 Subject: [PATCH 38/97] [skip ci] updated version information after successful test of v2.0.3-130-gda034f97 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 103e1d432..a55a6e6d5 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.3-100-g6270e6f8 +v2.0.3-130-gda034f97 From 8e295cbadf3b88276465234d669a26c90f8d03ea Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 11 Apr 2019 12:22:16 +0200 Subject: [PATCH 39/97] no need to create type for native data types --- src/HDF5_utilities.f90 | 102 +++++++++++++++++++---------------------- 1 file changed, 47 insertions(+), 55 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index a2593e1cb..38d3f475f 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -268,10 +268,11 @@ end subroutine HDF5_closeGroup !-------------------------------------------------------------------------------------------------- logical function HDF5_objectExists(loc_id,path) - integer(HID_T), intent(in) :: loc_id + integer(HID_T), intent(in) :: loc_id character(len=*), intent(in), optional :: path - integer :: hdferr - character(len=256) :: p + + integer :: hdferr + character(len=256) :: p if (present(path)) then p = trim(path) @@ -295,13 +296,14 @@ end function HDF5_objectExists !-------------------------------------------------------------------------------------------------- subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path) - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in) :: attrLabel, attrValue - character(len=*), intent(in), optional :: path - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - logical :: attrExists - character(len=256) :: p + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel, attrValue + character(len=*), intent(in), optional :: path + + integer :: hdferr + integer(HID_T) :: attr_id, space_id, type_id + logical :: attrExists + character(len=256) :: p if (present(path)) then p = trim(path) @@ -340,14 +342,15 @@ end subroutine HDF5_addAttribute_str !-------------------------------------------------------------------------------------------------- subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path) - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in) :: attrLabel - integer(pInt), intent(in) :: attrValue + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel + integer(pInt), intent(in) :: attrValue character(len=*), intent(in), optional :: path - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - logical :: attrExists - character(len=256) :: p + + integer :: hdferr + integer(HID_T) :: attr_id, space_id + logical :: attrExists + character(len=256) :: p if (present(path)) then p = trim(path) @@ -356,27 +359,21 @@ subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path) endif call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5screate_f') - call h5tcopy_f(H5T_NATIVE_INTEGER, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tcopy_f') - call h5tset_size_f(type_id, 1_HSIZE_T, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tset_size_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5screate_f') call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5aexists_by_name_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5aexists_by_name_f') if (attrExists) then call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5adelete_by_name_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5adelete_by_name_f') endif - call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5acreate_f') - call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5awrite_f') + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5acreate_f') + call h5awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5awrite_f') call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5aclose_f') - call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5tclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5tclose_f') call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pInt: h5sclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5sclose_f') end subroutine HDF5_addAttribute_int @@ -386,14 +383,15 @@ end subroutine HDF5_addAttribute_int !-------------------------------------------------------------------------------------------------- subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path) - integer(HID_T), intent(in) :: loc_id - character(len=*), intent(in) :: attrLabel - real(pReal), intent(in) :: attrValue - character(len=*), intent(in), optional :: path - integer :: hdferr - integer(HID_T) :: attr_id, space_id, type_id - logical :: attrExists - character(len=256) :: p + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel + real(pReal), intent(in) :: attrValue + character(len=*), intent(in), optional :: path + + integer :: hdferr + integer(HID_T) :: attr_id, space_id + logical :: attrExists + character(len=256) :: p if (present(path)) then p = trim(path) @@ -402,27 +400,21 @@ subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path) endif call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5screate_f') - call h5tcopy_f(H5T_NATIVE_DOUBLE, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tcopy_f') - call h5tset_size_f(type_id, 8_HSIZE_T, hdferr) ! ToDo - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tset_size_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5screate_f') call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5aexists_by_name_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5aexists_by_name_f') if (attrExists) then call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5adelete_by_name_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5adelete_by_name_f') endif - call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5acreate_f') - call h5awrite_f(attr_id, type_id, attrValue, int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5awrite_f') + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5acreate_f') + call h5awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, int([1],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5awrite_f') call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5aclose_f') - call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5tclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5tclose_f') call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_pReal: h5sclose_f') + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5sclose_f') end subroutine HDF5_addAttribute_real From 3c8d96c54cbe219120108e486fe96cccebe5c111 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 11 Apr 2019 15:44:08 +0200 Subject: [PATCH 40/97] enable more complex attributes --- src/HDF5_utilities.f90 | 90 ++++++++++++++++++++++++++++++++++++++++++ src/results.f90 | 73 +++++++++++++++++++++++++++++++--- 2 files changed, 158 insertions(+), 5 deletions(-) diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 38d3f475f..731b44f06 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -70,6 +70,8 @@ module HDF5_utilities module procedure HDF5_addAttribute_str module procedure HDF5_addAttribute_int module procedure HDF5_addAttribute_real + module procedure HDF5_addAttribute_int_array + module procedure HDF5_addAttribute_real_array end interface HDF5_addAttribute @@ -419,6 +421,94 @@ subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path) end subroutine HDF5_addAttribute_real +!-------------------------------------------------------------------------------------------------- +!> @brief adds a integer attribute to the path given relative to the location +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addAttribute_int_array(loc_id,attrLabel,attrValue,path) + + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel + integer(pInt), intent(in), dimension(:) :: attrValue + character(len=*), intent(in), optional :: path + + integer :: hdferr + integer(HID_T) :: attr_id, space_id + integer(HSIZE_T),dimension(1) :: array_size + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif + + array_size = size(attrValue,kind=HSIZE_T) + + call h5screate_simple_f(1, array_size, space_id, hdferr, array_size) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5screate_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5acreate_f') + call h5awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, array_size, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5sclose_f') + +end subroutine HDF5_addAttribute_int_array + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a real attribute to the path given relative to the location +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addAttribute_real_array(loc_id,attrLabel,attrValue,path) + + integer(HID_T), intent(in) :: loc_id + character(len=*), intent(in) :: attrLabel + real(pReal), intent(in), dimension(:) :: attrValue + character(len=*), intent(in), optional :: path + + integer :: hdferr + integer(HID_T) :: attr_id, space_id + integer(HSIZE_T),dimension(1) :: array_size + logical :: attrExists + character(len=256) :: p + + if (present(path)) then + p = trim(path) + else + p = '.' + endif + + array_size = size(attrValue,kind=HSIZE_T) + + call h5screate_simple_f(1, array_size, space_id, hdferr, array_size) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5screate_f') + call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5aexists_by_name_f') + if (attrExists) then + call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5adelete_by_name_f') + endif + call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5acreate_f') + call h5awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, array_size, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5tclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5sclose_f') + +end subroutine HDF5_addAttribute_real_array + + !-------------------------------------------------------------------------------------------------- !> @brief set link to object in results file !-------------------------------------------------------------------------------------------------- diff --git a/src/results.f90 b/src/results.f90 index 4ed5cc751..20c2aa143 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -27,6 +27,17 @@ module results module procedure results_writeScalarDataset_rotation end interface results_writeDataset + + interface results_addAttribute + + module procedure results_addAttribute_real + module procedure results_addAttribute_int + module procedure results_addAttribute_str + + module procedure results_addAttribute_int_array + module procedure results_addAttribute_real_array + + end interface results_addAttribute public :: & results_init, & @@ -144,15 +155,67 @@ end subroutine results_setLink !-------------------------------------------------------------------------------------------------- -!> @brief adds an attribute to an object +!> @brief adds a string attribute to an object in the results file !-------------------------------------------------------------------------------------------------- -subroutine results_addAttribute(attrLabel,attrValue,path) +subroutine results_addAttribute_str(attrLabel,attrValue,path) - character(len=*), intent(in) :: attrLabel, attrValue, path + character(len=*), intent(in) :: attrLabel, attrValue, path - call HDF5_addAttribute_str(resultsFile,attrLabel, attrValue, path) + call HDF5_addAttribute(resultsFile,attrLabel, attrValue, path) -end subroutine results_addAttribute +end subroutine results_addAttribute_str + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds an integer attribute an object in the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_addAttribute_int(attrLabel,attrValue,path) + + character(len=*), intent(in) :: attrLabel, path + integer, intent(in) :: attrValue + + call HDF5_addAttribute(resultsFile,attrLabel, attrValue, path) + +end subroutine results_addAttribute_int + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a real attribute an object in the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_addAttribute_real(attrLabel,attrValue,path) + + character(len=*), intent(in) :: attrLabel, path + real(pReal), intent(in) :: attrValue + + call HDF5_addAttribute(resultsFile,attrLabel, attrValue, path) + +end subroutine results_addAttribute_real + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds an integer array attribute an object in the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_addAttribute_int_array(attrLabel,attrValue,path) + + character(len=*), intent(in) :: attrLabel, path + integer, intent(in), dimension(:) :: attrValue + + call HDF5_addAttribute(resultsFile,attrLabel, attrValue, path) + +end subroutine results_addAttribute_int_array + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a real array attribute an object in the results file +!-------------------------------------------------------------------------------------------------- +subroutine results_addAttribute_real_array(attrLabel,attrValue,path) + + character(len=*), intent(in) :: attrLabel, path + real(pReal), intent(in), dimension(:) :: attrValue + + call HDF5_addAttribute(resultsFile,attrLabel, attrValue, path) + +end subroutine results_addAttribute_real_array !-------------------------------------------------------------------------------------------------- From 12efa108d6c0bd68fad42e5c3d15ebd6d28dcd07 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 11 Apr 2019 15:44:34 +0200 Subject: [PATCH 41/97] store grid and size store it temporarly at "mappings", later on they will be attached to the (no yet existing) coordinates --- src/DAMASK_grid.f90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/DAMASK_grid.f90 b/src/DAMASK_grid.f90 index 29b505d14..f2f52bb2f 100644 --- a/src/DAMASK_grid.f90 +++ b/src/DAMASK_grid.f90 @@ -358,6 +358,11 @@ program DAMASK_spectral enddo close(fileUnit) + call results_openJobFile + call results_addAttribute('grid',grid,'mapping') + call results_addAttribute('size',geomSize,'mapping') + call results_closeJobFile + !-------------------------------------------------------------------------------------------------- ! doing initialization depending on active solvers call Utilities_init() From 8609c959dffae0aaad950ce01db697c472fdefc7 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Thu, 11 Apr 2019 15:51:34 +0200 Subject: [PATCH 42/97] grid_mech_polarisation works --- src/grid_mech_spectral_polarisation.f90 | 121 +++++++++++++++--------- 1 file changed, 77 insertions(+), 44 deletions(-) diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 index aff4913b1..e87b8ec46 100644 --- a/src/grid_mech_spectral_polarisation.f90 +++ b/src/grid_mech_spectral_polarisation.f90 @@ -7,6 +7,8 @@ module grid_mech_spectral_polarisation #include #include + use DAMASK_interface + use HDF5_utilities use PETScdmda use PETScsnes use prec, only: & @@ -124,6 +126,7 @@ subroutine grid_mech_spectral_polarisation_init F, & ! specific (sub)pointer F_tau ! specific (sub)pointer PetscInt, dimension(worldsize) :: localK + integer(HID_T) :: fileHandle integer :: fileUnit character(len=1024) :: rankStr @@ -183,23 +186,34 @@ subroutine grid_mech_spectral_polarisation_init restart: if (restartInc > 0) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading values of increment ', restartInc, ' from file' - fileUnit = IO_open_jobFile_binary('F_aim') - read(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc') - read(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot') - read(fileUnit) F_aimDot; close(fileUnit) - write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr)) - read(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr)) - read(fileUnit) F_lastInc; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_tau'//trim(rankStr)) - read(fileUnit) F_tau; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_tau_lastInc'//trim(rankStr)) - read(fileUnit) F_tau_lastInc; close (fileUnit) + call HDF5_read(fileHandle,F_aim, 'F_aim') + call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') + call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_read(fileHandle,F, 'F') + call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_read(fileHandle,F_tau, 'F_tau') + call HDF5_read(fileHandle,F_tau_lastInc, 'F_tau_lastInc') + + ! fileUnit = IO_open_jobFile_binary('F_aim') + ! read(fileUnit) F_aim; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_aim_lastInc') + ! read(fileUnit) F_aim_lastInc; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_aimDot') + ! read(fileUnit) F_aimDot; close(fileUnit) + + ! write(rankStr,'(a1,i0)')'_',worldrank + + ! fileUnit = IO_open_jobFile_binary('F'//trim(rankStr)) + ! read(fileUnit) F; close (fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr)) + ! read(fileUnit) F_lastInc; close (fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_tau'//trim(rankStr)) + ! read(fileUnit) F_tau; close (fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_tau_lastInc'//trim(rankStr)) + ! read(fileUnit) F_tau_lastInc; close (fileUnit) elseif (restartInc == 0) then restart F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity @@ -218,12 +232,16 @@ subroutine grid_mech_spectral_polarisation_init restartRead: if (restartInc > 0) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading more values of increment ', restartInc, ' from file' - fileUnit = IO_open_jobFile_binary('C_volAvg') - read(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') - read(fileUnit) C_volAvgLastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_ref') - read(fileUnit) C_minMaxAvg; close(fileUnit) + call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_read(fileHandle,C_minMaxAvg,'C_ref') + call HDF5_closeFile(fileHandle) + ! fileUnit = IO_open_jobFile_binary('C_volAvg') + ! read(fileUnit) C_volAvg; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') + ! read(fileUnit) C_volAvgLastInc; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('C_ref') + ! read(fileUnit) C_minMaxAvg; close(fileUnit) endif restartRead call Utilities_updateGamma(C_minMaxAvg,.true.) @@ -348,6 +366,7 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa real(pReal), dimension(3,3) :: F_lambda33 integer :: fileUnit + integer(HID_T) :: fileHandle character(len=32) :: rankStr call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) @@ -361,31 +380,45 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa !-------------------------------------------------------------------------------------------------- ! restart information for spectral solver if (restartWrite) then ! QUESTION: where is this logical properly set? - write(6,'(/,a)') ' writing converged results for restart' - flush(6) - - if (worldrank == 0) then - fileUnit = IO_open_jobFile_binary('C_volAvg','w') - write(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') - write(fileUnit) C_volAvgLastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim','w') - write(fileUnit) F_aim; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') - write(fileUnit) F_aim_lastInc; close(fileUnit) - fileUnit = IO_open_jobFile_binary('F_aimDot','w') - write(fileUnit) F_aimDot; close(fileUnit) - endif + write(6,'(/,a)') ' writing converged results for restart';flush(6) write(rankStr,'(a1,i0)')'_',worldrank - fileUnit = IO_open_jobFile_binary('F'//trim(rankStr),'w') - write(fileUnit) F; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr),'w') - write(fileUnit) F_lastInc; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_tau'//trim(rankStr),'w') - write(fileUnit) F_tau; close (fileUnit) - fileUnit = IO_open_jobFile_binary('F_tau_lastInc'//trim(rankStr),'w') - write(fileUnit) F_tau_lastInc; close (fileUnit) + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') + + if (worldrank == 0) then + call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_write(fileHandle,F_aim, 'F_aim') + call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') + ! fileUnit = IO_open_jobFile_binary('C_volAvg','w') + ! write(fileUnit) C_volAvg; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') + ! write(fileUnit) C_volAvgLastInc; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_aim','w') + ! write(fileUnit) F_aim; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') + ! write(fileUnit) F_aim_lastInc; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_aimDot','w') + call HDF5_closeFile(fileHandle) + !write(fileUnit) F_aimDot; close(fileUnit) + endif + + !write(rankStr,'(a1,i0)')'_',worldrank + call HDF5_write(fileHandle,F, 'F') + call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_write(fileHandle,F_tau, 'F_tau') + call HDF5_write(fileHandle,F_tau_lastInc, 'F_tau_lastInc') + call HDF5_closeFile(fileHandle) + +! fileUnit = IO_open_jobFile_binary('F'//trim(rankStr),'w') +! write(fileUnit) F; close (fileUnit) +! fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr),'w') +! write(fileUnit) F_lastInc; close (fileUnit) +! fileUnit = IO_open_jobFile_binary('F_tau'//trim(rankStr),'w') +! write(fileUnit) F_tau; close (fileUnit) +! fileUnit = IO_open_jobFile_binary('F_tau_lastInc'//trim(rankStr),'w') +! write(fileUnit) F_tau_lastInc; close (fileUnit) endif call CPFEM_age ! age state and kinematics From a5b3fa565f1299add358bddcae65e7d70203f84c Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Thu, 11 Apr 2019 18:36:28 +0200 Subject: [PATCH 43/97] Some incorrect variable names fixed --- src/grid_mech_spectral_polarisation.f90 | 68 ++++++++++++------------- 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 index e87b8ec46..1f64be0a0 100644 --- a/src/grid_mech_spectral_polarisation.f90 +++ b/src/grid_mech_spectral_polarisation.f90 @@ -232,16 +232,16 @@ subroutine grid_mech_spectral_polarisation_init restartRead: if (restartInc > 0) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading more values of increment ', restartInc, ' from file' - call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') - call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') - call HDF5_read(fileHandle,C_minMaxAvg,'C_ref') - call HDF5_closeFile(fileHandle) - ! fileUnit = IO_open_jobFile_binary('C_volAvg') - ! read(fileUnit) C_volAvg; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') - ! read(fileUnit) C_volAvgLastInc; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('C_ref') - ! read(fileUnit) C_minMaxAvg; close(fileUnit) + ! call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') + ! call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + ! call HDF5_read(fileHandle,C_minMaxAvg,'C_ref') + ! call HDF5_closeFile(fileHandle) + fileUnit = IO_open_jobFile_binary('C_volAvg') + read(fileUnit) C_volAvg; close(fileUnit) + fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') + read(fileUnit) C_volAvgLastInc; close(fileUnit) + fileUnit = IO_open_jobFile_binary('C_ref') + read(fileUnit) C_minMaxAvg; close(fileUnit) endif restartRead call Utilities_updateGamma(C_minMaxAvg,.true.) @@ -384,41 +384,41 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa write(rankStr,'(a1,i0)')'_',worldrank fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') - + if (worldrank == 0) then - call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') - call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + ! call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') + ! call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') call HDF5_write(fileHandle,F_aim, 'F_aim') call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') - call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') - ! fileUnit = IO_open_jobFile_binary('C_volAvg','w') - ! write(fileUnit) C_volAvg; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') - ! write(fileUnit) C_volAvgLastInc; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_aim','w') - ! write(fileUnit) F_aim; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') - ! write(fileUnit) F_aim_lastInc; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_aimDot','w') - call HDF5_closeFile(fileHandle) - !write(fileUnit) F_aimDot; close(fileUnit) + call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') + fileUnit = IO_open_jobFile_binary('C_volAvg','w') + write(fileUnit) C_volAvg; close(fileUnit) + fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') + write(fileUnit) C_volAvgLastInc; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_aim','w') + ! write(fileUnit) F_aim; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') + ! write(fileUnit) F_aim_lastInc; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('F_aimDot','w') + ! call HDF5_closeFile(fileHandle) + ! write(fileUnit) F_aimDot; close(fileUnit) endif - !write(rankStr,'(a1,i0)')'_',worldrank + write(rankStr,'(a1,i0)')'_',worldrank call HDF5_write(fileHandle,F, 'F') call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') call HDF5_write(fileHandle,F_tau, 'F_tau') call HDF5_write(fileHandle,F_tau_lastInc, 'F_tau_lastInc') call HDF5_closeFile(fileHandle) -! fileUnit = IO_open_jobFile_binary('F'//trim(rankStr),'w') -! write(fileUnit) F; close (fileUnit) -! fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr),'w') -! write(fileUnit) F_lastInc; close (fileUnit) -! fileUnit = IO_open_jobFile_binary('F_tau'//trim(rankStr),'w') -! write(fileUnit) F_tau; close (fileUnit) -! fileUnit = IO_open_jobFile_binary('F_tau_lastInc'//trim(rankStr),'w') -! write(fileUnit) F_tau_lastInc; close (fileUnit) + !fileUnit = IO_open_jobFile_binary('F'//trim(rankStr),'w') + !write(fileUnit) F; close (fileUnit) + !fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr),'w') + !write(fileUnit) F_lastInc; close (fileUnit) + !fileUnit = IO_open_jobFile_binary('F_tau'//trim(rankStr),'w') + !write(fileUnit) F_tau; close (fileUnit) + !fileUnit = IO_open_jobFile_binary('F_tau_lastInc'//trim(rankStr),'w') + !write(fileUnit) F_tau_lastInc; close (fileUnit) endif call CPFEM_age ! age state and kinematics From 057bee92afe0d055c58630bafd5c985b256a8414 Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Thu, 11 Apr 2019 18:43:20 +0200 Subject: [PATCH 44/97] adding C_ref to HDF5 file doesnt work --- src/grid_mech_spectral_polarisation.f90 | 28 ++++++++++++------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 index 1f64be0a0..c549cd591 100644 --- a/src/grid_mech_spectral_polarisation.f90 +++ b/src/grid_mech_spectral_polarisation.f90 @@ -232,14 +232,14 @@ subroutine grid_mech_spectral_polarisation_init restartRead: if (restartInc > 0) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading more values of increment ', restartInc, ' from file' - ! call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') - ! call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') - ! call HDF5_read(fileHandle,C_minMaxAvg,'C_ref') - ! call HDF5_closeFile(fileHandle) - fileUnit = IO_open_jobFile_binary('C_volAvg') - read(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') - read(fileUnit) C_volAvgLastInc; close(fileUnit) + call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + !call HDF5_read(fileHandle,C_minMaxAvg,'C_ref') + call HDF5_closeFile(fileHandle) + ! fileUnit = IO_open_jobFile_binary('C_volAvg') + ! read(fileUnit) C_volAvg; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') + ! read(fileUnit) C_volAvgLastInc; close(fileUnit) fileUnit = IO_open_jobFile_binary('C_ref') read(fileUnit) C_minMaxAvg; close(fileUnit) endif restartRead @@ -386,15 +386,15 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') if (worldrank == 0) then - ! call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') - ! call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') call HDF5_write(fileHandle,F_aim, 'F_aim') call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') - fileUnit = IO_open_jobFile_binary('C_volAvg','w') - write(fileUnit) C_volAvg; close(fileUnit) - fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') - write(fileUnit) C_volAvgLastInc; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('C_volAvg','w') + ! write(fileUnit) C_volAvg; close(fileUnit) + ! fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') + ! write(fileUnit) C_volAvgLastInc; close(fileUnit) ! fileUnit = IO_open_jobFile_binary('F_aim','w') ! write(fileUnit) F_aim; close(fileUnit) ! fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') From a59c5c30c90e134ea58cefdf2f429ab0f81cd16a Mon Sep 17 00:00:00 2001 From: Vitesh Shah Date: Thu, 11 Apr 2019 18:48:28 +0200 Subject: [PATCH 45/97] some cleanup --- src/grid_mech_spectral_polarisation.f90 | 41 ------------------------- 1 file changed, 41 deletions(-) diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 index c549cd591..12183db0e 100644 --- a/src/grid_mech_spectral_polarisation.f90 +++ b/src/grid_mech_spectral_polarisation.f90 @@ -197,23 +197,6 @@ subroutine grid_mech_spectral_polarisation_init call HDF5_read(fileHandle,F_tau, 'F_tau') call HDF5_read(fileHandle,F_tau_lastInc, 'F_tau_lastInc') - ! fileUnit = IO_open_jobFile_binary('F_aim') - ! read(fileUnit) F_aim; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_aim_lastInc') - ! read(fileUnit) F_aim_lastInc; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_aimDot') - ! read(fileUnit) F_aimDot; close(fileUnit) - - ! write(rankStr,'(a1,i0)')'_',worldrank - - ! fileUnit = IO_open_jobFile_binary('F'//trim(rankStr)) - ! read(fileUnit) F; close (fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr)) - ! read(fileUnit) F_lastInc; close (fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_tau'//trim(rankStr)) - ! read(fileUnit) F_tau; close (fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_tau_lastInc'//trim(rankStr)) - ! read(fileUnit) F_tau_lastInc; close (fileUnit) elseif (restartInc == 0) then restart F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity @@ -234,12 +217,7 @@ subroutine grid_mech_spectral_polarisation_init write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading more values of increment ', restartInc, ' from file' call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') - !call HDF5_read(fileHandle,C_minMaxAvg,'C_ref') call HDF5_closeFile(fileHandle) - ! fileUnit = IO_open_jobFile_binary('C_volAvg') - ! read(fileUnit) C_volAvg; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('C_volAvgLastInv') - ! read(fileUnit) C_volAvgLastInc; close(fileUnit) fileUnit = IO_open_jobFile_binary('C_ref') read(fileUnit) C_minMaxAvg; close(fileUnit) endif restartRead @@ -391,17 +369,6 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa call HDF5_write(fileHandle,F_aim, 'F_aim') call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') - ! fileUnit = IO_open_jobFile_binary('C_volAvg','w') - ! write(fileUnit) C_volAvg; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('C_volAvgLastInv','w') - ! write(fileUnit) C_volAvgLastInc; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_aim','w') - ! write(fileUnit) F_aim; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_aim_lastInc','w') - ! write(fileUnit) F_aim_lastInc; close(fileUnit) - ! fileUnit = IO_open_jobFile_binary('F_aimDot','w') - ! call HDF5_closeFile(fileHandle) - ! write(fileUnit) F_aimDot; close(fileUnit) endif write(rankStr,'(a1,i0)')'_',worldrank @@ -411,14 +378,6 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa call HDF5_write(fileHandle,F_tau_lastInc, 'F_tau_lastInc') call HDF5_closeFile(fileHandle) - !fileUnit = IO_open_jobFile_binary('F'//trim(rankStr),'w') - !write(fileUnit) F; close (fileUnit) - !fileUnit = IO_open_jobFile_binary('F_lastInc'//trim(rankStr),'w') - !write(fileUnit) F_lastInc; close (fileUnit) - !fileUnit = IO_open_jobFile_binary('F_tau'//trim(rankStr),'w') - !write(fileUnit) F_tau; close (fileUnit) - !fileUnit = IO_open_jobFile_binary('F_tau_lastInc'//trim(rankStr),'w') - !write(fileUnit) F_tau_lastInc; close (fileUnit) endif call CPFEM_age ! age state and kinematics From 0335207956668c8652774341c93dd2026fab1d46 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 13 Apr 2019 00:36:13 +0200 Subject: [PATCH 46/97] complex orientation initialization conflicts with phase field - easier to do as pre processing (python) - ensures same solution independently of random number --- .gitlab-ci.yml | 7 ---- src/IO.f90 | 2 + src/material.f90 | 99 +++--------------------------------------------- 3 files changed, 7 insertions(+), 101 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1e1b8fe49..31501edd0 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -382,13 +382,6 @@ Phenopowerlaw_singleSlip: - master - release -TextureComponents: - stage: grid - script: TextureComponents/test.py - except: - - master - - release - ################################################################################################### Marc_compileIfort2018_1: diff --git a/src/IO.f90 b/src/IO.f90 index 33c4a778d..074e2b0f4 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -708,6 +708,8 @@ subroutine IO_error(error_ID,el,ip,g,instance,ext_msg) msg = 'too many systems requested' case (146_pInt) msg = 'number of values does not match' + case (147_pInt) + msg = 'not supported anymore' !-------------------------------------------------------------------------------------------------- ! material error messages and related messages in mesh diff --git a/src/material.f90 b/src/material.f90 index 0b749c8ef..383462ae1 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -856,34 +856,9 @@ subroutine material_parseTexture if(dNeq(math_det33(texture_transformation(1:3,1:3,t)),1.0_pReal)) call IO_error(157_pInt,t) endif - if (config_texture(t)%keyExists('symmetry')) then - select case (config_texture(t)%getString('symmetry')) - case('orthotropic') - texture_symmetry(t) = 4_pInt - case('monoclinic') - texture_symmetry(t) = 2_pInt - case default - texture_symmetry(t) = 1_pInt - end select - endif - - if (config_texture(t)%keyExists('(random)')) then - strings = config_texture(t)%getStrings('(random)',raw=.true.) - do i = 1_pInt, size(strings) - gauss = gauss + 1_pInt - texture_Gauss(1:3,gauss,t) = math_sampleRandomOri() - chunkPos = IO_stringPos(strings(i)) - do j = 1_pInt,3_pInt,2_pInt - select case (IO_stringValue(strings(i),chunkPos,j)) - case('scatter') - texture_Gauss(4,gauss,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('fraction') - texture_Gauss(5,gauss,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt) - end select - enddo - enddo - endif - + if (config_texture(t)%keyExists('symmetry')) call IO_error(147,ext_msg='symmetry') + if (config_texture(t)%keyExists('(random)')) call IO_error(147,ext_msg='(random)') + if (config_texture(t)%keyExists('(fiber)')) call IO_error(147,ext_msg='(fiber)') if (config_texture(t)%keyExists('(gauss)')) then gauss = gauss + 1_pInt @@ -906,31 +881,6 @@ subroutine material_parseTexture enddo enddo endif - - - if (config_texture(t)%keyExists('(fiber)')) then - fiber = fiber + 1_pInt - strings = config_texture(t)%getStrings('(fiber)',raw= .true.) - do i = 1_pInt, size(strings) - chunkPos = IO_stringPos(strings(i)) - do j = 1_pInt,11_pInt,2_pInt - select case (IO_stringValue(strings(i),chunkPos,j)) - case('alpha1') - texture_Fiber(1,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('alpha2') - texture_Fiber(2,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('beta1') - texture_Fiber(3,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('beta2') - texture_Fiber(4,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('scatter') - texture_Fiber(5,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt)*inRad - case('fraction') - texture_Fiber(6,fiber,t) = IO_floatValue(strings(i),chunkPos,j+1_pInt) - end select - enddo - enddo - endif enddo call config_deallocate('material.config/texture') @@ -1040,11 +990,7 @@ subroutine material_populateGrains math_RtoEuler, & math_EulerToR, & math_mul33x33, & - math_range, & - math_sampleRandomOri, & - math_sampleGaussOri, & - math_sampleFiberOri, & - math_symmetricEulers + math_range use mesh, only: & theMesh, & mesh_ipVolume @@ -1226,28 +1172,12 @@ subroutine material_populateGrains ! has texture components gauss: do t = 1_pInt,texture_Ngauss(textureID) ! loop over Gauss components do g = 1_pInt,int(real(myNorientations,pReal)*texture_Gauss(5,t,textureID),pInt) ! loop over required grain count - orientationOfGrain(:,grain+constituentGrain+g) = & - math_sampleGaussOri(texture_Gauss(1:3,t,textureID),& - texture_Gauss( 4,t,textureID)) + orientationOfGrain(:,grain+constituentGrain+g) = texture_Gauss(1:3,t,textureID) enddo constituentGrain = & constituentGrain + int(real(myNorientations,pReal)*texture_Gauss(5,t,textureID)) ! advance counter for grains of current constituent enddo gauss - fiber: do t = 1_pInt,texture_Nfiber(textureID) ! loop over fiber components - do g = 1_pInt,int(real(myNorientations,pReal)*texture_Fiber(6,t,textureID),pInt) ! loop over required grain count - orientationOfGrain(:,grain+constituentGrain+g) = & - math_sampleFiberOri(texture_Fiber(1:2,t,textureID),& - texture_Fiber(3:4,t,textureID),& - texture_Fiber( 5,t,textureID)) - enddo - constituentGrain = & - constituentGrain + int(real(myNorientations,pReal)*texture_fiber(6,t,textureID),pInt) ! advance counter for grains of current constituent - enddo fiber - - random: do constituentGrain = constituentGrain+1_pInt,myNorientations ! fill remainder with random - orientationOfGrain(:,grain+constituentGrain) = math_sampleRandomOri() - enddo random !-------------------------------------------------------------------------------------------------- ! ...texture transformation @@ -1261,25 +1191,6 @@ subroutine material_populateGrains ) enddo -!-------------------------------------------------------------------------------------------------- -! ...sample symmetry - - symExtension = texture_symmetry(textureID) - 1_pInt - if (symExtension > 0_pInt) then ! sample symmetry (number of additional equivalent orientations) - constituentGrain = myNorientations ! start right after "real" orientations - do j = 1_pInt,myNorientations ! loop over each "real" orientation - symOrientation = math_symmetricEulers(texture_symmetry(textureID), & - orientationOfGrain(1:3,grain+j)) ! get symmetric equivalents - e = min(symExtension,NgrainsOfConstituent(i)-constituentGrain) ! do not overshoot end of constituent grain array - if (e > 0_pInt) then - orientationOfGrain(1:3,grain+constituentGrain+1: & - grain+constituentGrain+e) = & - symOrientation(1:3,1:e) - constituentGrain = constituentGrain + e ! remainder shrinks by e - endif - enddo - endif - !-------------------------------------------------------------------------------------------------- ! shuffle grains within current constituent From 0c6fde97f9bed2ea1b7476240b0eabccbdb33d15 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 13 Apr 2019 00:42:05 +0200 Subject: [PATCH 47/97] wrong positions for point visualization - now the cell centers are at the centers of the cells for cell visualization --- processing/post/addDisplacement.py | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/processing/post/addDisplacement.py b/processing/post/addDisplacement.py index aa12ba2b1..53311ce9e 100755 --- a/processing/post/addDisplacement.py +++ b/processing/post/addDisplacement.py @@ -40,9 +40,10 @@ def displacementAvgFFT(F,grid,size,nodal=False,transformed=False): np.linspace(0,size[0],1+grid[0]), indexing = 'ij') else: - x, y, z = np.meshgrid(np.linspace(0,size[2],grid[2],endpoint=False), - np.linspace(0,size[1],grid[1],endpoint=False), - np.linspace(0,size[0],grid[0],endpoint=False), + delta = size/grid*0.5 + x, y, z = np.meshgrid(np.linspace(delta[2],size[2]-delta[2],grid[2]), + np.linspace(delta[1],size[1]-delta[1],grid[1]), + np.linspace(delta[0],size[0]-delta[0],grid[0]), indexing = 'ij') origCoords = np.concatenate((z[:,:,:,None],y[:,:,:,None],x[:,:,:,None]),axis = 3) From ffdd3955a3b9902835943d5f8811eee60acba0e1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 13 Apr 2019 00:44:00 +0200 Subject: [PATCH 48/97] implicit none is not needed --- src/quaternions.f90 | 31 +++++-------------------------- 1 file changed, 5 insertions(+), 26 deletions(-) diff --git a/src/quaternions.f90 b/src/quaternions.f90 index 2716817cf..fa9c13f38 100644 --- a/src/quaternions.f90 +++ b/src/quaternions.f90 @@ -77,11 +77,11 @@ module quaternions procedure, private :: pow_scal__ generic, public :: operator(**) => pow_quat__, pow_scal__ - procedure, private :: abs__ - procedure, private :: dot_product__ - procedure, private :: conjg__ - procedure, private :: exp__ - procedure, private :: log__ + procedure, public :: abs__ + procedure, public :: dot_product__ + procedure, public :: conjg__ + procedure, public :: exp__ + procedure, public :: log__ procedure, public :: homomorphed => quat_homomorphed @@ -124,7 +124,6 @@ contains !--------------------------------------------------------------------------------------------------- type(quaternion) pure function init__(array) - implicit none real(pReal), intent(in), dimension(4) :: array init__%w=array(1) @@ -140,7 +139,6 @@ end function init__ !--------------------------------------------------------------------------------------------------- elemental subroutine assign_quat__(self,other) - implicit none type(quaternion), intent(out) :: self type(quaternion), intent(in) :: other @@ -157,7 +155,6 @@ end subroutine assign_quat__ !--------------------------------------------------------------------------------------------------- pure subroutine assign_vec__(self,other) - implicit none type(quaternion), intent(out) :: self real(pReal), intent(in), dimension(4) :: other @@ -174,7 +171,6 @@ end subroutine assign_vec__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function add__(self,other) - implicit none class(quaternion), intent(in) :: self,other add__%w = self%w + other%w @@ -190,7 +186,6 @@ end function add__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function pos__(self) - implicit none class(quaternion), intent(in) :: self pos__%w = self%w @@ -206,7 +201,6 @@ end function pos__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function sub__(self,other) - implicit none class(quaternion), intent(in) :: self,other sub__%w = self%w - other%w @@ -222,7 +216,6 @@ end function sub__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function neg__(self) - implicit none class(quaternion), intent(in) :: self neg__%w = -self%w @@ -238,7 +231,6 @@ end function neg__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function mul_quat__(self,other) - implicit none class(quaternion), intent(in) :: self, other mul_quat__%w = self%w*other%w - self%x*other%x - self%y*other%y - self%z*other%z @@ -254,7 +246,6 @@ end function mul_quat__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function mul_scal__(self,scal) - implicit none class(quaternion), intent(in) :: self real(pReal), intent(in) :: scal @@ -271,7 +262,6 @@ end function mul_scal__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function div_quat__(self,other) - implicit none class(quaternion), intent(in) :: self, other div_quat__ = self * (conjg(other)/(abs(other)**2.0_pReal)) @@ -284,7 +274,6 @@ end function div_quat__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function div_scal__(self,scal) - implicit none class(quaternion), intent(in) :: self real(pReal), intent(in) :: scal @@ -300,7 +289,6 @@ logical elemental function eq__(self,other) use prec, only: & dEq - implicit none class(quaternion), intent(in) :: self,other eq__ = all(dEq([ self%w, self%x, self%y, self%z], & @@ -314,7 +302,6 @@ end function eq__ !--------------------------------------------------------------------------------------------------- logical elemental function neq__(self,other) - implicit none class(quaternion), intent(in) :: self,other neq__ = .not. self%eq__(other) @@ -327,7 +314,6 @@ end function neq__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function pow_scal__(self,expon) - implicit none class(quaternion), intent(in) :: self real(pReal), intent(in) :: expon @@ -341,7 +327,6 @@ end function pow_scal__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function pow_quat__(self,expon) - implicit none class(quaternion), intent(in) :: self type(quaternion), intent(in) :: expon @@ -356,7 +341,6 @@ end function pow_quat__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function exp__(self) - implicit none class(quaternion), intent(in) :: self real(pReal) :: absImag @@ -376,7 +360,6 @@ end function exp__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function log__(self) - implicit none class(quaternion), intent(in) :: self real(pReal) :: absImag @@ -395,7 +378,6 @@ end function log__ !--------------------------------------------------------------------------------------------------- real(pReal) elemental function abs__(a) - implicit none class(quaternion), intent(in) :: a abs__ = norm2([a%w,a%x,a%y,a%z]) @@ -408,7 +390,6 @@ end function abs__ !--------------------------------------------------------------------------------------------------- real(pReal) elemental function dot_product__(a,b) - implicit none class(quaternion), intent(in) :: a,b dot_product__ = a%w*b%w + a%x*b%x + a%y*b%y + a%z*b%z @@ -421,7 +402,6 @@ end function dot_product__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function conjg__(a) - implicit none class(quaternion), intent(in) :: a conjg__ = quaternion([a%w, -a%x, -a%y, -a%z]) @@ -434,7 +414,6 @@ end function conjg__ !--------------------------------------------------------------------------------------------------- type(quaternion) elemental function quat_homomorphed(a) - implicit none class(quaternion), intent(in) :: a quat_homomorphed = quaternion(-[a%w,a%x,a%y,a%z]) From 1036c76ae083ccdcd3213fb7d9305d4863f61530 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 13 Apr 2019 00:46:27 +0200 Subject: [PATCH 49/97] to transpose already when constructing the interaction matrix --- src/lattice.f90 | 4557 ++++++++++++++-------------- src/plastic_disloUCLA.f90 | 10 +- src/plastic_dislotwin.f90 | 43 +- src/plastic_isotropic.f90 | 5 - src/plastic_kinematichardening.f90 | 10 +- src/plastic_none.f90 | 80 +- src/plastic_nonlocal.f90 | 10 - src/plastic_phenopowerlaw.f90 | 22 +- 8 files changed, 2334 insertions(+), 2403 deletions(-) diff --git a/src/lattice.f90 b/src/lattice.f90 index d11932c29..1a7508984 100644 --- a/src/lattice.f90 +++ b/src/lattice.f90 @@ -7,1288 +7,1278 @@ ! and cleavage as well as interaction among the various systems !-------------------------------------------------------------------------------------------------- module lattice - use prec, only: & - pReal - use future - - implicit none - private - + use prec, only: & + pReal + use future + + implicit none + private + ! BEGIN DEPRECATED - integer, parameter, public :: & - LATTICE_maxNcleavageFamily = 3 !< max # of transformation system families over lattice structures - - integer, allocatable, dimension(:,:), protected, public :: & - lattice_NcleavageSystem !< total # of transformation systems in each family - - real(pReal), allocatable, dimension(:,:,:,:,:), protected, public :: & - lattice_Scleavage !< Schmid matrices for cleavage systems + integer, parameter, public :: & + LATTICE_maxNcleavageFamily = 3 !< max # of transformation system families over lattice structures + + integer, allocatable, dimension(:,:), protected, public :: & + lattice_NcleavageSystem !< total # of transformation systems in each family + + real(pReal), allocatable, dimension(:,:,:,:,:), protected, public :: & + lattice_Scleavage !< Schmid matrices for cleavage systems ! END DEPRECATED !-------------------------------------------------------------------------------------------------- ! face centered cubic - integer, dimension(2), parameter, private :: & - LATTICE_FCC_NSLIPSYSTEM = [12, 6] !< # of slip systems per family for fcc - - integer, dimension(1), parameter, private :: & - LATTICE_FCC_NTWINSYSTEM = [12] !< # of twin systems per family for fcc - - integer, dimension(1), parameter, private :: & - LATTICE_FCC_NTRANSSYSTEM = [12] !< # of transformation systems per family for fcc - - integer, dimension(2), parameter, private :: & - LATTICE_FCC_NCLEAVAGESYSTEM = [3, 4] !< # of cleavage systems per family for fcc - - integer, parameter, private :: & - LATTICE_FCC_NSLIP = sum(LATTICE_FCC_NSLIPSYSTEM), & !< total # of slip systems for fcc - LATTICE_FCC_NTWIN = sum(LATTICE_FCC_NTWINSYSTEM), & !< total # of twin systems for fcc - LATTICE_FCC_NTRANS = sum(LATTICE_FCC_NTRANSSYSTEM), & !< total # of transformation systems for fcc - LATTICE_FCC_NCLEAVAGE = sum(LATTICE_FCC_NCLEAVAGESYSTEM) !< total # of cleavage systems for fcc - - real(pReal), dimension(3+3,LATTICE_FCC_NSLIP), parameter, private :: & - LATTICE_FCC_SYSTEMSLIP = reshape(real([& - ! Slip direction Plane normal ! SCHMID-BOAS notation - 0, 1,-1, 1, 1, 1, & ! B2 - -1, 0, 1, 1, 1, 1, & ! B4 - 1,-1, 0, 1, 1, 1, & ! B5 - 0,-1,-1, -1,-1, 1, & ! C1 - 1, 0, 1, -1,-1, 1, & ! C3 - -1, 1, 0, -1,-1, 1, & ! C5 - 0,-1, 1, 1,-1,-1, & ! A2 - -1, 0,-1, 1,-1,-1, & ! A3 - 1, 1, 0, 1,-1,-1, & ! A6 - 0, 1, 1, -1, 1,-1, & ! D1 - 1, 0,-1, -1, 1,-1, & ! D4 - -1,-1, 0, -1, 1,-1, & ! D6 - ! Slip system <110>{110} - 1, 1, 0, 1,-1, 0, & - 1,-1, 0, 1, 1, 0, & - 1, 0, 1, 1, 0,-1, & - 1, 0,-1, 1, 0, 1, & - 0, 1, 1, 0, 1,-1, & - 0, 1,-1, 0, 1, 1 & - ],pReal),shape(LATTICE_FCC_SYSTEMSLIP)) !< Slip system <110>{111} directions. Sorted according to Eisenlohr & Hantcherli - - character(len=*), dimension(2), parameter, private :: LATTICE_FCC_SLIPFAMILY_NAME = & - ['<0 1 -1>{1 1 1}', & - '<0 1 -1>{0 1 1}'] - - real(pReal), dimension(3+3,LATTICE_FCC_NTWIN), parameter, private :: & - LATTICE_FCC_SYSTEMTWIN = reshape(real( [& - -2, 1, 1, 1, 1, 1, & - 1,-2, 1, 1, 1, 1, & - 1, 1,-2, 1, 1, 1, & - 2,-1, 1, -1,-1, 1, & - -1, 2, 1, -1,-1, 1, & - -1,-1,-2, -1,-1, 1, & - -2,-1,-1, 1,-1,-1, & - 1, 2,-1, 1,-1,-1, & - 1,-1, 2, 1,-1,-1, & - 2, 1,-1, -1, 1,-1, & - -1,-2,-1, -1, 1,-1, & - -1, 1, 2, -1, 1,-1 & - ],pReal),shape(LATTICE_FCC_SYSTEMTWIN)) !< Twin system <112>{111} directions. Sorted according to Eisenlohr & Hantcherli - - character(len=*), dimension(1), parameter, private :: LATTICE_FCC_TWINFAMILY_NAME = & - ['<-2 1 1>{1 1 1}'] - - - integer, dimension(2,LATTICE_FCC_NTWIN), parameter, public :: & - LATTICE_FCC_TWINNUCLEATIONSLIPPAIR = reshape( [& - 2,3, & - 1,3, & - 1,2, & - 5,6, & - 4,6, & - 4,5, & - 8,9, & - 7,9, & - 7,8, & - 11,12, & - 10,12, & - 10,11 & - ],shape(LATTICE_FCC_TWINNUCLEATIONSLIPPAIR)) - - real(pReal), dimension(3+3,LATTICE_FCC_NCLEAVAGE), parameter, private :: & - LATTICE_FCC_SYSTEMCLEAVAGE = reshape(real([& - ! Cleavage direction Plane normal - 0, 1, 0, 1, 0, 0, & - 0, 0, 1, 0, 1, 0, & - 1, 0, 0, 0, 0, 1, & - 0, 1,-1, 1, 1, 1, & - 0,-1,-1, -1,-1, 1, & - -1, 0,-1, 1,-1,-1, & - 0, 1, 1, -1, 1,-1 & - ],pReal),shape(LATTICE_FCC_SYSTEMCLEAVAGE)) - + integer, dimension(2), parameter, private :: & + LATTICE_FCC_NSLIPSYSTEM = [12, 6] !< # of slip systems per family for fcc + + integer, dimension(1), parameter, private :: & + LATTICE_FCC_NTWINSYSTEM = [12] !< # of twin systems per family for fcc + + integer, dimension(1), parameter, private :: & + LATTICE_FCC_NTRANSSYSTEM = [12] !< # of transformation systems per family for fcc + + integer, dimension(2), parameter, private :: & + LATTICE_FCC_NCLEAVAGESYSTEM = [3, 4] !< # of cleavage systems per family for fcc + + integer, parameter, private :: & + LATTICE_FCC_NSLIP = sum(LATTICE_FCC_NSLIPSYSTEM), & !< total # of slip systems for fcc + LATTICE_FCC_NTWIN = sum(LATTICE_FCC_NTWINSYSTEM), & !< total # of twin systems for fcc + LATTICE_FCC_NTRANS = sum(LATTICE_FCC_NTRANSSYSTEM), & !< total # of transformation systems for fcc + LATTICE_FCC_NCLEAVAGE = sum(LATTICE_FCC_NCLEAVAGESYSTEM) !< total # of cleavage systems for fcc + + real(pReal), dimension(3+3,LATTICE_FCC_NSLIP), parameter, private :: & + LATTICE_FCC_SYSTEMSLIP = reshape(real([& + ! Slip direction Plane normal ! SCHMID-BOAS notation + 0, 1,-1, 1, 1, 1, & ! B2 + -1, 0, 1, 1, 1, 1, & ! B4 + 1,-1, 0, 1, 1, 1, & ! B5 + 0,-1,-1, -1,-1, 1, & ! C1 + 1, 0, 1, -1,-1, 1, & ! C3 + -1, 1, 0, -1,-1, 1, & ! C5 + 0,-1, 1, 1,-1,-1, & ! A2 + -1, 0,-1, 1,-1,-1, & ! A3 + 1, 1, 0, 1,-1,-1, & ! A6 + 0, 1, 1, -1, 1,-1, & ! D1 + 1, 0,-1, -1, 1,-1, & ! D4 + -1,-1, 0, -1, 1,-1, & ! D6 + ! Slip system <110>{110} + 1, 1, 0, 1,-1, 0, & + 1,-1, 0, 1, 1, 0, & + 1, 0, 1, 1, 0,-1, & + 1, 0,-1, 1, 0, 1, & + 0, 1, 1, 0, 1,-1, & + 0, 1,-1, 0, 1, 1 & + ],pReal),shape(LATTICE_FCC_SYSTEMSLIP)) !< Slip system <110>{111} directions. Sorted according to Eisenlohr & Hantcherli + + character(len=*), dimension(2), parameter, private :: LATTICE_FCC_SLIPFAMILY_NAME = & + ['<0 1 -1>{1 1 1}', & + '<0 1 -1>{0 1 1}'] + + real(pReal), dimension(3+3,LATTICE_FCC_NTWIN), parameter, private :: & + LATTICE_FCC_SYSTEMTWIN = reshape(real( [& + -2, 1, 1, 1, 1, 1, & + 1,-2, 1, 1, 1, 1, & + 1, 1,-2, 1, 1, 1, & + 2,-1, 1, -1,-1, 1, & + -1, 2, 1, -1,-1, 1, & + -1,-1,-2, -1,-1, 1, & + -2,-1,-1, 1,-1,-1, & + 1, 2,-1, 1,-1,-1, & + 1,-1, 2, 1,-1,-1, & + 2, 1,-1, -1, 1,-1, & + -1,-2,-1, -1, 1,-1, & + -1, 1, 2, -1, 1,-1 & + ],pReal),shape(LATTICE_FCC_SYSTEMTWIN)) !< Twin system <112>{111} directions. Sorted according to Eisenlohr & Hantcherli + + character(len=*), dimension(1), parameter, private :: LATTICE_FCC_TWINFAMILY_NAME = & + ['<-2 1 1>{1 1 1}'] + + + integer, dimension(2,LATTICE_FCC_NTWIN), parameter, public :: & + LATTICE_FCC_TWINNUCLEATIONSLIPPAIR = reshape( [& + 2,3, & + 1,3, & + 1,2, & + 5,6, & + 4,6, & + 4,5, & + 8,9, & + 7,9, & + 7,8, & + 11,12, & + 10,12, & + 10,11 & + ],shape(LATTICE_FCC_TWINNUCLEATIONSLIPPAIR)) + + real(pReal), dimension(3+3,LATTICE_FCC_NCLEAVAGE), parameter, private :: & + LATTICE_FCC_SYSTEMCLEAVAGE = reshape(real([& + ! Cleavage direction Plane normal + 0, 1, 0, 1, 0, 0, & + 0, 0, 1, 0, 1, 0, & + 1, 0, 0, 0, 0, 1, & + 0, 1,-1, 1, 1, 1, & + 0,-1,-1, -1,-1, 1, & + -1, 0,-1, 1,-1,-1, & + 0, 1, 1, -1, 1,-1 & + ],pReal),shape(LATTICE_FCC_SYSTEMCLEAVAGE)) + !-------------------------------------------------------------------------------------------------- ! body centered cubic - integer, dimension(2), parameter, private :: & - LATTICE_BCC_NSLIPSYSTEM = [12, 12] !< # of slip systems per family for bcc - - integer, dimension(1), parameter, private :: & - LATTICE_BCC_NTWINSYSTEM = [12] !< # of twin systems per family for bcc - - integer, dimension(2), parameter, private :: & - LATTICE_BCC_NCLEAVAGESYSTEM = [3, 6] !< # of cleavage systems per family for bcc - - integer, parameter, private :: & - LATTICE_BCC_NSLIP = sum(LATTICE_BCC_NSLIPSYSTEM), & !< total # of slip systems for bcc - LATTICE_BCC_NTWIN = sum(LATTICE_BCC_NTWINSYSTEM), & !< total # of twin systems for bcc - LATTICE_BCC_NCLEAVAGE = sum(LATTICE_BCC_NCLEAVAGESYSTEM) !< total # of cleavage systems for bcc - - real(pReal), dimension(3+3,LATTICE_BCC_NSLIP), parameter, private :: & - LATTICE_BCC_SYSTEMSLIP = reshape(real([& - ! Slip direction Plane normal - ! Slip system <111>{110} - 1,-1, 1, 0, 1, 1, & - -1,-1, 1, 0, 1, 1, & - 1, 1, 1, 0,-1, 1, & - -1, 1, 1, 0,-1, 1, & - -1, 1, 1, 1, 0, 1, & - -1,-1, 1, 1, 0, 1, & - 1, 1, 1, -1, 0, 1, & - 1,-1, 1, -1, 0, 1, & - -1, 1, 1, 1, 1, 0, & - -1, 1,-1, 1, 1, 0, & - 1, 1, 1, -1, 1, 0, & - 1, 1,-1, -1, 1, 0, & - ! Slip system <111>{112} - -1, 1, 1, 2, 1, 1, & - 1, 1, 1, -2, 1, 1, & - 1, 1,-1, 2,-1, 1, & - 1,-1, 1, 2, 1,-1, & - 1,-1, 1, 1, 2, 1, & - 1, 1,-1, -1, 2, 1, & - 1, 1, 1, 1,-2, 1, & - -1, 1, 1, 1, 2,-1, & - 1, 1,-1, 1, 1, 2, & - 1,-1, 1, -1, 1, 2, & - -1, 1, 1, 1,-1, 2, & - 1, 1, 1, 1, 1,-2 & - ],pReal),shape(LATTICE_BCC_SYSTEMSLIP)) - - character(len=*), dimension(2), parameter, private :: LATTICE_BCC_SLIPFAMILY_NAME = & - ['<1 -1 1>{0 1 1}', & - '<1 -1 1>{2 1 1}'] - - real(pReal), dimension(3+3,LATTICE_BCC_NTWIN), parameter, private :: & - LATTICE_BCC_SYSTEMTWIN = reshape(real([& - ! Twin system <111>{112} - -1, 1, 1, 2, 1, 1, & - 1, 1, 1, -2, 1, 1, & - 1, 1,-1, 2,-1, 1, & - 1,-1, 1, 2, 1,-1, & - 1,-1, 1, 1, 2, 1, & - 1, 1,-1, -1, 2, 1, & - 1, 1, 1, 1,-2, 1, & - -1, 1, 1, 1, 2,-1, & - 1, 1,-1, 1, 1, 2, & - 1,-1, 1, -1, 1, 2, & - -1, 1, 1, 1,-1, 2, & - 1, 1, 1, 1, 1,-2 & - ],pReal),shape(LATTICE_BCC_SYSTEMTWIN)) - - character(len=*), dimension(1), parameter, private :: LATTICE_BCC_TWINFAMILY_NAME = & - ['<1 1 1>{2 1 1}'] - - real(pReal), dimension(3+3,LATTICE_BCC_NCLEAVAGE), parameter, private :: & - LATTICE_BCC_SYSTEMCLEAVAGE = reshape(real([& - ! Cleavage direction Plane normal - 0, 1, 0, 1, 0, 0, & - 0, 0, 1, 0, 1, 0, & - 1, 0, 0, 0, 0, 1, & - 1,-1, 1, 0, 1, 1, & - 1, 1, 1, 0,-1, 1, & - -1, 1, 1, 1, 0, 1, & - 1, 1, 1, -1, 0, 1, & - -1, 1, 1, 1, 1, 0, & - 1, 1, 1, -1, 1, 0 & - ],pReal),shape(LATTICE_BCC_SYSTEMCLEAVAGE)) - + integer, dimension(2), parameter, private :: & + LATTICE_BCC_NSLIPSYSTEM = [12, 12] !< # of slip systems per family for bcc + + integer, dimension(1), parameter, private :: & + LATTICE_BCC_NTWINSYSTEM = [12] !< # of twin systems per family for bcc + + integer, dimension(2), parameter, private :: & + LATTICE_BCC_NCLEAVAGESYSTEM = [3, 6] !< # of cleavage systems per family for bcc + + integer, parameter, private :: & + LATTICE_BCC_NSLIP = sum(LATTICE_BCC_NSLIPSYSTEM), & !< total # of slip systems for bcc + LATTICE_BCC_NTWIN = sum(LATTICE_BCC_NTWINSYSTEM), & !< total # of twin systems for bcc + LATTICE_BCC_NCLEAVAGE = sum(LATTICE_BCC_NCLEAVAGESYSTEM) !< total # of cleavage systems for bcc + + real(pReal), dimension(3+3,LATTICE_BCC_NSLIP), parameter, private :: & + LATTICE_BCC_SYSTEMSLIP = reshape(real([& + ! Slip direction Plane normal + ! Slip system <111>{110} + 1,-1, 1, 0, 1, 1, & + -1,-1, 1, 0, 1, 1, & + 1, 1, 1, 0,-1, 1, & + -1, 1, 1, 0,-1, 1, & + -1, 1, 1, 1, 0, 1, & + -1,-1, 1, 1, 0, 1, & + 1, 1, 1, -1, 0, 1, & + 1,-1, 1, -1, 0, 1, & + -1, 1, 1, 1, 1, 0, & + -1, 1,-1, 1, 1, 0, & + 1, 1, 1, -1, 1, 0, & + 1, 1,-1, -1, 1, 0, & + ! Slip system <111>{112} + -1, 1, 1, 2, 1, 1, & + 1, 1, 1, -2, 1, 1, & + 1, 1,-1, 2,-1, 1, & + 1,-1, 1, 2, 1,-1, & + 1,-1, 1, 1, 2, 1, & + 1, 1,-1, -1, 2, 1, & + 1, 1, 1, 1,-2, 1, & + -1, 1, 1, 1, 2,-1, & + 1, 1,-1, 1, 1, 2, & + 1,-1, 1, -1, 1, 2, & + -1, 1, 1, 1,-1, 2, & + 1, 1, 1, 1, 1,-2 & + ],pReal),shape(LATTICE_BCC_SYSTEMSLIP)) + + character(len=*), dimension(2), parameter, private :: LATTICE_BCC_SLIPFAMILY_NAME = & + ['<1 -1 1>{0 1 1}', & + '<1 -1 1>{2 1 1}'] + + real(pReal), dimension(3+3,LATTICE_BCC_NTWIN), parameter, private :: & + LATTICE_BCC_SYSTEMTWIN = reshape(real([& + ! Twin system <111>{112} + -1, 1, 1, 2, 1, 1, & + 1, 1, 1, -2, 1, 1, & + 1, 1,-1, 2,-1, 1, & + 1,-1, 1, 2, 1,-1, & + 1,-1, 1, 1, 2, 1, & + 1, 1,-1, -1, 2, 1, & + 1, 1, 1, 1,-2, 1, & + -1, 1, 1, 1, 2,-1, & + 1, 1,-1, 1, 1, 2, & + 1,-1, 1, -1, 1, 2, & + -1, 1, 1, 1,-1, 2, & + 1, 1, 1, 1, 1,-2 & + ],pReal),shape(LATTICE_BCC_SYSTEMTWIN)) + + character(len=*), dimension(1), parameter, private :: LATTICE_BCC_TWINFAMILY_NAME = & + ['<1 1 1>{2 1 1}'] + + real(pReal), dimension(3+3,LATTICE_BCC_NCLEAVAGE), parameter, private :: & + LATTICE_BCC_SYSTEMCLEAVAGE = reshape(real([& + ! Cleavage direction Plane normal + 0, 1, 0, 1, 0, 0, & + 0, 0, 1, 0, 1, 0, & + 1, 0, 0, 0, 0, 1, & + 1,-1, 1, 0, 1, 1, & + 1, 1, 1, 0,-1, 1, & + -1, 1, 1, 1, 0, 1, & + 1, 1, 1, -1, 0, 1, & + -1, 1, 1, 1, 1, 0, & + 1, 1, 1, -1, 1, 0 & + ],pReal),shape(LATTICE_BCC_SYSTEMCLEAVAGE)) + !-------------------------------------------------------------------------------------------------- ! hexagonal - integer, dimension(6), parameter, private :: & - LATTICE_HEX_NSLIPSYSTEM = [3, 3, 3, 6, 12, 6] !< # of slip systems per family for hex - - integer, dimension(4), parameter, private :: & - LATTICE_HEX_NTWINSYSTEM = [6, 6, 6, 6] !< # of slip systems per family for hex - - integer, dimension(1), parameter, private :: & - LATTICE_HEX_NCLEAVAGESYSTEM = [3] !< # of cleavage systems per family for hex - - integer, parameter, private :: & - LATTICE_HEX_NSLIP = sum(LATTICE_HEX_NSLIPSYSTEM), & !< total # of slip systems for hex - LATTICE_HEX_NTWIN = sum(LATTICE_HEX_NTWINSYSTEM), & !< total # of twin systems for hex - LATTICE_HEX_NCLEAVAGE = sum(LATTICE_HEX_NCLEAVAGESYSTEM) !< total # of cleavage systems for hex - - real(pReal), dimension(4+4,LATTICE_HEX_NSLIP), parameter, private :: & - LATTICE_HEX_SYSTEMSLIP = reshape(real([& - ! Slip direction Plane normal - ! Basal systems <11.0>{00.1} (independent of c/a-ratio, Bravais notation (4 coordinate base)) - 2, -1, -1, 0, 0, 0, 0, 1, & - -1, 2, -1, 0, 0, 0, 0, 1, & - -1, -1, 2, 0, 0, 0, 0, 1, & - ! 1st type prismatic systems <11.0>{10.0} (independent of c/a-ratio) - 2, -1, -1, 0, 0, 1, -1, 0, & - -1, 2, -1, 0, -1, 0, 1, 0, & - -1, -1, 2, 0, 1, -1, 0, 0, & - ! 2nd type prismatic systems <10.0>{11.0} -- a slip; plane normals independent of c/a-ratio - 0, 1, -1, 0, 2, -1, -1, 0, & - -1, 0, 1, 0, -1, 2, -1, 0, & - 1, -1, 0, 0, -1, -1, 2, 0, & - ! 1st type 1st order pyramidal systems <11.0>{-11.1} -- plane normals depend on the c/a-ratio - 2, -1, -1, 0, 0, 1, -1, 1, & - -1, 2, -1, 0, -1, 0, 1, 1, & - -1, -1, 2, 0, 1, -1, 0, 1, & - 1, 1, -2, 0, -1, 1, 0, 1, & - -2, 1, 1, 0, 0, -1, 1, 1, & - 1, -2, 1, 0, 1, 0, -1, 1, & - ! pyramidal system: c+a slip <11.3>{-10.1} -- plane normals depend on the c/a-ratio - 2, -1, -1, 3, -1, 1, 0, 1, & - 1, -2, 1, 3, -1, 1, 0, 1, & - -1, -1, 2, 3, 1, 0, -1, 1, & - -2, 1, 1, 3, 1, 0, -1, 1, & - -1, 2, -1, 3, 0, -1, 1, 1, & - 1, 1, -2, 3, 0, -1, 1, 1, & - -2, 1, 1, 3, 1, -1, 0, 1, & - -1, 2, -1, 3, 1, -1, 0, 1, & - 1, 1, -2, 3, -1, 0, 1, 1, & - 2, -1, -1, 3, -1, 0, 1, 1, & - 1, -2, 1, 3, 0, 1, -1, 1, & - -1, -1, 2, 3, 0, 1, -1, 1, & - ! pyramidal system: c+a slip <11.3>{-1-1.2} -- as for hexagonal ice (Castelnau et al. 1996, similar to twin system found below) - 2, -1, -1, 3, -2, 1, 1, 2, & ! sorted according to similar twin system - -1, 2, -1, 3, 1, -2, 1, 2, & ! <11.3>{-1-1.2} shear = 2((c/a)^2-2)/(3 c/a) - -1, -1, 2, 3, 1, 1, -2, 2, & - -2, 1, 1, 3, 2, -1, -1, 2, & - 1, -2, 1, 3, -1, 2, -1, 2, & - 1, 1, -2, 3, -1, -1, 2, 2 & - ],pReal),shape(LATTICE_HEX_SYSTEMSLIP)) !< slip systems for hex sorted by A. Alankar & P. Eisenlohr - - character(len=*), dimension(6), parameter, private :: LATTICE_HEX_SLIPFAMILY_NAME = & - ['<1 1 . 1>{0 0 . 1} ', & - '<1 1 . 1>{1 0 . 0} ', & - '<1 0 . 0>{1 1 . 0} ', & - '<1 1 . 0>{-1 1 . 1} ', & - '<1 1 . 3>{-1 0 . 1} ', & - '<1 1 . 3>{-1 -1 . 2}'] - - real(pReal), dimension(4+4,LATTICE_HEX_NTWIN), parameter, private :: & - LATTICE_HEX_SYSTEMTWIN = reshape(real([& - ! Compression or Tension =f(twinning shear=f(c/a)) for each metal ! (according to Yoo 1981) - 1, -1, 0, 1, -1, 1, 0, 2, & ! <-10.1>{10.2} shear = (3-(c/a)^2)/(sqrt(3) c/a) - -1, 0, 1, 1, 1, 0, -1, 2, & - 0, 1, -1, 1, 0, -1, 1, 2, & - -1, 1, 0, 1, 1, -1, 0, 2, & - 1, 0, -1, 1, -1, 0, 1, 2, & - 0, -1, 1, 1, 0, 1, -1, 2, & + integer, dimension(6), parameter, private :: & + LATTICE_HEX_NSLIPSYSTEM = [3, 3, 3, 6, 12, 6] !< # of slip systems per family for hex + + integer, dimension(4), parameter, private :: & + LATTICE_HEX_NTWINSYSTEM = [6, 6, 6, 6] !< # of slip systems per family for hex + + integer, dimension(1), parameter, private :: & + LATTICE_HEX_NCLEAVAGESYSTEM = [3] !< # of cleavage systems per family for hex + + integer, parameter, private :: & + LATTICE_HEX_NSLIP = sum(LATTICE_HEX_NSLIPSYSTEM), & !< total # of slip systems for hex + LATTICE_HEX_NTWIN = sum(LATTICE_HEX_NTWINSYSTEM), & !< total # of twin systems for hex + LATTICE_HEX_NCLEAVAGE = sum(LATTICE_HEX_NCLEAVAGESYSTEM) !< total # of cleavage systems for hex + + real(pReal), dimension(4+4,LATTICE_HEX_NSLIP), parameter, private :: & + LATTICE_HEX_SYSTEMSLIP = reshape(real([& + ! Slip direction Plane normal + ! Basal systems <11.0>{00.1} (independent of c/a-ratio, Bravais notation (4 coordinate base)) + 2, -1, -1, 0, 0, 0, 0, 1, & + -1, 2, -1, 0, 0, 0, 0, 1, & + -1, -1, 2, 0, 0, 0, 0, 1, & + ! 1st type prismatic systems <11.0>{10.0} (independent of c/a-ratio) + 2, -1, -1, 0, 0, 1, -1, 0, & + -1, 2, -1, 0, -1, 0, 1, 0, & + -1, -1, 2, 0, 1, -1, 0, 0, & + ! 2nd type prismatic systems <10.0>{11.0} -- a slip; plane normals independent of c/a-ratio + 0, 1, -1, 0, 2, -1, -1, 0, & + -1, 0, 1, 0, -1, 2, -1, 0, & + 1, -1, 0, 0, -1, -1, 2, 0, & + ! 1st type 1st order pyramidal systems <11.0>{-11.1} -- plane normals depend on the c/a-ratio + 2, -1, -1, 0, 0, 1, -1, 1, & + -1, 2, -1, 0, -1, 0, 1, 1, & + -1, -1, 2, 0, 1, -1, 0, 1, & + 1, 1, -2, 0, -1, 1, 0, 1, & + -2, 1, 1, 0, 0, -1, 1, 1, & + 1, -2, 1, 0, 1, 0, -1, 1, & + ! pyramidal system: c+a slip <11.3>{-10.1} -- plane normals depend on the c/a-ratio + 2, -1, -1, 3, -1, 1, 0, 1, & + 1, -2, 1, 3, -1, 1, 0, 1, & + -1, -1, 2, 3, 1, 0, -1, 1, & + -2, 1, 1, 3, 1, 0, -1, 1, & + -1, 2, -1, 3, 0, -1, 1, 1, & + 1, 1, -2, 3, 0, -1, 1, 1, & + -2, 1, 1, 3, 1, -1, 0, 1, & + -1, 2, -1, 3, 1, -1, 0, 1, & + 1, 1, -2, 3, -1, 0, 1, 1, & + 2, -1, -1, 3, -1, 0, 1, 1, & + 1, -2, 1, 3, 0, 1, -1, 1, & + -1, -1, 2, 3, 0, 1, -1, 1, & + ! pyramidal system: c+a slip <11.3>{-1-1.2} -- as for hexagonal ice (Castelnau et al. 1996, similar to twin system found below) + 2, -1, -1, 3, -2, 1, 1, 2, & ! sorted according to similar twin system + -1, 2, -1, 3, 1, -2, 1, 2, & ! <11.3>{-1-1.2} shear = 2((c/a)^2-2)/(3 c/a) + -1, -1, 2, 3, 1, 1, -2, 2, & + -2, 1, 1, 3, 2, -1, -1, 2, & + 1, -2, 1, 3, -1, 2, -1, 2, & + 1, 1, -2, 3, -1, -1, 2, 2 & + ],pReal),shape(LATTICE_HEX_SYSTEMSLIP)) !< slip systems for hex sorted by A. Alankar & P. Eisenlohr + + character(len=*), dimension(6), parameter, private :: LATTICE_HEX_SLIPFAMILY_NAME = & + ['<1 1 . 1>{0 0 . 1} ', & + '<1 1 . 1>{1 0 . 0} ', & + '<1 0 . 0>{1 1 . 0} ', & + '<1 1 . 0>{-1 1 . 1} ', & + '<1 1 . 3>{-1 0 . 1} ', & + '<1 1 . 3>{-1 -1 . 2}'] + + real(pReal), dimension(4+4,LATTICE_HEX_NTWIN), parameter, private :: & + LATTICE_HEX_SYSTEMTWIN = reshape(real([& + ! Compression or Tension =f(twinning shear=f(c/a)) for each metal ! (according to Yoo 1981) + 1, -1, 0, 1, -1, 1, 0, 2, & ! <-10.1>{10.2} shear = (3-(c/a)^2)/(sqrt(3) c/a) + -1, 0, 1, 1, 1, 0, -1, 2, & + 0, 1, -1, 1, 0, -1, 1, 2, & + -1, 1, 0, 1, 1, -1, 0, 2, & + 1, 0, -1, 1, -1, 0, 1, 2, & + 0, -1, 1, 1, 0, 1, -1, 2, & ! - 2, -1, -1, 6, -2, 1, 1, 1, & ! <11.6>{-1-1.1} shear = 1/(c/a) - -1, 2, -1, 6, 1, -2, 1, 1, & - -1, -1, 2, 6, 1, 1, -2, 1, & - -2, 1, 1, 6, 2, -1, -1, 1, & - 1, -2, 1, 6, -1, 2, -1, 1, & - 1, 1, -2, 6, -1, -1, 2, 1, & + 2, -1, -1, 6, -2, 1, 1, 1, & ! <11.6>{-1-1.1} shear = 1/(c/a) + -1, 2, -1, 6, 1, -2, 1, 1, & + -1, -1, 2, 6, 1, 1, -2, 1, & + -2, 1, 1, 6, 2, -1, -1, 1, & + 1, -2, 1, 6, -1, 2, -1, 1, & + 1, 1, -2, 6, -1, -1, 2, 1, & ! - -1, 1, 0, -2, -1, 1, 0, 1, & !! <10.-2>{10.1} shear = (4(c/a)^2-9)/(4 sqrt(3) c/a) - 1, 0, -1, -2, 1, 0, -1, 1, & - 0, -1, 1, -2, 0, -1, 1, 1, & - 1, -1, 0, -2, 1, -1, 0, 1, & - -1, 0, 1, -2, -1, 0, 1, 1, & - 0, 1, -1, -2, 0, 1, -1, 1, & + -1, 1, 0, -2, -1, 1, 0, 1, & !! <10.-2>{10.1} shear = (4(c/a)^2-9)/(4 sqrt(3) c/a) + 1, 0, -1, -2, 1, 0, -1, 1, & + 0, -1, 1, -2, 0, -1, 1, 1, & + 1, -1, 0, -2, 1, -1, 0, 1, & + -1, 0, 1, -2, -1, 0, 1, 1, & + 0, 1, -1, -2, 0, 1, -1, 1, & ! - 2, -1, -1, -3, 2, -1, -1, 2, & ! <11.-3>{11.2} shear = 2((c/a)^2-2)/(3 c/a) - -1, 2, -1, -3, -1, 2, -1, 2, & - -1, -1, 2, -3, -1, -1, 2, 2, & - -2, 1, 1, -3, -2, 1, 1, 2, & - 1, -2, 1, -3, 1, -2, 1, 2, & - 1, 1, -2, -3, 1, 1, -2, 2 & - ],pReal),shape(LATTICE_HEX_SYSTEMTWIN)) !< twin systems for hex, order follows Prof. Tom Bieler's scheme - - character(len=*), dimension(4), parameter, private :: LATTICE_HEX_TWINFAMILY_NAME = & - ['<-1 0 . 1>{1 0 . 2} ', & - '<1 1 . 6>{-1 -1 . 1}', & - '<1 0 . -2>{1 0 . 1} ', & - '<1 1 . -3>{1 1 . 2} '] - - real(pReal), dimension(4+4,LATTICE_HEX_NCLEAVAGE), parameter, private :: & - LATTICE_HEX_SYSTEMCLEAVAGE = reshape(real([& - ! Cleavage direction Plane normal - 2,-1,-1, 0, 0, 0, 0, 1, & - 0, 0, 0, 1, 2,-1,-1, 0, & - 0, 0, 0, 1, 0, 1,-1, 0 & - ],pReal),shape(LATTICE_HEX_SYSTEMCLEAVAGE)) - - + 2, -1, -1, -3, 2, -1, -1, 2, & ! <11.-3>{11.2} shear = 2((c/a)^2-2)/(3 c/a) + -1, 2, -1, -3, -1, 2, -1, 2, & + -1, -1, 2, -3, -1, -1, 2, 2, & + -2, 1, 1, -3, -2, 1, 1, 2, & + 1, -2, 1, -3, 1, -2, 1, 2, & + 1, 1, -2, -3, 1, 1, -2, 2 & + ],pReal),shape(LATTICE_HEX_SYSTEMTWIN)) !< twin systems for hex, order follows Prof. Tom Bieler's scheme + + character(len=*), dimension(4), parameter, private :: LATTICE_HEX_TWINFAMILY_NAME = & + ['<-1 0 . 1>{1 0 . 2} ', & + '<1 1 . 6>{-1 -1 . 1}', & + '<1 0 . -2>{1 0 . 1} ', & + '<1 1 . -3>{1 1 . 2} '] + + real(pReal), dimension(4+4,LATTICE_HEX_NCLEAVAGE), parameter, private :: & + LATTICE_HEX_SYSTEMCLEAVAGE = reshape(real([& + ! Cleavage direction Plane normal + 2,-1,-1, 0, 0, 0, 0, 1, & + 0, 0, 0, 1, 2,-1,-1, 0, & + 0, 0, 0, 1, 0, 1,-1, 0 & + ],pReal),shape(LATTICE_HEX_SYSTEMCLEAVAGE)) + + !-------------------------------------------------------------------------------------------------- ! body centered tetragonal - integer, dimension(13), parameter, private :: & - LATTICE_BCT_NSLIPSYSTEM = [2, 2, 2, 4, 2, 4, 2, 2, 4, 8, 4, 8, 8 ] !< # of slip systems per family for bct (Sn) Bieler J. Electr Mater 2009 - - integer, parameter, private :: & - LATTICE_BCT_NSLIP = sum(LATTICE_BCT_NSLIPSYSTEM) !< total # of slip systems for bct - - real(pReal), dimension(3+3,LATTICE_BCT_NSLIP), parameter, private :: & - LATTICE_BCT_SYSTEMSLIP = reshape(real([& - ! Slip direction Plane normal - ! Slip family 1 {100)<001] (Bravais notation {hkl) @brief Module initialization !-------------------------------------------------------------------------------------------------- subroutine lattice_init - use IO, only: & - IO_error - use config, only: & - config_phase - - implicit none - integer :: Nphases - character(len=65536) :: & - tag = '' - integer :: i,p - real(pReal), dimension(:), allocatable :: & - temp, & - CoverA !< c/a ratio for low symmetry type lattice - - write(6,'(/,a)') ' <<<+- lattice init -+>>>' - - Nphases = size(config_phase) - - allocate(lattice_structure(Nphases),source = LATTICE_undefined_ID) - allocate(trans_lattice_structure(Nphases),source = LATTICE_undefined_ID) - allocate(lattice_C66(6,6,Nphases), source=0.0_pReal) - allocate(lattice_C3333(3,3,3,3,Nphases), source=0.0_pReal) + use IO, only: & + IO_error + use config, only: & + config_phase + + integer :: Nphases + character(len=65536) :: & + tag = '' + integer :: i,p + real(pReal), dimension(:), allocatable :: & + temp, & + CoverA !< c/a ratio for low symmetry type lattice + + write(6,'(/,a)') ' <<<+- lattice init -+>>>' + + Nphases = size(config_phase) + + allocate(lattice_structure(Nphases),source = LATTICE_undefined_ID) + allocate(trans_lattice_structure(Nphases),source = LATTICE_undefined_ID) + allocate(lattice_C66(6,6,Nphases), source=0.0_pReal) + allocate(lattice_C3333(3,3,3,3,Nphases), source=0.0_pReal) + + allocate(lattice_thermalExpansion33 (3,3,3,Nphases), source=0.0_pReal) ! constant, linear, quadratic coefficients + allocate(lattice_thermalConductivity33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_damageDiffusion33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_damageMobility ( Nphases), source=0.0_pReal) + allocate(lattice_massDensity ( Nphases), source=0.0_pReal) + allocate(lattice_specificHeat ( Nphases), source=0.0_pReal) + allocate(lattice_referenceTemperature ( Nphases), source=300.0_pReal) + + allocate(lattice_mu(Nphases), source=0.0_pReal) + allocate(lattice_nu(Nphases), source=0.0_pReal) + + + allocate(lattice_Scleavage(3,3,3,lattice_maxNcleavage,Nphases),source=0.0_pReal) + allocate(lattice_NcleavageSystem(lattice_maxNcleavageFamily,Nphases),source=0) + + allocate(CoverA(Nphases),source=0.0_pReal) + + do p = 1, size(config_phase) + tag = config_phase(p)%getString('lattice_structure') + select case(trim(tag(1:3))) + case('iso') + lattice_structure(p) = LATTICE_iso_ID + case('fcc') + lattice_structure(p) = LATTICE_fcc_ID + case('bcc') + lattice_structure(p) = LATTICE_bcc_ID + case('hex') + lattice_structure(p) = LATTICE_hex_ID + case('bct') + lattice_structure(p) = LATTICE_bct_ID + case('ort') + lattice_structure(p) = LATTICE_ort_ID + end select + + tag = 'undefined' + tag = config_phase(p)%getString('trans_lattice_structure',defaultVal=tag) + select case(trim(tag)) + case('bcc') + trans_lattice_structure(p) = LATTICE_bcc_ID + case('hex','hexagonal') + trans_lattice_structure(p) = LATTICE_hex_ID + end select + + lattice_C66(1,1,p) = config_phase(p)%getFloat('c11',defaultVal=0.0_pReal) + lattice_C66(1,2,p) = config_phase(p)%getFloat('c12',defaultVal=0.0_pReal) + lattice_C66(1,3,p) = config_phase(p)%getFloat('c13',defaultVal=0.0_pReal) + lattice_C66(2,2,p) = config_phase(p)%getFloat('c22',defaultVal=0.0_pReal) + lattice_C66(2,3,p) = config_phase(p)%getFloat('c23',defaultVal=0.0_pReal) + lattice_C66(3,3,p) = config_phase(p)%getFloat('c33',defaultVal=0.0_pReal) + lattice_C66(4,4,p) = config_phase(p)%getFloat('c44',defaultVal=0.0_pReal) + lattice_C66(5,5,p) = config_phase(p)%getFloat('c55',defaultVal=0.0_pReal) + lattice_C66(6,6,p) = config_phase(p)%getFloat('c66',defaultVal=0.0_pReal) + + + CoverA(p) = config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal) + + lattice_thermalConductivity33(1,1,p) = config_phase(p)%getFloat('thermal_conductivity11',defaultVal=0.0_pReal) + lattice_thermalConductivity33(2,2,p) = config_phase(p)%getFloat('thermal_conductivity22',defaultVal=0.0_pReal) + lattice_thermalConductivity33(3,3,p) = config_phase(p)%getFloat('thermal_conductivity33',defaultVal=0.0_pReal) + + temp = config_phase(p)%getFloats('thermal_expansion11',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) + lattice_thermalExpansion33(1,1,1:size(temp),p) = temp + temp = config_phase(p)%getFloats('thermal_expansion22',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) + lattice_thermalExpansion33(2,2,1:size(temp),p) = temp + temp = config_phase(p)%getFloats('thermal_expansion33',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) + lattice_thermalExpansion33(3,3,1:size(temp),p) = temp + + lattice_specificHeat(p) = config_phase(p)%getFloat( 'specific_heat',defaultVal=0.0_pReal) + lattice_massDensity(p) = config_phase(p)%getFloat( 'mass_density',defaultVal=0.0_pReal) + lattice_referenceTemperature(p) = config_phase(p)%getFloat( 'reference_temperature',defaultVal=0.0_pReal) + lattice_DamageDiffusion33(1,1,p) = config_phase(p)%getFloat( 'damage_diffusion11',defaultVal=0.0_pReal) + lattice_DamageDiffusion33(2,2,p) = config_phase(p)%getFloat( 'damage_diffusion22',defaultVal=0.0_pReal) + lattice_DamageDiffusion33(3,3,p) = config_phase(p)%getFloat( 'damage_diffusion33',defaultVal=0.0_pReal) + lattice_DamageMobility(p) = config_phase(p)%getFloat( 'damage_mobility',defaultVal=0.0_pReal) + enddo + + do i = 1,Nphases + if ((CoverA(i) < 1.0_pReal .or. CoverA(i) > 2.0_pReal) & + .and. lattice_structure(i) == LATTICE_hex_ID) call IO_error(131,el=i) ! checking physical significance of c/a + if ((CoverA(i) > 2.0_pReal) & + .and. lattice_structure(i) == LATTICE_bct_ID) call IO_error(131,el=i) ! checking physical significance of c/a + call lattice_initializeStructure(i, CoverA(i)) + enddo - allocate(lattice_thermalExpansion33 (3,3,3,Nphases), source=0.0_pReal) ! constant, linear, quadratic coefficients - allocate(lattice_thermalConductivity33 (3,3,Nphases), source=0.0_pReal) - allocate(lattice_damageDiffusion33 (3,3,Nphases), source=0.0_pReal) - allocate(lattice_damageMobility ( Nphases), source=0.0_pReal) - allocate(lattice_massDensity ( Nphases), source=0.0_pReal) - allocate(lattice_specificHeat ( Nphases), source=0.0_pReal) - allocate(lattice_referenceTemperature ( Nphases), source=300.0_pReal) - - allocate(lattice_mu(Nphases), source=0.0_pReal) - allocate(lattice_nu(Nphases), source=0.0_pReal) - - - allocate(lattice_Scleavage(3,3,3,lattice_maxNcleavage,Nphases),source=0.0_pReal) - allocate(lattice_NcleavageSystem(lattice_maxNcleavageFamily,Nphases),source=0) - - allocate(CoverA(Nphases),source=0.0_pReal) - - do p = 1, size(config_phase) - tag = config_phase(p)%getString('lattice_structure') - select case(trim(tag(1:3))) - case('iso') - lattice_structure(p) = LATTICE_iso_ID - case('fcc') - lattice_structure(p) = LATTICE_fcc_ID - case('bcc') - lattice_structure(p) = LATTICE_bcc_ID - case('hex') - lattice_structure(p) = LATTICE_hex_ID - case('bct') - lattice_structure(p) = LATTICE_bct_ID - case('ort') - lattice_structure(p) = LATTICE_ort_ID - end select - - tag = 'undefined' - tag = config_phase(p)%getString('trans_lattice_structure',defaultVal=tag) - select case(trim(tag)) - case('bcc') - trans_lattice_structure(p) = LATTICE_bcc_ID - case('hex','hexagonal') - trans_lattice_structure(p) = LATTICE_hex_ID - end select - - lattice_C66(1,1,p) = config_phase(p)%getFloat('c11',defaultVal=0.0_pReal) - lattice_C66(1,2,p) = config_phase(p)%getFloat('c12',defaultVal=0.0_pReal) - lattice_C66(1,3,p) = config_phase(p)%getFloat('c13',defaultVal=0.0_pReal) - lattice_C66(2,2,p) = config_phase(p)%getFloat('c22',defaultVal=0.0_pReal) - lattice_C66(2,3,p) = config_phase(p)%getFloat('c23',defaultVal=0.0_pReal) - lattice_C66(3,3,p) = config_phase(p)%getFloat('c33',defaultVal=0.0_pReal) - lattice_C66(4,4,p) = config_phase(p)%getFloat('c44',defaultVal=0.0_pReal) - lattice_C66(5,5,p) = config_phase(p)%getFloat('c55',defaultVal=0.0_pReal) - lattice_C66(6,6,p) = config_phase(p)%getFloat('c66',defaultVal=0.0_pReal) - - - CoverA(p) = config_phase(p)%getFloat('c/a',defaultVal=0.0_pReal) - - lattice_thermalConductivity33(1,1,p) = config_phase(p)%getFloat('thermal_conductivity11',defaultVal=0.0_pReal) - lattice_thermalConductivity33(2,2,p) = config_phase(p)%getFloat('thermal_conductivity22',defaultVal=0.0_pReal) - lattice_thermalConductivity33(3,3,p) = config_phase(p)%getFloat('thermal_conductivity33',defaultVal=0.0_pReal) - - temp = config_phase(p)%getFloats('thermal_expansion11',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) - lattice_thermalExpansion33(1,1,1:size(temp),p) = temp - temp = config_phase(p)%getFloats('thermal_expansion22',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) - lattice_thermalExpansion33(2,2,1:size(temp),p) = temp - temp = config_phase(p)%getFloats('thermal_expansion33',defaultVal=[0.0_pReal]) ! read up to three parameters (constant, linear, quadratic with T) - lattice_thermalExpansion33(3,3,1:size(temp),p) = temp - - lattice_specificHeat(p) = config_phase(p)%getFloat( 'specific_heat',defaultVal=0.0_pReal) - lattice_massDensity(p) = config_phase(p)%getFloat( 'mass_density',defaultVal=0.0_pReal) - lattice_referenceTemperature(p) = config_phase(p)%getFloat( 'reference_temperature',defaultVal=0.0_pReal) - lattice_DamageDiffusion33(1,1,p) = config_phase(p)%getFloat( 'damage_diffusion11',defaultVal=0.0_pReal) - lattice_DamageDiffusion33(2,2,p) = config_phase(p)%getFloat( 'damage_diffusion22',defaultVal=0.0_pReal) - lattice_DamageDiffusion33(3,3,p) = config_phase(p)%getFloat( 'damage_diffusion33',defaultVal=0.0_pReal) - lattice_DamageMobility(p) = config_phase(p)%getFloat( 'damage_mobility',defaultVal=0.0_pReal) - enddo - - do i = 1,Nphases - if ((CoverA(i) < 1.0_pReal .or. CoverA(i) > 2.0_pReal) & - .and. lattice_structure(i) == LATTICE_hex_ID) call IO_error(131,el=i) ! checking physical significance of c/a - if ((CoverA(i) > 2.0_pReal) & - .and. lattice_structure(i) == LATTICE_bct_ID) call IO_error(131,el=i) ! checking physical significance of c/a - call lattice_initializeStructure(i, CoverA(i)) - enddo - end subroutine lattice_init - - + + !-------------------------------------------------------------------------------------------------- !> @brief !!!!!!!DEPRECTATED!!!!!! !-------------------------------------------------------------------------------------------------- subroutine lattice_initializeStructure(myPhase,CoverA) - use prec, only: & - tol_math_check - use math, only: & - math_sym3333to66, & - math_Voigt66to3333, & - math_cross - use IO, only: & - IO_error - - implicit none - integer, intent(in) :: myPhase - real(pReal), intent(in) :: & - CoverA - - integer :: & - i, & - myNcleavage - - lattice_C66(1:6,1:6,myPhase) = lattice_symmetrizeC66(lattice_structure(myPhase),& - lattice_C66(1:6,1:6,myPhase)) - - lattice_mu(myPhase) = 0.2_pReal *( lattice_C66(1,1,myPhase) & - - lattice_C66(1,2,myPhase) & - + 3.0_pReal*lattice_C66(4,4,myPhase)) ! (C11iso-C12iso)/2 with C11iso=(3*C11+2*C12+4*C44)/5 and C12iso=(C11+4*C12-2*C44)/5 - lattice_nu(myPhase) = ( lattice_C66(1,1,myPhase) & - + 4.0_pReal*lattice_C66(1,2,myPhase) & - - 2.0_pReal*lattice_C66(4,4,myPhase)) & - /( 4.0_pReal*lattice_C66(1,1,myPhase) & - + 6.0_pReal*lattice_C66(1,2,myPhase) & - + 2.0_pReal*lattice_C66(4,4,myPhase))! C12iso/(C11iso+C12iso) with C11iso=(3*C11+2*C12+4*C44)/5 and C12iso=(C11+4*C12-2*C44)/5 - lattice_C3333(1:3,1:3,1:3,1:3,myPhase) = math_Voigt66to3333(lattice_C66(1:6,1:6,myPhase)) ! Literature data is Voigt - lattice_C66(1:6,1:6,myPhase) = math_sym3333to66(lattice_C3333(1:3,1:3,1:3,1:3,myPhase)) ! DAMASK uses Mandel-weighting - do i = 1, 6 - if (abs(lattice_C66(i,i,myPhase)) @brief Symmetrizes stiffness matrix according to lattice type !> @details J. A. Rayne and B. S. Chandrasekhar Phys. Rev. 120, 1658 Erratum Phys. Rev. 122, 1962 !-------------------------------------------------------------------------------------------------- pure function lattice_symmetrizeC66(struct,C66) - - implicit none - integer(kind(LATTICE_undefined_ID)), intent(in) :: struct - real(pReal), dimension(6,6), intent(in) :: C66 - real(pReal), dimension(6,6) :: lattice_symmetrizeC66 - integer :: j,k - - lattice_symmetrizeC66 = 0.0_pReal - - select case(struct) - case (LATTICE_iso_ID) - forall(k=1:3) - forall(j=1:3) lattice_symmetrizeC66(k,j) = C66(1,2) - lattice_symmetrizeC66(k,k) = C66(1,1) - lattice_symmetrizeC66(k+3,k+3) = 0.5_pReal*(C66(1,1)-C66(1,2)) - end forall - case (LATTICE_fcc_ID,LATTICE_bcc_ID) - forall(k=1:3) - forall(j=1:3) lattice_symmetrizeC66(k,j) = C66(1,2) - lattice_symmetrizeC66(k,k) = C66(1,1) - lattice_symmetrizeC66(k+3,k+3) = C66(4,4) - end forall - case (LATTICE_hex_ID) - lattice_symmetrizeC66(1,1) = C66(1,1) - lattice_symmetrizeC66(2,2) = C66(1,1) - lattice_symmetrizeC66(3,3) = C66(3,3) - lattice_symmetrizeC66(1,2) = C66(1,2) - lattice_symmetrizeC66(2,1) = C66(1,2) - lattice_symmetrizeC66(1,3) = C66(1,3) - lattice_symmetrizeC66(3,1) = C66(1,3) - lattice_symmetrizeC66(2,3) = C66(1,3) - lattice_symmetrizeC66(3,2) = C66(1,3) - lattice_symmetrizeC66(4,4) = C66(4,4) - lattice_symmetrizeC66(5,5) = C66(4,4) - lattice_symmetrizeC66(6,6) = 0.5_pReal*(C66(1,1)-C66(1,2)) - case (LATTICE_ort_ID) - lattice_symmetrizeC66(1,1) = C66(1,1) - lattice_symmetrizeC66(2,2) = C66(2,2) - lattice_symmetrizeC66(3,3) = C66(3,3) - lattice_symmetrizeC66(1,2) = C66(1,2) - lattice_symmetrizeC66(2,1) = C66(1,2) - lattice_symmetrizeC66(1,3) = C66(1,3) - lattice_symmetrizeC66(3,1) = C66(1,3) - lattice_symmetrizeC66(2,3) = C66(2,3) - lattice_symmetrizeC66(3,2) = C66(2,3) - lattice_symmetrizeC66(4,4) = C66(4,4) - lattice_symmetrizeC66(5,5) = C66(5,5) - lattice_symmetrizeC66(6,6) = C66(6,6) - case (LATTICE_bct_ID) - lattice_symmetrizeC66(1,1) = C66(1,1) - lattice_symmetrizeC66(2,2) = C66(1,1) - lattice_symmetrizeC66(3,3) = C66(3,3) - lattice_symmetrizeC66(1,2) = C66(1,2) - lattice_symmetrizeC66(2,1) = C66(1,2) - lattice_symmetrizeC66(1,3) = C66(1,3) - lattice_symmetrizeC66(3,1) = C66(1,3) - lattice_symmetrizeC66(2,3) = C66(1,3) - lattice_symmetrizeC66(3,2) = C66(1,3) - lattice_symmetrizeC66(4,4) = C66(4,4) - lattice_symmetrizeC66(5,5) = C66(4,4) - lattice_symmetrizeC66(6,6) = C66(6,6) - case default - lattice_symmetrizeC66 = C66 - end select - - end function lattice_symmetrizeC66 - - + + integer(kind(LATTICE_undefined_ID)), intent(in) :: struct + real(pReal), dimension(6,6), intent(in) :: C66 + real(pReal), dimension(6,6) :: lattice_symmetrizeC66 + integer :: j,k + + lattice_symmetrizeC66 = 0.0_pReal + + select case(struct) + case (LATTICE_iso_ID) + forall(k=1:3) + forall(j=1:3) lattice_symmetrizeC66(k,j) = C66(1,2) + lattice_symmetrizeC66(k,k) = C66(1,1) + lattice_symmetrizeC66(k+3,k+3) = 0.5_pReal*(C66(1,1)-C66(1,2)) + end forall + case (LATTICE_fcc_ID,LATTICE_bcc_ID) + forall(k=1:3) + forall(j=1:3) lattice_symmetrizeC66(k,j) = C66(1,2) + lattice_symmetrizeC66(k,k) = C66(1,1) + lattice_symmetrizeC66(k+3,k+3) = C66(4,4) + end forall + case (LATTICE_hex_ID) + lattice_symmetrizeC66(1,1) = C66(1,1) + lattice_symmetrizeC66(2,2) = C66(1,1) + lattice_symmetrizeC66(3,3) = C66(3,3) + lattice_symmetrizeC66(1,2) = C66(1,2) + lattice_symmetrizeC66(2,1) = C66(1,2) + lattice_symmetrizeC66(1,3) = C66(1,3) + lattice_symmetrizeC66(3,1) = C66(1,3) + lattice_symmetrizeC66(2,3) = C66(1,3) + lattice_symmetrizeC66(3,2) = C66(1,3) + lattice_symmetrizeC66(4,4) = C66(4,4) + lattice_symmetrizeC66(5,5) = C66(4,4) + lattice_symmetrizeC66(6,6) = 0.5_pReal*(C66(1,1)-C66(1,2)) + case (LATTICE_ort_ID) + lattice_symmetrizeC66(1,1) = C66(1,1) + lattice_symmetrizeC66(2,2) = C66(2,2) + lattice_symmetrizeC66(3,3) = C66(3,3) + lattice_symmetrizeC66(1,2) = C66(1,2) + lattice_symmetrizeC66(2,1) = C66(1,2) + lattice_symmetrizeC66(1,3) = C66(1,3) + lattice_symmetrizeC66(3,1) = C66(1,3) + lattice_symmetrizeC66(2,3) = C66(2,3) + lattice_symmetrizeC66(3,2) = C66(2,3) + lattice_symmetrizeC66(4,4) = C66(4,4) + lattice_symmetrizeC66(5,5) = C66(5,5) + lattice_symmetrizeC66(6,6) = C66(6,6) + case (LATTICE_bct_ID) + lattice_symmetrizeC66(1,1) = C66(1,1) + lattice_symmetrizeC66(2,2) = C66(1,1) + lattice_symmetrizeC66(3,3) = C66(3,3) + lattice_symmetrizeC66(1,2) = C66(1,2) + lattice_symmetrizeC66(2,1) = C66(1,2) + lattice_symmetrizeC66(1,3) = C66(1,3) + lattice_symmetrizeC66(3,1) = C66(1,3) + lattice_symmetrizeC66(2,3) = C66(1,3) + lattice_symmetrizeC66(3,2) = C66(1,3) + lattice_symmetrizeC66(4,4) = C66(4,4) + lattice_symmetrizeC66(5,5) = C66(4,4) + lattice_symmetrizeC66(6,6) = C66(6,6) + case default + lattice_symmetrizeC66 = C66 + end select + +end function lattice_symmetrizeC66 + + !-------------------------------------------------------------------------------------------------- !> @brief Symmetrizes 2nd order tensor according to lattice type !-------------------------------------------------------------------------------------------------- pure function lattice_symmetrize33(struct,T33) - - implicit none - integer(kind(LATTICE_undefined_ID)), intent(in) :: struct - real(pReal), dimension(3,3), intent(in) :: T33 - real(pReal), dimension(3,3) :: lattice_symmetrize33 - integer :: k - - lattice_symmetrize33 = 0.0_pReal - - select case(struct) - case (LATTICE_iso_ID,LATTICE_fcc_ID,LATTICE_bcc_ID) - forall(k=1:3) lattice_symmetrize33(k,k) = T33(1,1) - case (LATTICE_hex_ID) - lattice_symmetrize33(1,1) = T33(1,1) - lattice_symmetrize33(2,2) = T33(1,1) - lattice_symmetrize33(3,3) = T33(3,3) - case (LATTICE_ort_ID,lattice_bct_ID) - lattice_symmetrize33(1,1) = T33(1,1) - lattice_symmetrize33(2,2) = T33(2,2) - lattice_symmetrize33(3,3) = T33(3,3) - case default - lattice_symmetrize33 = T33 - end select - - end function lattice_symmetrize33 - - + + integer(kind(LATTICE_undefined_ID)), intent(in) :: struct + real(pReal), dimension(3,3), intent(in) :: T33 + real(pReal), dimension(3,3) :: lattice_symmetrize33 + integer :: k + + lattice_symmetrize33 = 0.0_pReal + + select case(struct) + case (LATTICE_iso_ID,LATTICE_fcc_ID,LATTICE_bcc_ID) + forall(k=1:3) lattice_symmetrize33(k,k) = T33(1,1) + case (LATTICE_hex_ID) + lattice_symmetrize33(1,1) = T33(1,1) + lattice_symmetrize33(2,2) = T33(1,1) + lattice_symmetrize33(3,3) = T33(3,3) + case (LATTICE_ort_ID,lattice_bct_ID) + lattice_symmetrize33(1,1) = T33(1,1) + lattice_symmetrize33(2,2) = T33(2,2) + lattice_symmetrize33(3,3) = T33(3,3) + case default + lattice_symmetrize33 = T33 + end select + +end function lattice_symmetrize33 + + !-------------------------------------------------------------------------------------------------- !> @brief figures whether unit quat falls into stereographic standard triangle !-------------------------------------------------------------------------------------------------- logical pure function lattice_qInSST(Q, struct) - use, intrinsic :: & - IEEE_arithmetic - use math, only: & - math_qToRodrig - - implicit none - real(pReal), dimension(4), intent(in) :: Q ! orientation - integer(kind(LATTICE_undefined_ID)), intent(in) :: struct ! lattice structure - real(pReal), dimension(3) :: Rodrig ! Rodrigues vector of Q - - Rodrig = math_qToRodrig(Q) - if (any(IEEE_is_NaN(Rodrig))) then - lattice_qInSST = .false. - else - select case (struct) - case (LATTICE_bcc_ID,LATTICE_fcc_ID) - lattice_qInSST = Rodrig(1) > Rodrig(2) .and. & - Rodrig(2) > Rodrig(3) .and. & - Rodrig(3) > 0.0_pReal - case (LATTICE_hex_ID) - lattice_qInSST = Rodrig(1) > sqrt(3.0_pReal)*Rodrig(2) .and. & - Rodrig(2) > 0.0_pReal .and. & - Rodrig(3) > 0.0_pReal - case default - lattice_qInSST = .true. - end select - endif - + use, intrinsic :: & + IEEE_arithmetic + use math, only: & + math_qToRodrig + + real(pReal), dimension(4), intent(in) :: Q ! orientation + integer(kind(LATTICE_undefined_ID)), intent(in) :: struct ! lattice structure + real(pReal), dimension(3) :: Rodrig ! Rodrigues vector of Q + + Rodrig = math_qToRodrig(Q) + if (any(IEEE_is_NaN(Rodrig))) then + lattice_qInSST = .false. + else + select case (struct) + case (LATTICE_bcc_ID,LATTICE_fcc_ID) + lattice_qInSST = Rodrig(1) > Rodrig(2) .and. & + Rodrig(2) > Rodrig(3) .and. & + Rodrig(3) > 0.0_pReal + case (LATTICE_hex_ID) + lattice_qInSST = Rodrig(1) > sqrt(3.0_pReal)*Rodrig(2) .and. & + Rodrig(2) > 0.0_pReal .and. & + Rodrig(3) > 0.0_pReal + case default + lattice_qInSST = .true. + end select + endif + end function lattice_qInSST - - + + !-------------------------------------------------------------------------------------------------- !> @brief calculates the disorientation for 2 unit quaternions !-------------------------------------------------------------------------------------------------- pure function lattice_qDisorientation(Q1, Q2, struct) - use prec, only: & - tol_math_check - use math, only: & - math_qMul, & - math_qConj - - implicit none - real(pReal), dimension(4) :: lattice_qDisorientation - real(pReal), dimension(4), intent(in) :: & - Q1, & ! 1st orientation - Q2 ! 2nd orientation - integer(kind(LATTICE_undefined_ID)), optional, intent(in) :: & ! if given, symmetries between the two orientation will be considered - struct - - real(pReal), dimension(4) :: dQ,dQsymA,mis - integer :: i,j,k,s,symmetry - integer(kind(LATTICE_undefined_ID)) :: myStruct - - integer, dimension(2), parameter :: & - NsymOperations = [24,12] - -real(pReal), dimension(4,36), parameter :: & - symOperations = reshape([& - 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! cubic symmetry operations - 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), & ! 2-fold symmetry - 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & ! 3-fold symmetry - -0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & - 0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & - -0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & - 0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & - -0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & - 0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & - -0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & - 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & ! 4-fold symmetry - 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & - -1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & - 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & - -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & - 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & - 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal, & - -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & -! - 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! hexagonal symmetry operations - 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & ! 2-fold symmetry - 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & - 0.0_pReal, 0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & - 0.0_pReal, -0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & - 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & - 0.0_pReal, -2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & - 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & ! 6-fold symmetry - -2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & - 0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & - -0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & - 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal & - ],[4,36]) !< Symmetry operations as quaternions 24 for cubic, 12 for hexagonal = 36 - + use prec, only: & + tol_math_check + use math, only: & + math_qMul, & + math_qConj + + real(pReal), dimension(4) :: lattice_qDisorientation + real(pReal), dimension(4), intent(in) :: & + Q1, & !< 1st orientation + Q2 !< 2nd orientation + integer(kind(LATTICE_undefined_ID)), optional, intent(in) :: & !< if given, symmetries between the two orientation will be considered + struct + + real(pReal), dimension(4) :: dQ,dQsymA,mis + integer :: i,j,k,s,symmetry + integer(kind(LATTICE_undefined_ID)) :: myStruct + + integer, dimension(2), parameter :: & + NsymOperations = [24,12] + + real(pReal), dimension(4,36), parameter :: & + symOperations = reshape([& + 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! cubic symmetry operations + 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), & ! 2-fold symmetry + 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & ! 3-fold symmetry + -0.5_pReal, 0.5_pReal, 0.5_pReal, 0.5_pReal, & + 0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & + -0.5_pReal, -0.5_pReal, 0.5_pReal, 0.5_pReal, & + 0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & + -0.5_pReal, 0.5_pReal, -0.5_pReal, 0.5_pReal, & + 0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & + -0.5_pReal, 0.5_pReal, 0.5_pReal, -0.5_pReal, & + 1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & ! 4-fold symmetry + 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & + -1.0_pReal/sqrt(2.0_pReal), 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, & + 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & + -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, & + 1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal, & + -1.0_pReal/sqrt(2.0_pReal), 0.0_pReal, 0.0_pReal, 1.0_pReal/sqrt(2.0_pReal), & + ! + 1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal, & ! hexagonal symmetry operations + 0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal, & ! 2-fold symmetry + 0.0_pReal, 0.0_pReal, 1.0_pReal, 0.0_pReal, & + 0.0_pReal, 0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & + 0.0_pReal, -0.5_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, & + 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & + 0.0_pReal, -2.0_pReal/sqrt(3.0_pReal), 0.5_pReal, 0.0_pReal, & + 2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & ! 6-fold symmetry + -2.0_pReal/sqrt(3.0_pReal), 0.0_pReal, 0.0_pReal, 0.5_pReal, & + 0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & + -0.5_pReal, 0.0_pReal, 0.0_pReal, 2.0_pReal/sqrt(3.0_pReal), & + 0.0_pReal, 0.0_pReal, 0.0_pReal, 1.0_pReal & + ],[4,36]) !< Symmetry operations as quaternions 24 for cubic, 12 for hexagonal = 36 + !-------------------------------------------------------------------------------------------------- ! check if a structure with known symmetries is given - if (present(struct)) then - myStruct = struct - select case (struct) - case(LATTICE_fcc_ID,LATTICE_bcc_ID) - symmetry = 1 - case(LATTICE_hex_ID) - symmetry = 2 - case default - symmetry = 0 - end select - else - symmetry = 0 - myStruct = LATTICE_undefined_ID - endif - - + if (present(struct)) then + myStruct = struct + select case (struct) + case(LATTICE_fcc_ID,LATTICE_bcc_ID) + symmetry = 1 + case(LATTICE_hex_ID) + symmetry = 2 + case default + symmetry = 0 + end select + else + symmetry = 0 + myStruct = LATTICE_undefined_ID + endif + + !-------------------------------------------------------------------------------------------------- ! calculate misorientation, for cubic and hexagonal structure find symmetries - dQ = math_qMul(math_qConj(Q1),Q2) - lattice_qDisorientation = dQ - - select case(symmetry) - - case (1,2) - s = sum(NsymOperations(1:symmetry-1)) - do i = 1,2 - dQ = math_qConj(dQ) ! switch order of "from -- to" - do j = 1,NsymOperations(symmetry) ! run through first crystal's symmetries - dQsymA = math_qMul(symOperations(1:4,s+j),dQ) ! apply sym - do k = 1,NsymOperations(symmetry) ! run through 2nd crystal's symmetries - mis = math_qMul(dQsymA,symOperations(1:4,s+k)) ! apply sym - if (mis(1) < 0.0_pReal) & ! want positive angle - mis = -mis - if (mis(1)-lattice_qDisorientation(1) > -tol_math_check & - .and. lattice_qInSST(mis,LATTICE_undefined_ID)) lattice_qDisorientation = mis ! found better one - enddo; enddo; enddo - case (0) - if (lattice_qDisorientation(1) < 0.0_pReal) lattice_qDisorientation = -lattice_qDisorientation ! keep omega within 0 to 180 deg - end select - + dQ = math_qMul(math_qConj(Q1),Q2) + lattice_qDisorientation = dQ + + select case(symmetry) + + case (1,2) + s = sum(NsymOperations(1:symmetry-1)) + do i = 1,2 + dQ = math_qConj(dQ) ! switch order of "from -- to" + do j = 1,NsymOperations(symmetry) ! run through first crystal's symmetries + dQsymA = math_qMul(symOperations(1:4,s+j),dQ) ! apply sym + do k = 1,NsymOperations(symmetry) ! run through 2nd crystal's symmetries + mis = math_qMul(dQsymA,symOperations(1:4,s+k)) ! apply sym + if (mis(1) < 0.0_pReal) & ! want positive angle + mis = -mis + if (mis(1)-lattice_qDisorientation(1) > -tol_math_check & + .and. lattice_qInSST(mis,LATTICE_undefined_ID)) lattice_qDisorientation = mis ! found better one + enddo; enddo; enddo + case (0) + if (lattice_qDisorientation(1) < 0.0_pReal) lattice_qDisorientation = -lattice_qDisorientation ! keep omega within 0 to 180 deg + end select + end function lattice_qDisorientation - - + + !-------------------------------------------------------------------------------------------------- !> @brief Characteristic shear for twinning !-------------------------------------------------------------------------------------------------- function lattice_characteristicShear_Twin(Ntwin,structure,CoverA) result(characteristicShear) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(sum(Ntwin)) :: characteristicShear + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(sum(Ntwin)) :: characteristicShear + + integer :: & + a, & !< index of active system + c, & !< index in complete system list + mf, & !< index of my family + ms !< index of my system in current family + + integer, dimension(LATTICE_HEX_NTWIN), parameter :: & + HEX_SHEARTWIN = reshape( [& + 1, & ! <-10.1>{10.2} + 1, & + 1, & + 1, & + 1, & + 1, & + 2, & ! <11.6>{-1-1.1} + 2, & + 2, & + 2, & + 2, & + 2, & + 3, & ! <10.-2>{10.1} + 3, & + 3, & + 3, & + 3, & + 3, & + 4, & ! <11.-3>{11.2} + 4, & + 4, & + 4, & + 4, & + 4 & + ],[LATTICE_HEX_NTWIN]) ! indicator to formulas below + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure)) + + a = 0 + myFamilies: do mf = 1,size(Ntwin,1) + mySystems: do ms = 1,Ntwin(mf) + a = a + 1 + select case(structure(1:3)) + case('fcc','bcc') + characteristicShear(a) = 0.5_pReal*sqrt(2.0_pReal) + case('hex') + if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & + call IO_error(131,ext_msg='lattice_characteristicShear_Twin') + c = sum(LATTICE_HEX_NTWINSYSTEM(1:mf-1))+ms + select case(HEX_SHEARTWIN(c)) ! from Christian & Mahajan 1995 p.29 + case (1) ! <-10.1>{10.2} + characteristicShear(a) = (3.0_pReal-cOverA**2.0_pReal)/sqrt(3.0_pReal)/CoverA + case (2) ! <11.6>{-1-1.1} + characteristicShear(a) = 1.0_pReal/cOverA + case (3) ! <10.-2>{10.1} + characteristicShear(a) = (4.0_pReal*cOverA**2.0_pReal-9.0_pReal)/sqrt(48.0_pReal)/cOverA + case (4) ! <11.-3>{11.2} + characteristicShear(a) = 2.0_pReal*(cOverA**2.0_pReal-2.0_pReal)/3.0_pReal/cOverA + end select + case default + call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure)) + end select + enddo mySystems + enddo myFamilies - integer :: & - a, & !< index of active system - c, & !< index in complete system list - mf, & !< index of my family - ms !< index of my system in current family - - integer, dimension(LATTICE_HEX_NTWIN), parameter :: & - HEX_SHEARTWIN = reshape( [& - 1, & ! <-10.1>{10.2} - 1, & - 1, & - 1, & - 1, & - 1, & - 2, & ! <11.6>{-1-1.1} - 2, & - 2, & - 2, & - 2, & - 2, & - 3, & ! <10.-2>{10.1} - 3, & - 3, & - 3, & - 3, & - 3, & - 4, & ! <11.-3>{11.2} - 4, & - 4, & - 4, & - 4, & - 4 & - ],[LATTICE_HEX_NTWIN]) ! indicator to formulas below - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure)) - - a = 0 - myFamilies: do mf = 1,size(Ntwin,1) - mySystems: do ms = 1,Ntwin(mf) - a = a + 1 - select case(structure(1:3)) - case('fcc','bcc') - characteristicShear(a) = 0.5_pReal*sqrt(2.0_pReal) - case('hex') - if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) & - call IO_error(131,ext_msg='lattice_characteristicShear_Twin') - c = sum(LATTICE_HEX_NTWINSYSTEM(1:mf-1))+ms - select case(HEX_SHEARTWIN(c)) ! from Christian & Mahajan 1995 p.29 - case (1) ! <-10.1>{10.2} - characteristicShear(a) = (3.0_pReal-cOverA**2.0_pReal)/sqrt(3.0_pReal)/CoverA - case (2) ! <11.6>{-1-1.1} - characteristicShear(a) = 1.0_pReal/cOverA - case (3) ! <10.-2>{10.1} - characteristicShear(a) = (4.0_pReal*cOverA**2.0_pReal-9.0_pReal)/sqrt(48.0_pReal)/cOverA - case (4) ! <11.-3>{11.2} - characteristicShear(a) = 2.0_pReal*(cOverA**2.0_pReal-2.0_pReal)/3.0_pReal/cOverA - end select - case default - call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure)) - end select - enddo mySystems - enddo myFamilies - end function lattice_characteristicShear_Twin - - + + !-------------------------------------------------------------------------------------------------- !> @brief Rotated elasticity matrices for twinning in 66-vector notation !-------------------------------------------------------------------------------------------------- function lattice_C66_twin(Ntwin,C66,structure,CoverA) - use IO, only: & - IO_error - use math, only: & - PI, & - math_axisAngleToR, & - math_sym3333to66, & - math_66toSym3333, & - math_rotate_forward3333 - - implicit none - integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin - - real(pReal),dimension(3,3,sum(Ntwin)) :: coordinateSystem - real(pReal), dimension(3,3) :: R - integer :: i + use IO, only: & + IO_error + use math, only: & + PI, & + math_axisAngleToR, & + math_sym3333to66, & + math_66toSym3333, & + math_rotate_forward3333 - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_C66_twin: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_FCC_NSLIPSYSTEM,LATTICE_FCC_SYSTEMTWIN,& - trim(structure),0.0_pReal) - case('bcc') - coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMTWIN,& - trim(structure),0.0_pReal) - case('hex') - coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_HEX_NSLIPSYSTEM,LATTICE_HEX_SYSTEMTWIN,& - 'hex',cOverA) - case default - call IO_error(137,ext_msg='lattice_C66_twin: '//trim(structure)) - end select - - do i = 1, sum(Ntwin) - R = math_axisAngleToR(coordinateSystem(1:3,2,i), PI) ! ToDo: Why always 180 deg? - lattice_C66_twin(1:6,1:6,i) = math_sym3333to66(math_rotate_forward3333(math_66toSym3333(C66),R)) - enddo + integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(6,6), intent(in) :: C66 !< unrotated parent stiffness matrix + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(6,6,sum(Ntwin)) :: lattice_C66_twin + + real(pReal),dimension(3,3,sum(Ntwin)) :: coordinateSystem + real(pReal), dimension(3,3) :: R + integer :: i + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_C66_twin: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_FCC_NSLIPSYSTEM,LATTICE_FCC_SYSTEMTWIN,& + trim(structure),0.0_pReal) + case('bcc') + coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMTWIN,& + trim(structure),0.0_pReal) + case('hex') + coordinateSystem = buildCoordinateSystem(Ntwin,LATTICE_HEX_NSLIPSYSTEM,LATTICE_HEX_SYSTEMTWIN,& + 'hex',cOverA) + case default + call IO_error(137,ext_msg='lattice_C66_twin: '//trim(structure)) + end select + + do i = 1, sum(Ntwin) + R = math_axisAngleToR(coordinateSystem(1:3,2,i), PI) ! ToDo: Why always 180 deg? + lattice_C66_twin(1:6,1:6,i) = math_sym3333to66(math_rotate_forward3333(math_66toSym3333(C66),R)) + enddo end function lattice_C66_twin - - + + !-------------------------------------------------------------------------------------------------- !> @brief Rotated elasticity matrices for transformation in 66-vector notation !-------------------------------------------------------------------------------------------------- function lattice_C66_trans(Ntrans,C_parent66,structure_target, & CoverA_trans,a_bcc,a_fcc) - use prec, only: & - tol_math_check - use IO, only: & - IO_error - use math, only: & - INRAD, & - MATH_I3, & - math_axisAngleToR, & - math_sym3333to66, & - math_66toSym3333, & - math_rotate_forward3333 - - implicit none - integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family - character(len=*), intent(in) :: structure_target !< lattice structure - real(pReal), dimension(6,6), intent(in) :: C_parent66 - real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans - - real(pReal), dimension(6,6) :: C_bar66, C_target_unrotated66 - real(pReal), dimension(3,3,3,3) :: C_target_unrotated - real(pReal), dimension(3,3,sum(Ntrans)) :: Q,S - real(pReal) :: a_bcc, a_fcc, CoverA_trans - integer :: i - - if (len_trim(structure_target) /= 3) & - call IO_error(137,ext_msg='lattice_C66_trans (target): '//trim(structure_target)) - - !ToDo: add checks for CoverA_trans,a_fcc,a_bcc + use prec, only: & + tol_math_check + use IO, only: & + IO_error + use math, only: & + INRAD, & + MATH_I3, & + math_axisAngleToR, & + math_sym3333to66, & + math_66toSym3333, & + math_rotate_forward3333 + + integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family + character(len=*), intent(in) :: structure_target !< lattice structure + real(pReal), dimension(6,6), intent(in) :: C_parent66 + real(pReal), dimension(6,6,sum(Ntrans)) :: lattice_C66_trans -!-------------------------------------------------------------------------------------------------- -! elasticity matrix of the target phase in cube orientation - if (structure_target(1:3) == 'hex') then - C_bar66(1,1) = (C_parent66(1,1) + C_parent66(1,2) + 2.0_pReal*C_parent66(4,4))/2.0_pReal - C_bar66(1,2) = (C_parent66(1,1) + 5.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/6.0_pReal - C_bar66(3,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) + 4.0_pReal*C_parent66(4,4))/3.0_pReal - C_bar66(1,3) = (C_parent66(1,1) + 2.0_pReal*C_parent66(1,2) - 2.0_pReal*C_parent66(4,4))/3.0_pReal - C_bar66(4,4) = (C_parent66(1,1) - C_parent66(1,2) + C_parent66(4,4))/3.0_pReal - C_bar66(1,4) = (C_parent66(1,1) - C_parent66(1,2) - 2.0_pReal*C_parent66(4,4)) /(3.0_pReal*sqrt(2.0_pReal)) - - C_target_unrotated66 = 0.0_pReal - C_target_unrotated66(1,1) = C_bar66(1,1) - C_bar66(1,4)**2.0_pReal/C_bar66(4,4) - C_target_unrotated66(1,2) = C_bar66(1,2) + C_bar66(1,4)**2.0_pReal/C_bar66(4,4) - C_target_unrotated66(1,3) = C_bar66(1,3) - C_target_unrotated66(3,3) = C_bar66(3,3) - C_target_unrotated66(4,4) = C_bar66(4,4) - C_bar66(1,4)**2.0_pReal/(0.5_pReal*(C_bar66(1,1) - C_bar66(1,2))) - C_target_unrotated66 = lattice_symmetrizeC66(LATTICE_HEX_ID,C_target_unrotated66) - elseif (structure_target(1:3) == 'bcc') then - C_target_unrotated66 = C_parent66 - else - call IO_error(137,ext_msg='lattice_C66_trans (target): '//trim(structure_target)) - endif - - - do i = 1, 6 - if (abs(C_target_unrotated66(i,i)) @brief Non-schmid projections for bcc with up to 6 coefficients ! Koester et al. 2012, Acta Materialia 60 (2012) 3894–3901, eq. (17) ! Gröger et al. 2008, Acta Materialia 56 (2008) 5412–5425, table 1 !-------------------------------------------------------------------------------------------------- function lattice_nonSchmidMatrix(Nslip,nonSchmidCoefficients,sense) result(nonSchmidMatrix) - use IO, only: & - IO_error - use math, only: & - INRAD, & - math_outer, & - math_cross, & - math_axisAngleToR - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: nonSchmidCoefficients !< non-Schmid coefficients for projections - integer, intent(in) :: sense !< sense (-1,+1) - real(pReal), dimension(1:3,1:3,sum(Nslip)) :: nonSchmidMatrix + use IO, only: & + IO_error + use math, only: & + INRAD, & + math_outer, & + math_cross, & + math_axisAngleToR - real(pReal), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem !< coordinate system of slip system - real(pReal), dimension(:), allocatable :: direction, normal, np - integer :: i - - if (abs(sense) /= 1) call IO_error(0,ext_msg='lattice_nonSchmidMatrix') - - coordinateSystem = buildCoordinateSystem(Nslip,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMSLIP,& - 'bcc',0.0_pReal) - coordinateSystem(1:3,1,1:sum(Nslip)) = coordinateSystem(1:3,1,1:sum(Nslip)) *real(sense,pReal) ! convert unidirectional coordinate system - nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'bcc',0.0_pReal) ! Schmid contribution - - do i = 1,sum(Nslip) - direction = coordinateSystem(1:3,1,i) - normal = coordinateSystem(1:3,2,i) - np = matmul(math_axisAngleToR(direction,60.0_pReal*INRAD), normal) - if (size(nonSchmidCoefficients)>0) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(1) * math_outer(direction, np) - if (size(nonSchmidCoefficients)>1) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(2) * math_outer(math_cross(normal, direction), normal) - if (size(nonSchmidCoefficients)>2) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(3) * math_outer(math_cross(np, direction), np) - if (size(nonSchmidCoefficients)>3) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(4) * math_outer(normal, normal) - if (size(nonSchmidCoefficients)>4) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(5) * math_outer(math_cross(normal, direction), & - math_cross(normal, direction)) - if (size(nonSchmidCoefficients)>5) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & - + nonSchmidCoefficients(6) * math_outer(direction, direction) - enddo + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + real(pReal), dimension(:), intent(in) :: nonSchmidCoefficients !< non-Schmid coefficients for projections + integer, intent(in) :: sense !< sense (-1,+1) + real(pReal), dimension(1:3,1:3,sum(Nslip)) :: nonSchmidMatrix + + real(pReal), dimension(1:3,1:3,sum(Nslip)) :: coordinateSystem !< coordinate system of slip system + real(pReal), dimension(:), allocatable :: direction, normal, np + integer :: i + + if (abs(sense) /= 1) call IO_error(0,ext_msg='lattice_nonSchmidMatrix') + + coordinateSystem = buildCoordinateSystem(Nslip,LATTICE_BCC_NSLIPSYSTEM,LATTICE_BCC_SYSTEMSLIP,& + 'bcc',0.0_pReal) + coordinateSystem(1:3,1,1:sum(Nslip)) = coordinateSystem(1:3,1,1:sum(Nslip)) *real(sense,pReal) ! convert unidirectional coordinate system + nonSchmidMatrix = lattice_SchmidMatrix_slip(Nslip,'bcc',0.0_pReal) ! Schmid contribution + + do i = 1,sum(Nslip) + direction = coordinateSystem(1:3,1,i) + normal = coordinateSystem(1:3,2,i) + np = matmul(math_axisAngleToR(direction,60.0_pReal*INRAD), normal) + if (size(nonSchmidCoefficients)>0) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(1) * math_outer(direction, np) + if (size(nonSchmidCoefficients)>1) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(2) * math_outer(math_cross(normal, direction), normal) + if (size(nonSchmidCoefficients)>2) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(3) * math_outer(math_cross(np, direction), np) + if (size(nonSchmidCoefficients)>3) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(4) * math_outer(normal, normal) + if (size(nonSchmidCoefficients)>4) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(5) * math_outer(math_cross(normal, direction), & + math_cross(normal, direction)) + if (size(nonSchmidCoefficients)>5) nonSchmidMatrix(1:3,1:3,i) = nonSchmidMatrix(1:3,1:3,i) & + + nonSchmidCoefficients(6) * math_outer(direction, direction) + enddo end function lattice_nonSchmidMatrix - - + + !-------------------------------------------------------------------------------------------------- !> @brief Slip-slip interaction matrix !> details only active slip systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_SlipBySlip(Nslip,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-slip interaction - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix - - integer, dimension(:), allocatable :: NslipMax - integer, dimension(:,:), allocatable :: interactionTypes + use IO, only: & + IO_error - integer, dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NSLIP), parameter :: & - FCC_INTERACTIONSLIPSLIP = reshape( [& - 1, 2, 2, 4, 6, 5, 3, 5, 5, 4, 5, 6, 9,10, 9,10,11,12, & - 2, 1, 2, 6, 4, 5, 5, 4, 6, 5, 3, 5, 9,10,11,12, 9,10, & - 2, 2, 1, 5, 5, 3, 5, 6, 4, 6, 5, 4, 11,12, 9,10, 9,10, & - 4, 6, 5, 1, 2, 2, 4, 5, 6, 3, 5, 5, 9,10,10, 9,12,11, & - 6, 4, 5, 2, 1, 2, 5, 3, 5, 5, 4, 6, 9,10,12,11,10, 9, & - 5, 5, 3, 2, 2, 1, 6, 5, 4, 5, 6, 4, 11,12,10, 9,10, 9, & - 3, 5, 5, 4, 5, 6, 1, 2, 2, 4, 6, 5, 10, 9,10, 9,11,12, & - 5, 4, 6, 5, 3, 5, 2, 1, 2, 6, 4, 5, 10, 9,12,11, 9,10, & - 5, 6, 4, 6, 5, 4, 2, 2, 1, 5, 5, 3, 12,11,10, 9, 9,10, & - 4, 5, 6, 3, 5, 5, 4, 6, 5, 1, 2, 2, 10, 9, 9,10,12,11, & - 5, 3, 5, 5, 4, 6, 6, 4, 5, 2, 1, 2, 10, 9,11,12,10, 9, & - 6, 5, 4, 5, 6, 4, 5, 5, 3, 2, 2, 1, 12,11, 9,10,10, 9, & - - 9, 9,11, 9, 9,11,10,10,12,10,10,12, 1, 7, 8, 8, 8, 8, & - 10,10,12,10,10,12, 9, 9,11, 9, 9,11, 7, 1, 8, 8, 8, 8, & - 9,11, 9,10,12,10,10,12,10, 9,11, 9, 8, 8, 1, 7, 8, 8, & - 10,12,10, 9,11, 9, 9,11, 9,10,12,10, 8, 8, 7, 1, 8, 8, & - 11, 9, 9,12,10,10,11, 9, 9,12,10,10, 8, 8, 8, 8, 1, 7, & - 12,10,10,11, 9, 9,12,10,10,11, 9, 9, 8, 8, 8, 8, 7, 1 & - ],shape(FCC_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for fcc + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-slip interaction + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(sum(Nslip),sum(Nslip)) :: interactionMatrix + + integer, dimension(:), allocatable :: NslipMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NSLIP), parameter :: & + FCC_INTERACTIONSLIPSLIP = reshape( [& + 1, 2, 2, 4, 6, 5, 3, 5, 5, 4, 5, 6, 9,10, 9,10,11,12, & ! -----> acting + 2, 1, 2, 6, 4, 5, 5, 4, 6, 5, 3, 5, 9,10,11,12, 9,10, & ! | + 2, 2, 1, 5, 5, 3, 5, 6, 4, 6, 5, 4, 11,12, 9,10, 9,10, & ! | + 4, 6, 5, 1, 2, 2, 4, 5, 6, 3, 5, 5, 9,10,10, 9,12,11, & ! v + 6, 4, 5, 2, 1, 2, 5, 3, 5, 5, 4, 6, 9,10,12,11,10, 9, & ! reacting + 5, 5, 3, 2, 2, 1, 6, 5, 4, 5, 6, 4, 11,12,10, 9,10, 9, & + 3, 5, 5, 4, 5, 6, 1, 2, 2, 4, 6, 5, 10, 9,10, 9,11,12, & + 5, 4, 6, 5, 3, 5, 2, 1, 2, 6, 4, 5, 10, 9,12,11, 9,10, & + 5, 6, 4, 6, 5, 4, 2, 2, 1, 5, 5, 3, 12,11,10, 9, 9,10, & + 4, 5, 6, 3, 5, 5, 4, 6, 5, 1, 2, 2, 10, 9, 9,10,12,11, & + 5, 3, 5, 5, 4, 6, 6, 4, 5, 2, 1, 2, 10, 9,11,12,10, 9, & + 6, 5, 4, 5, 6, 4, 5, 5, 3, 2, 2, 1, 12,11, 9,10,10, 9, & + + 9, 9,11, 9, 9,11,10,10,12,10,10,12, 1, 7, 8, 8, 8, 8, & + 10,10,12,10,10,12, 9, 9,11, 9, 9,11, 7, 1, 8, 8, 8, 8, & + 9,11, 9,10,12,10,10,12,10, 9,11, 9, 8, 8, 1, 7, 8, 8, & + 10,12,10, 9,11, 9, 9,11, 9,10,12,10, 8, 8, 7, 1, 8, 8, & + 11, 9, 9,12,10,10,11, 9, 9,12,10,10, 8, 8, 8, 8, 1, 7, & + 12,10,10,11, 9, 9,12,10,10,11, 9, 9, 8, 8, 8, 8, 7, 1 & + ],shape(FCC_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for fcc !< 1: self interaction !< 2: coplanar interaction !< 3: collinear interaction @@ -1301,1094 +1291,1078 @@ function lattice_interaction_SlipBySlip(Nslip,interactionValues,structure) resul !<10: similar to glissile junctions in <110>{111} btw one {110} and one {111} plane !<11: crossing btw one {110} and one {111} plane !<12: collinear btw one {110} and one {111} plane - - integer, dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NSLIP), parameter :: & - BCC_INTERACTIONSLIPSLIP = reshape( [& - 1,2,6,6,5,4,4,3,4,3,5,4, 6,6,4,3,3,4,6,6,4,3,6,6, & - 2,1,6,6,4,3,5,4,5,4,4,3, 6,6,3,4,4,3,6,6,3,4,6,6, & - 6,6,1,2,4,5,3,4,4,5,3,4, 4,3,6,6,6,6,3,4,6,6,4,3, & - 6,6,2,1,3,4,4,5,3,4,4,5, 3,4,6,6,6,6,4,3,6,6,3,4, & - 5,4,4,3,1,2,6,6,3,4,5,4, 3,6,4,6,6,4,6,3,4,6,3,6, & - 4,3,5,4,2,1,6,6,4,5,4,3, 4,6,3,6,6,3,6,4,3,6,4,6, & - 4,5,3,4,6,6,1,2,5,4,3,4, 6,3,6,4,4,6,3,6,6,4,6,3, & - 3,4,4,5,6,6,2,1,4,3,4,5, 6,4,6,3,3,6,4,6,6,3,6,4, & - 4,5,4,3,3,4,5,4,1,2,6,6, 3,6,6,4,4,6,6,3,6,4,3,6, & - 3,4,5,4,4,5,4,3,2,1,6,6, 4,6,6,3,3,6,6,4,6,3,4,6, & - 5,4,3,4,5,4,3,4,6,6,1,2, 6,3,4,6,6,4,3,6,4,6,6,3, & - 4,3,4,5,4,3,4,5,6,6,2,1, 6,4,3,6,6,3,4,6,3,6,6,4, & - ! - 6,6,4,3,3,4,6,6,3,4,6,6, 1,5,6,6,5,6,6,3,5,6,3,6, & - 6,6,3,4,6,6,3,4,6,6,3,4, 5,1,6,6,6,5,3,6,6,5,6,3, & - 4,3,6,6,4,3,6,6,6,6,4,3, 6,6,1,5,6,3,5,6,3,6,5,6, & - 3,4,6,6,6,6,4,3,4,3,6,6, 6,6,5,1,3,6,6,5,6,3,6,5, & - 3,4,6,6,6,6,4,3,4,3,6,6, 5,6,6,3,1,6,5,6,5,3,6,6, & - 4,3,6,6,4,3,6,6,6,6,4,3, 6,5,3,6,6,1,6,5,3,5,6,6, & - 6,6,3,4,6,6,3,4,6,6,3,4, 6,3,5,6,5,6,1,6,6,6,5,3, & - 6,6,4,3,3,4,6,6,3,4,6,6, 3,6,6,5,6,5,6,1,6,6,3,5, & - 4,3,6,6,4,3,6,6,6,6,4,3, 5,6,3,6,5,3,6,6,1,6,6,5, & - 3,4,6,6,6,6,4,3,4,3,6,6, 6,5,6,3,3,5,6,6,6,1,5,6, & - 6,6,4,3,3,4,6,6,3,4,6,6, 3,6,5,6,6,6,5,3,6,5,1,6, & - 6,6,3,4,6,6,3,4,6,6,3,4, 6,3,6,5,6,6,3,5,5,6,6,1 & - ],shape(BCC_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for bcc from Queyreau et al. Int J Plast 25 (2009) 361–377 + + integer, dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NSLIP), parameter :: & + BCC_INTERACTIONSLIPSLIP = reshape( [& + 1,2,6,6,5,4,4,3,4,3,5,4, 6,6,4,3,3,4,6,6,4,3,6,6, & ! -----> acting + 2,1,6,6,4,3,5,4,5,4,4,3, 6,6,3,4,4,3,6,6,3,4,6,6, & ! | + 6,6,1,2,4,5,3,4,4,5,3,4, 4,3,6,6,6,6,3,4,6,6,4,3, & ! | + 6,6,2,1,3,4,4,5,3,4,4,5, 3,4,6,6,6,6,4,3,6,6,3,4, & ! v + 5,4,4,3,1,2,6,6,3,4,5,4, 3,6,4,6,6,4,6,3,4,6,3,6, & ! reacting + 4,3,5,4,2,1,6,6,4,5,4,3, 4,6,3,6,6,3,6,4,3,6,4,6, & + 4,5,3,4,6,6,1,2,5,4,3,4, 6,3,6,4,4,6,3,6,6,4,6,3, & + 3,4,4,5,6,6,2,1,4,3,4,5, 6,4,6,3,3,6,4,6,6,3,6,4, & + 4,5,4,3,3,4,5,4,1,2,6,6, 3,6,6,4,4,6,6,3,6,4,3,6, & + 3,4,5,4,4,5,4,3,2,1,6,6, 4,6,6,3,3,6,6,4,6,3,4,6, & + 5,4,3,4,5,4,3,4,6,6,1,2, 6,3,4,6,6,4,3,6,4,6,6,3, & + 4,3,4,5,4,3,4,5,6,6,2,1, 6,4,3,6,6,3,4,6,3,6,6,4, & + ! + 6,6,4,3,3,4,6,6,3,4,6,6, 1,5,6,6,5,6,6,3,5,6,3,6, & + 6,6,3,4,6,6,3,4,6,6,3,4, 5,1,6,6,6,5,3,6,6,5,6,3, & + 4,3,6,6,4,3,6,6,6,6,4,3, 6,6,1,5,6,3,5,6,3,6,5,6, & + 3,4,6,6,6,6,4,3,4,3,6,6, 6,6,5,1,3,6,6,5,6,3,6,5, & + 3,4,6,6,6,6,4,3,4,3,6,6, 5,6,6,3,1,6,5,6,5,3,6,6, & + 4,3,6,6,4,3,6,6,6,6,4,3, 6,5,3,6,6,1,6,5,3,5,6,6, & + 6,6,3,4,6,6,3,4,6,6,3,4, 6,3,5,6,5,6,1,6,6,6,5,3, & + 6,6,4,3,3,4,6,6,3,4,6,6, 3,6,6,5,6,5,6,1,6,6,3,5, & + 4,3,6,6,4,3,6,6,6,6,4,3, 5,6,3,6,5,3,6,6,1,6,6,5, & + 3,4,6,6,6,6,4,3,4,3,6,6, 6,5,6,3,3,5,6,6,6,1,5,6, & + 6,6,4,3,3,4,6,6,3,4,6,6, 3,6,5,6,6,6,5,3,6,5,1,6, & + 6,6,3,4,6,6,3,4,6,6,3,4, 6,3,6,5,6,6,3,5,5,6,6,1 & + ],shape(BCC_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for bcc from Queyreau et al. Int J Plast 25 (2009) 361–377 !< 1: self interaction !< 2: coplanar interaction !< 3: collinear interaction !< 4: mixed-asymmetrical junction !< 5: mixed-symmetrical junction !< 6: edge junction - - integer, dimension(LATTICE_HEX_NSLIP,LATTICE_HEX_NSLIP), parameter :: & - HEX_INTERACTIONSLIPSLIP = reshape( [& - 1, 2, 2, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & - 2, 1, 2, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & - 2, 2, 1, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & - ! - 6, 6, 6, 4, 5, 5, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & - 6, 6, 6, 5, 4, 5, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & - 6, 6, 6, 5, 5, 4, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & - ! - 12,12,12, 11,11,11, 9,10,10, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & - 12,12,12, 11,11,11, 10, 9,10, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & - 12,12,12, 11,11,11, 10,10, 9, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & - ! - 20,20,20, 19,19,19, 18,18,18, 16,17,17,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - 20,20,20, 19,19,19, 18,18,18, 17,16,17,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - 20,20,20, 19,19,19, 18,18,18, 17,17,16,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - 20,20,20, 19,19,19, 18,18,18, 17,17,17,16,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - 20,20,20, 19,19,19, 18,18,18, 17,17,17,17,16,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - 20,20,20, 19,19,19, 18,18,18, 17,17,17,17,17,16, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & - ! - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 25,26,26,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,25,26,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,25,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,25,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,25,26,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,25,26,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,25,26,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,25,26,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,25,26,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,25,26,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,26,25,26, 35,35,35,35,35,35, & - 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,26,26,25, 35,35,35,35,35,35, & - ! - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 36,37,37,37,37,37, & - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,36,37,37,37,37, & - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,36,37,37,37, & - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,36,37,37, & - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,36,37, & - 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,37,36 & - ],shape(HEX_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for hex (onion peel naming scheme) - - integer, dimension(LATTICE_BCT_NSLIP,LATTICE_BCT_NSLIP), parameter :: & - BCT_INTERACTIONSLIPSLIP = reshape( [& - 1, 2, 3, 3, 7, 7, 13, 13, 13, 13, 21, 21, 31, 31, 31, 31, 43, 43, 57, 57, 73, 73, 73, 73, 91, 91, 91, 91, 91, 91, 91, 91, 111, 111, 111, 111, 133,133,133,133,133,133,133,133, 157,157,157,157,157,157,157,157, & - 2, 1, 3, 3, 7, 7, 13, 13, 13, 13, 21, 21, 31, 31, 31, 31, 43, 43, 57, 57, 73, 73, 73, 73, 91, 91, 91, 91, 91, 91, 91, 91, 111, 111, 111, 111, 133,133,133,133,133,133,133,133, 157,157,157,157,157,157,157,157, & - ! - 6, 6, 4, 5, 8, 8, 14, 14, 14, 14, 22, 22, 32, 32, 32, 32, 44, 44, 58, 58, 74, 74, 74, 74, 92, 92, 92, 92, 92, 92, 92, 92, 112, 112, 112, 112, 134,134,134,134,134,134,134,134, 158,158,158,158,158,158,158,158, & - 6, 6, 5, 4, 8, 8, 14, 14, 14, 14, 22, 22, 32, 32, 32, 32, 44, 44, 58, 58, 74, 74, 74, 74, 92, 92, 92, 92, 92, 92, 92, 92, 112, 112, 112, 112, 134,134,134,134,134,134,134,134, 158,158,158,158,158,158,158,158, & - ! - 12, 12, 11, 11, 9, 10, 15, 15, 15, 15, 23, 23, 33, 33, 33, 33, 45, 45, 59, 59, 75, 75, 75, 75, 93, 93, 93, 93, 93, 93, 93, 93, 113, 113, 113, 113, 135,135,135,135,135,135,135,135, 159,159,159,159,159,159,159,159, & - 12, 12, 11, 11, 10, 9, 15, 15, 15, 15, 23, 23, 33, 33, 33, 33, 45, 45, 59, 59, 75, 75, 75, 75, 93, 93, 93, 93, 93, 93, 93, 93, 113, 113, 113, 113, 135,135,135,135,135,135,135,135, 159,159,159,159,159,159,159,159, & - ! - 20, 20, 19, 19, 18, 18, 16, 17, 17, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & - 20, 20, 19, 19, 18, 18, 17, 16, 17, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & - 20, 20, 19, 19, 18, 18, 17, 17, 16, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & - 20, 20, 19, 19, 18, 18, 17, 17, 17, 16, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & - ! - 30, 30, 29, 29, 28, 28, 27, 27, 27, 27, 25, 26, 35, 35, 35, 35, 47, 47, 61, 61, 77, 77, 77, 77, 95, 95, 95, 95, 95, 95, 95, 95, 115, 115, 115, 115, 137,137,137,137,137,137,137,137, 161,161,161,161,161,161,161,161, & - 30, 30, 29, 29, 28, 28, 27, 27, 27, 27, 26, 25, 35, 35, 35, 35, 47, 47, 61, 61, 77, 77, 77, 77, 95, 95, 95, 95, 95, 95, 95, 95, 115, 115, 115, 115, 137,137,137,137,137,137,137,137, 161,161,161,161,161,161,161,161, & - ! - 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 36, 37, 37, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & - 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 36, 37, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & - 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 37, 36, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & - 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 37, 37, 36, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & - ! - 56, 56, 55, 55, 54, 54, 53, 53, 53, 53, 52, 52, 51, 51, 51, 51, 49, 50, 63, 63, 79, 79, 79, 79, 97, 97, 97, 97, 97, 97, 97, 97, 117, 117, 117, 117, 139,139,139,139,139,139,139,139, 163,163,163,163,163,163,163,163, & - 56, 56, 55, 55, 54, 54, 53, 53, 53, 53, 52, 52, 51, 51, 51, 51, 50, 49, 63, 63, 79, 79, 79, 79, 97, 97, 97, 97, 97, 97, 97, 97, 117, 117, 117, 117, 139,139,139,139,139,139,139,139, 163,163,163,163,163,163,163,163, & - ! - 72, 72, 71, 71, 70, 70, 69, 69, 69, 69, 68, 68, 67, 67, 67, 67, 66, 66, 64, 65, 80, 80, 80, 80, 98, 98, 98, 98, 98, 98, 98, 98, 118, 118, 118, 118, 140,140,140,140,140,140,140,140, 164,164,164,164,164,164,164,164, & - 72, 72, 71, 71, 70, 70, 69, 69, 69, 69, 68, 68, 67, 67, 67, 67, 66, 66, 65, 64, 80, 80, 80, 80, 98, 98, 98, 98, 98, 98, 98, 98, 118, 118, 118, 118, 140,140,140,140,140,140,140,140, 164,164,164,164,164,164,164,164, & - ! - 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 81, 82, 82, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & - 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 81, 82, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & - 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 82, 81, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & - 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 82, 82, 81, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & - ! - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 100,101,101,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,100,101,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,100,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,100,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,100,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,100,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,101,100,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,101,101,100, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & - ! - 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 122, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & - 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 121, 122, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & - 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 121, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & - 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 122, 121, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & - ! - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 144,145,145,145,145,145,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,144,145,145,145,145,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,144,145,145,145,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,144,145,145,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,144,145,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,144,145,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,145,144,145, 168,168,168,168,168,168,168,168, & - 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,145,145,144, 168,168,168,168,168,168,168,168, & - ! - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,169,170,170,170,170,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,169,170,170,170,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,170,169,170,170,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,170,170,169,170,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,169,170,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,169,170, & - 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,169 & - ],shape(BCT_INTERACTIONSLIPSLIP)) - - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_SlipBySlip: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - interactionTypes = FCC_INTERACTIONSLIPSLIP - NslipMax = LATTICE_FCC_NSLIPSYSTEM - case('bcc') - interactionTypes = BCC_INTERACTIONSLIPSLIP - NslipMax = LATTICE_BCC_NSLIPSYSTEM - case('hex') - interactionTypes = HEX_INTERACTIONSLIPSLIP - NslipMax = LATTICE_HEX_NSLIPSYSTEM - case('bct') - interactionTypes = BCT_INTERACTIONSLIPSLIP - NslipMax = LATTICE_BCT_NSLIPSYSTEM - case default - call IO_error(137,ext_msg='lattice_interaction_SlipBySlip: '//trim(structure)) - end select - - interactionMatrix = buildInteraction(Nslip,Nslip,NslipMax,NslipMax,interactionValues,interactionTypes) - + + integer, dimension(LATTICE_HEX_NSLIP,LATTICE_HEX_NSLIP), parameter :: & + HEX_INTERACTIONSLIPSLIP = reshape( [& + 1, 2, 2, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & ! -----> acting + 2, 1, 2, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & ! | + 2, 2, 1, 3, 3, 3, 7, 7, 7, 13,13,13,13,13,13, 21,21,21,21,21,21,21,21,21,21,21,21, 31,31,31,31,31,31, & ! | + ! ! v + 6, 6, 6, 4, 5, 5, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & ! reacting + 6, 6, 6, 5, 4, 5, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & + 6, 6, 6, 5, 5, 4, 8, 8, 8, 14,14,14,14,14,14, 22,22,22,22,22,22,22,22,22,22,22,22, 32,32,32,32,32,32, & + ! + 12,12,12, 11,11,11, 9,10,10, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & + 12,12,12, 11,11,11, 10, 9,10, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & + 12,12,12, 11,11,11, 10,10, 9, 15,15,15,15,15,15, 23,23,23,23,23,23,23,23,23,23,23,23, 33,33,33,33,33,33, & + ! + 20,20,20, 19,19,19, 18,18,18, 16,17,17,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + 20,20,20, 19,19,19, 18,18,18, 17,16,17,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + 20,20,20, 19,19,19, 18,18,18, 17,17,16,17,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + 20,20,20, 19,19,19, 18,18,18, 17,17,17,16,17,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + 20,20,20, 19,19,19, 18,18,18, 17,17,17,17,16,17, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + 20,20,20, 19,19,19, 18,18,18, 17,17,17,17,17,16, 24,24,24,24,24,24,24,24,24,24,24,24, 34,34,34,34,34,34, & + ! + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 25,26,26,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,25,26,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,25,26,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,25,26,26,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,25,26,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,25,26,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,25,26,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,25,26,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,25,26,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,25,26,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,26,25,26, 35,35,35,35,35,35, & + 30,30,30, 29,29,29, 28,28,28, 27,27,27,27,27,27, 26,26,26,26,26,26,26,26,26,26,26,25, 35,35,35,35,35,35, & + ! + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 36,37,37,37,37,37, & + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,36,37,37,37,37, & + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,36,37,37,37, & + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,36,37,37, & + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,36,37, & + 42,42,42, 41,41,41, 40,40,40, 39,39,39,39,39,39, 38,38,38,38,38,38,38,38,38,38,38,38, 37,37,37,37,37,36 & + ],shape(HEX_INTERACTIONSLIPSLIP)) !< Slip--slip interaction types for hex (onion peel naming scheme) + + integer, dimension(LATTICE_BCT_NSLIP,LATTICE_BCT_NSLIP), parameter :: & + BCT_INTERACTIONSLIPSLIP = reshape( [& + 1, 2, 3, 3, 7, 7, 13, 13, 13, 13, 21, 21, 31, 31, 31, 31, 43, 43, 57, 57, 73, 73, 73, 73, 91, 91, 91, 91, 91, 91, 91, 91, 111, 111, 111, 111, 133,133,133,133,133,133,133,133, 157,157,157,157,157,157,157,157, & ! -----> acting + 2, 1, 3, 3, 7, 7, 13, 13, 13, 13, 21, 21, 31, 31, 31, 31, 43, 43, 57, 57, 73, 73, 73, 73, 91, 91, 91, 91, 91, 91, 91, 91, 111, 111, 111, 111, 133,133,133,133,133,133,133,133, 157,157,157,157,157,157,157,157, & ! | + ! | + 6, 6, 4, 5, 8, 8, 14, 14, 14, 14, 22, 22, 32, 32, 32, 32, 44, 44, 58, 58, 74, 74, 74, 74, 92, 92, 92, 92, 92, 92, 92, 92, 112, 112, 112, 112, 134,134,134,134,134,134,134,134, 158,158,158,158,158,158,158,158, & ! v + 6, 6, 5, 4, 8, 8, 14, 14, 14, 14, 22, 22, 32, 32, 32, 32, 44, 44, 58, 58, 74, 74, 74, 74, 92, 92, 92, 92, 92, 92, 92, 92, 112, 112, 112, 112, 134,134,134,134,134,134,134,134, 158,158,158,158,158,158,158,158, & ! reacting + ! + 12, 12, 11, 11, 9, 10, 15, 15, 15, 15, 23, 23, 33, 33, 33, 33, 45, 45, 59, 59, 75, 75, 75, 75, 93, 93, 93, 93, 93, 93, 93, 93, 113, 113, 113, 113, 135,135,135,135,135,135,135,135, 159,159,159,159,159,159,159,159, & + 12, 12, 11, 11, 10, 9, 15, 15, 15, 15, 23, 23, 33, 33, 33, 33, 45, 45, 59, 59, 75, 75, 75, 75, 93, 93, 93, 93, 93, 93, 93, 93, 113, 113, 113, 113, 135,135,135,135,135,135,135,135, 159,159,159,159,159,159,159,159, & + ! + 20, 20, 19, 19, 18, 18, 16, 17, 17, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & + 20, 20, 19, 19, 18, 18, 17, 16, 17, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & + 20, 20, 19, 19, 18, 18, 17, 17, 16, 17, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & + 20, 20, 19, 19, 18, 18, 17, 17, 17, 16, 24, 24, 34, 34, 34, 34, 46, 46, 60, 60, 76, 76, 76, 76, 94, 94, 94, 94, 94, 94, 94, 94, 114, 114, 114, 114, 136,136,136,136,136,136,136,136, 160,160,160,160,160,160,160,160, & + ! + 30, 30, 29, 29, 28, 28, 27, 27, 27, 27, 25, 26, 35, 35, 35, 35, 47, 47, 61, 61, 77, 77, 77, 77, 95, 95, 95, 95, 95, 95, 95, 95, 115, 115, 115, 115, 137,137,137,137,137,137,137,137, 161,161,161,161,161,161,161,161, & + 30, 30, 29, 29, 28, 28, 27, 27, 27, 27, 26, 25, 35, 35, 35, 35, 47, 47, 61, 61, 77, 77, 77, 77, 95, 95, 95, 95, 95, 95, 95, 95, 115, 115, 115, 115, 137,137,137,137,137,137,137,137, 161,161,161,161,161,161,161,161, & + ! + 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 36, 37, 37, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & + 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 36, 37, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & + 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 37, 36, 37, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & + 42, 42, 41, 41, 40, 40, 39, 39, 39, 39, 38, 38, 37, 37, 37, 36, 48, 48, 62, 62, 78, 78, 78, 78, 96, 96, 96, 96, 96, 96, 96, 96, 116, 116, 116, 116, 138,138,138,138,138,138,138,138, 162,162,162,162,162,162,162,162, & + ! + 56, 56, 55, 55, 54, 54, 53, 53, 53, 53, 52, 52, 51, 51, 51, 51, 49, 50, 63, 63, 79, 79, 79, 79, 97, 97, 97, 97, 97, 97, 97, 97, 117, 117, 117, 117, 139,139,139,139,139,139,139,139, 163,163,163,163,163,163,163,163, & + 56, 56, 55, 55, 54, 54, 53, 53, 53, 53, 52, 52, 51, 51, 51, 51, 50, 49, 63, 63, 79, 79, 79, 79, 97, 97, 97, 97, 97, 97, 97, 97, 117, 117, 117, 117, 139,139,139,139,139,139,139,139, 163,163,163,163,163,163,163,163, & + ! + 72, 72, 71, 71, 70, 70, 69, 69, 69, 69, 68, 68, 67, 67, 67, 67, 66, 66, 64, 65, 80, 80, 80, 80, 98, 98, 98, 98, 98, 98, 98, 98, 118, 118, 118, 118, 140,140,140,140,140,140,140,140, 164,164,164,164,164,164,164,164, & + 72, 72, 71, 71, 70, 70, 69, 69, 69, 69, 68, 68, 67, 67, 67, 67, 66, 66, 65, 64, 80, 80, 80, 80, 98, 98, 98, 98, 98, 98, 98, 98, 118, 118, 118, 118, 140,140,140,140,140,140,140,140, 164,164,164,164,164,164,164,164, & + ! + 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 81, 82, 82, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & + 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 81, 82, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & + 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 82, 81, 82, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & + 90, 90, 89, 89, 88, 88, 87, 87, 87, 87, 86, 86, 85, 85, 85, 85, 84, 84, 83, 83, 82, 82, 82, 81, 99, 99, 99, 99, 99, 99, 99, 99, 119, 119, 119, 119, 141,141,141,141,141,141,141,141, 165,165,165,165,165,165,165,165, & + ! + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 100,101,101,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,100,101,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,100,101,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,100,101,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,100,101,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,100,101,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,101,100,101, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + 110,110, 109,109, 108,108, 107,107,107,107, 106,106, 105,105,105,105, 104,104, 103,103, 102,102,102,102, 101,101,101,101,101,101,101,100, 120, 120, 120, 120, 142,142,142,142,142,142,142,142, 166,166,166,166,166,166,166,166, & + ! + 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 122, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & + 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 121, 122, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & + 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 121, 122, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & + 132,132, 131,131, 130,130, 129,129,129,129, 128,128, 127,127,127,127, 126,126, 125,125, 124,124,124,124, 123,123,123,123,123,123,123,123, 121, 122, 122, 121, 143,143,143,143,143,143,143,143, 167,167,167,167,167,167,167,167, & + ! + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 144,145,145,145,145,145,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,144,145,145,145,145,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,144,145,145,145,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,144,145,145,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,144,145,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,144,145,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,145,144,145, 168,168,168,168,168,168,168,168, & + 156,156, 155,155, 154,154, 153,153,153,153, 152,152, 151,151,151,151, 150,150, 149,149, 148,148,148,148, 147,147,147,147,147,147,147,147, 146, 146, 146, 146, 145,145,145,145,145,145,145,144, 168,168,168,168,168,168,168,168, & + ! + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,169,170,170,170,170,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,169,170,170,170,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,170,169,170,170,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 170,170,170,170,169,170,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,169,170,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,169,170, & + 182,182, 181,181, 180,180, 179,179,179,179, 178,178, 177,177,177,177, 176,176, 175,175, 174,174,174,174, 173,173,173,173,173,173,173,173, 172, 172, 172, 172, 171,171,171,171,171,171,171,171, 169,170,170,170,170,170,170,169 & + ],shape(BCT_INTERACTIONSLIPSLIP)) + + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_SlipBySlip: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + interactionTypes = FCC_INTERACTIONSLIPSLIP + NslipMax = LATTICE_FCC_NSLIPSYSTEM + case('bcc') + interactionTypes = BCC_INTERACTIONSLIPSLIP + NslipMax = LATTICE_BCC_NSLIPSYSTEM + case('hex') + interactionTypes = HEX_INTERACTIONSLIPSLIP + NslipMax = LATTICE_HEX_NSLIPSYSTEM + case('bct') + interactionTypes = BCT_INTERACTIONSLIPSLIP + NslipMax = LATTICE_BCT_NSLIPSYSTEM + case default + call IO_error(137,ext_msg='lattice_interaction_SlipBySlip: '//trim(structure)) + end select + + interactionMatrix = buildInteraction(Nslip,Nslip,NslipMax,NslipMax,interactionValues,interactionTypes) + end function lattice_interaction_SlipBySlip - - + + !-------------------------------------------------------------------------------------------------- !> @brief Twin-twin interaction matrix !> details only active twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_TwinByTwin(Ntwin,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix - - integer, dimension(:), allocatable :: NtwinMax - integer, dimension(:,:), allocatable :: interactionTypes - - integer, dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NTWIN), parameter :: & - FCC_INTERACTIONTWINTWIN = reshape( [& - 1,1,1,2,2,2,2,2,2,2,2,2, & - 1,1,1,2,2,2,2,2,2,2,2,2, & - 1,1,1,2,2,2,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1 & - ],shape(FCC_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for fcc - - integer, dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NTWIN), parameter :: & - BCC_INTERACTIONTWINTWIN = reshape( [& - 1,3,3,3,3,3,3,2,3,3,2,3, & - 3,1,3,3,3,3,2,3,3,3,3,2, & - 3,3,1,3,3,2,3,3,2,3,3,3, & - 3,3,3,1,2,3,3,3,3,2,3,3, & - 3,3,3,2,1,3,3,3,3,2,3,3, & - 3,3,2,3,3,1,3,3,2,3,3,3, & - 3,2,3,3,3,3,1,3,3,3,3,2, & - 2,3,3,3,3,3,3,1,3,3,2,3, & - 3,3,2,3,3,2,3,3,1,3,3,3, & - 3,3,3,2,2,3,3,3,3,1,3,3, & - 2,3,3,3,3,3,3,2,3,3,1,3, & - 3,2,3,3,3,3,2,3,3,3,3,1 & - ],shape(BCC_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for bcc + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(sum(Ntwin),sum(Ntwin)) :: interactionMatrix + + integer, dimension(:), allocatable :: NtwinMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NTWIN), parameter :: & + FCC_INTERACTIONTWINTWIN = reshape( [& + 1,1,1,2,2,2,2,2,2,2,2,2, & ! -----> acting + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 2,2,2,1,1,1,2,2,2,2,2,2, & ! v + 2,2,2,1,1,1,2,2,2,2,2,2, & ! reacting + 2,2,2,1,1,1,2,2,2,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1 & + ],shape(FCC_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for fcc + + integer, dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NTWIN), parameter :: & + BCC_INTERACTIONTWINTWIN = reshape( [& + 1,3,3,3,3,3,3,2,3,3,2,3, & ! -----> acting + 3,1,3,3,3,3,2,3,3,3,3,2, & ! | + 3,3,1,3,3,2,3,3,2,3,3,3, & ! | + 3,3,3,1,2,3,3,3,3,2,3,3, & ! v + 3,3,3,2,1,3,3,3,3,2,3,3, & ! reacting + 3,3,2,3,3,1,3,3,2,3,3,3, & + 3,2,3,3,3,3,1,3,3,3,3,2, & + 2,3,3,3,3,3,3,1,3,3,2,3, & + 3,3,2,3,3,2,3,3,1,3,3,3, & + 3,3,3,2,2,3,3,3,3,1,3,3, & + 2,3,3,3,3,3,3,2,3,3,1,3, & + 3,2,3,3,3,3,2,3,3,3,3,1 & + ],shape(BCC_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for bcc !< 1: self interaction !< 2: collinear interaction !< 3: other interaction - integer, dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NTWIN), parameter :: & - HEX_INTERACTIONTWINTWIN = reshape( [& - 1, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 2, 1, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 2, 2, 1, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 2, 2, 2, 1, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - 2, 2, 2, 2, 2, 1, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & - ! - 6, 6, 6, 6, 6, 6, 4, 5, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 4, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 4, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 5, 4, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 4, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 5, 4, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & - ! - 12,12,12,12,12,12, 11,11,11,11,11,11, 9,10,10,10,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10, 9,10,10,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10, 9,10,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10, 9,10,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10, 9,10, 15,15,15,15,15,15, & - 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10,10, 9, 15,15,15,15,15,15, & - ! - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 16,17,17,17,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,16,17,17,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,16,17,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,16,17,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,16,17, & - 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,17,16 & - ],shape(HEX_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for hex - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_TwinByTwin: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - interactionTypes = FCC_INTERACTIONTWINTWIN - NtwinMax = LATTICE_FCC_NTWINSYSTEM - case('bcc') - interactionTypes = BCC_INTERACTIONTWINTWIN - NtwinMax = LATTICE_BCC_NTWINSYSTEM - case('hex') - interactionTypes = HEX_INTERACTIONTWINTWIN - NtwinMax = LATTICE_HEX_NTWINSYSTEM - case default - call IO_error(137,ext_msg='lattice_interaction_TwinByTwin: '//trim(structure)) - end select - - interactionMatrix = buildInteraction(Ntwin,Ntwin,NtwinMax,NtwinMax,interactionValues,interactionTypes) - + integer, dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NTWIN), parameter :: & + HEX_INTERACTIONTWINTWIN = reshape( [& + 1, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! -----> acting + 2, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! | + 2, 2, 1, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! | + 2, 2, 2, 1, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! v + 2, 2, 2, 2, 1, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! reacting + 2, 2, 2, 2, 2, 1, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & + ! + 6, 6, 6, 6, 6, 6, 4, 5, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 4, 5, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 4, 5, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 5, 4, 5, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 4, 5, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + 6, 6, 6, 6, 6, 6, 5, 5, 5, 5, 5, 4, 8, 8, 8, 8, 8, 8, 14,14,14,14,14,14, & + ! + 12,12,12,12,12,12, 11,11,11,11,11,11, 9,10,10,10,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10, 9,10,10,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10, 9,10,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10, 9,10,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10, 9,10, 15,15,15,15,15,15, & + 12,12,12,12,12,12, 11,11,11,11,11,11, 10,10,10,10,10, 9, 15,15,15,15,15,15, & + ! + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 16,17,17,17,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,16,17,17,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,16,17,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,16,17,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,16,17, & + 20,20,20,20,20,20, 19,19,19,19,19,19, 18,18,18,18,18,18, 17,17,17,17,17,16 & + ],shape(HEX_INTERACTIONTWINTWIN)) !< Twin-twin interaction types for hex + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_TwinByTwin: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + interactionTypes = FCC_INTERACTIONTWINTWIN + NtwinMax = LATTICE_FCC_NTWINSYSTEM + case('bcc') + interactionTypes = BCC_INTERACTIONTWINTWIN + NtwinMax = LATTICE_BCC_NTWINSYSTEM + case('hex') + interactionTypes = HEX_INTERACTIONTWINTWIN + NtwinMax = LATTICE_HEX_NTWINSYSTEM + case default + call IO_error(137,ext_msg='lattice_interaction_TwinByTwin: '//trim(structure)) + end select + + interactionMatrix = buildInteraction(Ntwin,Ntwin,NtwinMax,NtwinMax,interactionValues,interactionTypes) + end function lattice_interaction_TwinByTwin - - + + !-------------------------------------------------------------------------------------------------- !> @brief Trans-trans interaction matrix !> details only active trans systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_TransByTrans(Ntrans,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ntrans !< number of active trans systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for trans-trans interaction - character(len=*), intent(in) :: structure !< lattice structure (parent crystal) - real(pReal), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix - - integer, dimension(:), allocatable :: NtransMax - integer, dimension(:,:), allocatable :: interactionTypes - - integer, dimension(LATTICE_FCC_NTRANS,LATTICE_FCC_NTRANS), parameter :: & - FCC_INTERACTIONTRANSTRANS = reshape( [& - 1,1,1,2,2,2,2,2,2,2,2,2, & - 1,1,1,2,2,2,2,2,2,2,2,2, & - 1,1,1,2,2,2,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,1,1,1,2,2,2,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,1,1,1,2,2,2, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1, & - 2,2,2,2,2,2,2,2,2,1,1,1 & - ],shape(FCC_INTERACTIONTRANSTRANS)) !< Trans-trans interaction types for fcc - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_TransByTrans: '//trim(structure)) - - if(structure(1:3) == 'fcc') then - interactionTypes = FCC_INTERACTIONTRANSTRANS - NtransMax = LATTICE_FCC_NTRANSSYSTEM - else - call IO_error(137,ext_msg='lattice_interaction_TransByTrans: '//trim(structure)) - end if - - interactionMatrix = buildInteraction(Ntrans,Ntrans,NtransMax,NtransMax,interactionValues,interactionTypes) - + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ntrans !< number of active trans systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for trans-trans interaction + character(len=*), intent(in) :: structure !< lattice structure (parent crystal) + real(pReal), dimension(sum(Ntrans),sum(Ntrans)) :: interactionMatrix + + integer, dimension(:), allocatable :: NtransMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NTRANS,LATTICE_FCC_NTRANS), parameter :: & + FCC_INTERACTIONTRANSTRANS = reshape( [& + 1,1,1,2,2,2,2,2,2,2,2,2, & ! -----> acting + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 1,1,1,2,2,2,2,2,2,2,2,2, & ! | + 2,2,2,1,1,1,2,2,2,2,2,2, & ! v + 2,2,2,1,1,1,2,2,2,2,2,2, & ! reacting + 2,2,2,1,1,1,2,2,2,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,1,1,1,2,2,2, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1, & + 2,2,2,2,2,2,2,2,2,1,1,1 & + ],shape(FCC_INTERACTIONTRANSTRANS)) !< Trans-trans interaction types for fcc + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_TransByTrans: '//trim(structure)) + + if(structure(1:3) == 'fcc') then + interactionTypes = FCC_INTERACTIONTRANSTRANS + NtransMax = LATTICE_FCC_NTRANSSYSTEM + else + call IO_error(137,ext_msg='lattice_interaction_TransByTrans: '//trim(structure)) + end if + + interactionMatrix = buildInteraction(Ntrans,Ntrans,NtransMax,NtransMax,interactionValues,interactionTypes) + end function lattice_interaction_TransByTrans - - + + !-------------------------------------------------------------------------------------------------- !> @brief Slip-twin interaction matrix !> details only active slip and twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_SlipByTwin(Nslip,Ntwin,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family - Ntwin !< number of active twin systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-twin interaction - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(sum(Ntwin),sum(Nslip)) :: interactionMatrix - - integer, dimension(:), allocatable :: NslipMax, & - NtwinMax - integer, dimension(:,:), allocatable :: interactionTypes - - integer, dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NSLIP), parameter :: & - FCC_INTERACTIONSLIPTWIN = reshape( [& - 1,1,1,3,3,3,2,2,2,3,3,3, & ! -----> twin - 1,1,1,3,3,3,3,3,3,2,2,2, & ! | - 1,1,1,2,2,2,3,3,3,3,3,3, & ! | - 3,3,3,1,1,1,3,3,3,2,2,2, & ! v slip - 3,3,3,1,1,1,2,2,2,3,3,3, & - 2,2,2,1,1,1,3,3,3,3,3,3, & - 2,2,2,3,3,3,1,1,1,3,3,3, & - 3,3,3,2,2,2,1,1,1,3,3,3, & - 3,3,3,3,3,3,1,1,1,2,2,2, & - 3,3,3,2,2,2,3,3,3,1,1,1, & - 2,2,2,3,3,3,3,3,3,1,1,1, & - 3,3,3,3,3,3,2,2,2,1,1,1, & - - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4 & - ],shape(FCC_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for fcc + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family + Ntwin !< number of active twin systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-twin interaction + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(sum(Nslip),sum(Ntwin)) :: interactionMatrix + + integer, dimension(:), allocatable :: NslipMax, & + NtwinMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NTWIN,LATTICE_FCC_NSLIP), parameter :: & + FCC_INTERACTIONSLIPTWIN = reshape( [& + 1,1,1,3,3,3,2,2,2,3,3,3, & ! -----> twin (acting) + 1,1,1,3,3,3,3,3,3,2,2,2, & ! | + 1,1,1,2,2,2,3,3,3,3,3,3, & ! | + 3,3,3,1,1,1,3,3,3,2,2,2, & ! v + 3,3,3,1,1,1,2,2,2,3,3,3, & ! slip (reacting) + 2,2,2,1,1,1,3,3,3,3,3,3, & + 2,2,2,3,3,3,1,1,1,3,3,3, & + 3,3,3,2,2,2,1,1,1,3,3,3, & + 3,3,3,3,3,3,1,1,1,2,2,2, & + 3,3,3,2,2,2,3,3,3,1,1,1, & + 2,2,2,3,3,3,3,3,3,1,1,1, & + 3,3,3,3,3,3,2,2,2,1,1,1, & + + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4 & + ],shape(FCC_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for fcc !< 1: coplanar interaction !< 2: screw trace between slip system and twin habit plane (easy cross slip) !< 3: other interaction - integer, dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NSLIP), parameter :: & - BCC_INTERACTIONSLIPTWIN = reshape( [& - 3,3,3,2,2,3,3,3,3,2,3,3, & ! -----> twin - 3,3,2,3,3,2,3,3,2,3,3,3, & ! | - 3,2,3,3,3,3,2,3,3,3,3,2, & ! | - 2,3,3,3,3,3,3,2,3,3,2,3, & ! v slip - 2,3,3,3,3,3,3,2,3,3,2,3, & - 3,3,2,3,3,2,3,3,2,3,3,3, & - 3,2,3,3,3,3,2,3,3,3,3,2, & - 3,3,3,2,2,3,3,3,3,2,3,3, & - 2,3,3,3,3,3,3,2,3,3,2,3, & - 3,3,3,2,2,3,3,3,3,2,3,3, & - 3,2,3,3,3,3,2,3,3,3,3,2, & - 3,3,2,3,3,2,3,3,2,3,3,3, & + integer, dimension(LATTICE_BCC_NTWIN,LATTICE_BCC_NSLIP), parameter :: & + BCC_INTERACTIONSLIPTWIN = reshape( [& + 3,3,3,2,2,3,3,3,3,2,3,3, & ! -----> twin (acting) + 3,3,2,3,3,2,3,3,2,3,3,3, & ! | + 3,2,3,3,3,3,2,3,3,3,3,2, & ! | + 2,3,3,3,3,3,3,2,3,3,2,3, & ! v + 2,3,3,3,3,3,3,2,3,3,2,3, & ! slip (reacting) + 3,3,2,3,3,2,3,3,2,3,3,3, & + 3,2,3,3,3,3,2,3,3,3,3,2, & + 3,3,3,2,2,3,3,3,3,2,3,3, & + 2,3,3,3,3,3,3,2,3,3,2,3, & + 3,3,3,2,2,3,3,3,3,2,3,3, & + 3,2,3,3,3,3,2,3,3,3,3,2, & + 3,3,2,3,3,2,3,3,2,3,3,3, & + ! + 1,3,3,3,3,3,3,2,3,3,2,3, & + 3,1,3,3,3,3,2,3,3,3,3,2, & + 3,3,1,3,3,2,3,3,2,3,3,3, & + 3,3,3,1,2,3,3,3,3,2,3,3, & + 3,3,3,2,1,3,3,3,3,2,3,3, & + 3,3,2,3,3,1,3,3,2,3,3,3, & + 3,2,3,3,3,3,1,3,3,3,3,2, & + 2,3,3,3,3,3,3,1,3,3,2,3, & + 3,3,2,3,3,2,3,3,1,3,3,3, & + 3,3,3,2,2,3,3,3,3,1,3,3, & + 2,3,3,3,3,3,3,2,3,3,1,3, & + 3,2,3,3,3,3,2,3,3,3,3,1 & + ],shape(BCC_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for bcc + !< 1: coplanar interaction + !< 2: screw trace between slip system and twin habit plane (easy cross slip) + !< 3: other interaction + integer, dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NSLIP), parameter :: & + HEX_INTERACTIONSLIPTWIN = reshape( [& + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! ----> twin (acting) + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | + ! v + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & ! slip (reacting) + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & ! - 1,3,3,3,3,3,3,2,3,3,2,3, & - 3,1,3,3,3,3,2,3,3,3,3,2, & - 3,3,1,3,3,2,3,3,2,3,3,3, & - 3,3,3,1,2,3,3,3,3,2,3,3, & - 3,3,3,2,1,3,3,3,3,2,3,3, & - 3,3,2,3,3,1,3,3,2,3,3,3, & - 3,2,3,3,3,3,1,3,3,3,3,2, & - 2,3,3,3,3,3,3,1,3,3,2,3, & - 3,3,2,3,3,2,3,3,1,3,3,3, & - 3,3,3,2,2,3,3,3,3,1,3,3, & - 2,3,3,3,3,3,3,2,3,3,1,3, & - 3,2,3,3,3,3,2,3,3,3,3,1 & - ],shape(BCC_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for bcc - !< 1: coplanar interaction - !< 2: screw trace between slip system and twin habit plane (easy cross slip) - !< 3: other interaction - integer, dimension(LATTICE_HEX_NTWIN,LATTICE_HEX_NSLIP), parameter :: & - HEX_INTERACTIONSLIPTWIN = reshape( [& - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! ----> twin - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & ! | - ! v - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & ! slip - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, & - ! - 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & - 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & - 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & - ! - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & - ! - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & - ! - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & - 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24 & - ! - ],shape(HEX_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for hex - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_SlipByTwin: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - interactionTypes = FCC_INTERACTIONSLIPTWIN - NslipMax = LATTICE_FCC_NSLIPSYSTEM - NtwinMax = LATTICE_FCC_NTWINSYSTEM - case('bcc') - interactionTypes = BCC_INTERACTIONSLIPTWIN - NslipMax = LATTICE_BCC_NSLIPSYSTEM - NtwinMax = LATTICE_BCC_NTWINSYSTEM - case('hex') - interactionTypes = HEX_INTERACTIONSLIPTWIN - NslipMax = LATTICE_HEX_NSLIPSYSTEM - NtwinMax = LATTICE_HEX_NTWINSYSTEM - case default - call IO_error(137,ext_msg='lattice_interaction_SlipByTwin: '//trim(structure)) - end select - - interactionMatrix = buildInteraction(Ntwin,Nslip,NtwinMax,NslipMax,interactionValues,interactionTypes) - + 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & + 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & + 9, 9, 9, 9, 9, 9, 10,10,10,10,10,10, 11,11,11,11,11,11, 12,12,12,12,12,12, & + ! + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + 13,13,13,13,13,13, 14,14,14,14,14,14, 15,15,15,15,15,15, 16,16,16,16,16,16, & + ! + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + 17,17,17,17,17,17, 18,18,18,18,18,18, 19,19,19,19,19,19, 20,20,20,20,20,20, & + ! + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24, & + 21,21,21,21,21,21, 22,22,22,22,22,22, 23,23,23,23,23,23, 24,24,24,24,24,24 & + ! + ],shape(HEX_INTERACTIONSLIPTWIN)) !< Slip-twin interaction types for hex + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_SlipByTwin: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + interactionTypes = FCC_INTERACTIONSLIPTWIN + NslipMax = LATTICE_FCC_NSLIPSYSTEM + NtwinMax = LATTICE_FCC_NTWINSYSTEM + case('bcc') + interactionTypes = BCC_INTERACTIONSLIPTWIN + NslipMax = LATTICE_BCC_NSLIPSYSTEM + NtwinMax = LATTICE_BCC_NTWINSYSTEM + case('hex') + interactionTypes = HEX_INTERACTIONSLIPTWIN + NslipMax = LATTICE_HEX_NSLIPSYSTEM + NtwinMax = LATTICE_HEX_NTWINSYSTEM + case default + call IO_error(137,ext_msg='lattice_interaction_SlipByTwin: '//trim(structure)) + end select + + interactionMatrix = buildInteraction(Nslip,Ntwin,NslipMax,NtwinMax,interactionValues,interactionTypes) + end function lattice_interaction_SlipByTwin - - + + !-------------------------------------------------------------------------------------------------- !> @brief Slip-trans interaction matrix !> details only active slip and trans systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_SlipByTrans(Nslip,Ntrans,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family - Ntrans !< number of active trans systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-trans interaction - character(len=*), intent(in) :: structure !< lattice structure (parent crystal) - real(pReal), dimension(sum(Ntrans),sum(Nslip)) :: interactionMatrix - - integer, dimension(:), allocatable :: NslipMax, & - NtransMax - integer, dimension(:,:), allocatable :: interactionTypes - - integer, dimension(LATTICE_FCC_NTRANS,LATTICE_FCC_NSLIP), parameter :: & - FCC_INTERACTIONSLIPTRANS = reshape( [& - 1,1,1,3,3,3,2,2,2,3,3,3, & ! -----> trans - 1,1,1,3,3,3,3,3,3,2,2,2, & ! | - 1,1,1,2,2,2,3,3,3,3,3,3, & ! | - 3,3,3,1,1,1,3,3,3,2,2,2, & ! v slip - 3,3,3,1,1,1,2,2,2,3,3,3, & - 2,2,2,1,1,1,3,3,3,3,3,3, & - 2,2,2,3,3,3,1,1,1,3,3,3, & - 3,3,3,2,2,2,1,1,1,3,3,3, & - 3,3,3,3,3,3,1,1,1,2,2,2, & - 3,3,3,2,2,2,3,3,3,1,1,1, & - 2,2,2,3,3,3,3,3,3,1,1,1, & - 3,3,3,3,3,3,2,2,2,1,1,1, & - - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4, & - 4,4,4,4,4,4,4,4,4,4,4,4 & - ],shape(FCC_INTERACTIONSLIPTRANS)) !< Slip-trans interaction types for fcc - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_SlipByTrans: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - interactionTypes = FCC_INTERACTIONSLIPTRANS - NslipMax = LATTICE_FCC_NSLIPSYSTEM - NtransMax = LATTICE_FCC_NTRANSSYSTEM - case default - call IO_error(137,ext_msg='lattice_interaction_SlipByTrans: '//trim(structure)) - end select - - interactionMatrix = buildInteraction(Ntrans,Nslip,NtransMax,NslipMax,interactionValues,interactionTypes) - -end function lattice_interaction_SlipByTrans - - + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Nslip, & !< number of active slip systems per family + Ntrans !< number of active trans systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for slip-trans interaction + character(len=*), intent(in) :: structure !< lattice structure (parent crystal) + real(pReal), dimension(sum(Nslip),sum(Ntrans)) :: interactionMatrix + + integer, dimension(:), allocatable :: NslipMax, & + NtransMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NTRANS,LATTICE_FCC_NSLIP), parameter :: & + FCC_INTERACTIONSLIPTRANS = reshape( [& + 1,1,1,3,3,3,2,2,2,3,3,3, & ! -----> trans (acting) + 1,1,1,3,3,3,3,3,3,2,2,2, & ! | + 1,1,1,2,2,2,3,3,3,3,3,3, & ! | + 3,3,3,1,1,1,3,3,3,2,2,2, & ! v + 3,3,3,1,1,1,2,2,2,3,3,3, & ! slip (reacting) + 2,2,2,1,1,1,3,3,3,3,3,3, & + 2,2,2,3,3,3,1,1,1,3,3,3, & + 3,3,3,2,2,2,1,1,1,3,3,3, & + 3,3,3,3,3,3,1,1,1,2,2,2, & + 3,3,3,2,2,2,3,3,3,1,1,1, & + 2,2,2,3,3,3,3,3,3,1,1,1, & + 3,3,3,3,3,3,2,2,2,1,1,1, & + + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4, & + 4,4,4,4,4,4,4,4,4,4,4,4 & + ],shape(FCC_INTERACTIONSLIPTRANS)) !< Slip-trans interaction types for fcc + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_SlipByTrans: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + interactionTypes = FCC_INTERACTIONSLIPTRANS + NslipMax = LATTICE_FCC_NSLIPSYSTEM + NtransMax = LATTICE_FCC_NTRANSSYSTEM + case default + call IO_error(137,ext_msg='lattice_interaction_SlipByTrans: '//trim(structure)) + end select + + interactionMatrix = buildInteraction(Nslip,Ntrans,NslipMax,NtransMax,interactionValues,interactionTypes) + + end function lattice_interaction_SlipByTrans + + !-------------------------------------------------------------------------------------------------- !> @brief Twin-slip interaction matrix !> details only active twin and slip systems are considered !-------------------------------------------------------------------------------------------------- function lattice_interaction_TwinBySlip(Ntwin,Nslip,interactionValues,structure) result(interactionMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ntwin, & !< number of active twin systems per family - Nslip !< number of active slip systems per family - real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), dimension(sum(Nslip),sum(Ntwin)) :: interactionMatrix - - integer, dimension(:), allocatable :: NtwinMax, & - NslipMax - integer, dimension(:,:), allocatable :: interactionTypes - - integer, dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NTWIN), parameter :: & - FCC_INTERACTIONTWINSLIP = 1 !< Twin-Slip interaction types for fcc - - integer, dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NTWIN), parameter :: & - BCC_INTERACTIONTWINSLIP = 1 !< Twin-slip interaction types for bcc - - integer, dimension(LATTICE_HEX_NSLIP,LATTICE_HEX_NTWIN), parameter :: & - HEX_INTERACTIONTWINSLIP = reshape( [& - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! ----> slip - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! v - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! twin - 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & - ! - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & - ! - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & - ! - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & - 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24 & - ],shape(HEX_INTERACTIONTWINSLIP)) !< Twin-twin interaction types for hex - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_interaction_TwinBySlip: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - interactionTypes = FCC_INTERACTIONTWINSLIP - NtwinMax = LATTICE_FCC_NTWINSYSTEM - NslipMax = LATTICE_FCC_NSLIPSYSTEM - case('bcc') - interactionTypes = BCC_INTERACTIONTWINSLIP - NtwinMax = LATTICE_BCC_NTWINSYSTEM - NslipMax = LATTICE_BCC_NSLIPSYSTEM - case('hex') - interactionTypes = HEX_INTERACTIONTWINSLIP - NtwinMax = LATTICE_HEX_NTWINSYSTEM - NslipMax = LATTICE_HEX_NSLIPSYSTEM - case default - call IO_error(137,ext_msg='lattice_interaction_TwinBySlip: '//trim(structure)) - end select - - interactionMatrix = buildInteraction(Nslip,Ntwin,NslipMax,NtwinMax,interactionValues,interactionTypes) - + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ntwin, & !< number of active twin systems per family + Nslip !< number of active slip systems per family + real(pReal), dimension(:), intent(in) :: interactionValues !< values for twin-twin interaction + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), dimension(sum(Ntwin),sum(Nslip)) :: interactionMatrix + + integer, dimension(:), allocatable :: NtwinMax, & + NslipMax + integer, dimension(:,:), allocatable :: interactionTypes + + integer, dimension(LATTICE_FCC_NSLIP,LATTICE_FCC_NTWIN), parameter :: & + FCC_INTERACTIONTWINSLIP = 1 !< Twin-slip interaction types for fcc + + integer, dimension(LATTICE_BCC_NSLIP,LATTICE_BCC_NTWIN), parameter :: & + BCC_INTERACTIONTWINSLIP = 1 !< Twin-slip interaction types for bcc + + integer, dimension(LATTICE_HEX_NSLIP,LATTICE_HEX_NTWIN), parameter :: & + HEX_INTERACTIONTWINSLIP = reshape( [& + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! ----> slip (acting) + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! | + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! v + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & ! twin (reacting) + 1, 1, 1, 5, 5, 5, 9, 9, 9, 13,13,13,13,13,13, 17,17,17,17,17,17,17,17,17,17,17,17, 21,21,21,21,21,21, & + ! + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + 2, 2, 2, 6, 6, 6, 10,10,10, 14,14,14,14,14,14, 18,18,18,18,18,18,18,18,18,18,18,18, 22,22,22,22,22,22, & + ! + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + 3, 3, 3, 7, 7, 7, 11,11,11, 15,15,15,15,15,15, 19,19,19,19,19,19,19,19,19,19,19,19, 23,23,23,23,23,23, & + ! + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24, & + 4, 4, 4, 8, 8, 8, 12,12,12, 16,16,16,16,16,16, 20,20,20,20,20,20,20,20,20,20,20,20, 24,24,24,24,24,24 & + ],shape(HEX_INTERACTIONTWINSLIP)) !< Twin-slip interaction types for hex + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_interaction_TwinBySlip: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + interactionTypes = FCC_INTERACTIONTWINSLIP + NtwinMax = LATTICE_FCC_NTWINSYSTEM + NslipMax = LATTICE_FCC_NSLIPSYSTEM + case('bcc') + interactionTypes = BCC_INTERACTIONTWINSLIP + NtwinMax = LATTICE_BCC_NTWINSYSTEM + NslipMax = LATTICE_BCC_NSLIPSYSTEM + case('hex') + interactionTypes = HEX_INTERACTIONTWINSLIP + NtwinMax = LATTICE_HEX_NTWINSYSTEM + NslipMax = LATTICE_HEX_NSLIPSYSTEM + case default + call IO_error(137,ext_msg='lattice_interaction_TwinBySlip: '//trim(structure)) + end select + + interactionMatrix = buildInteraction(Ntwin,Nslip,NtwinMax,NslipMax,interactionValues,interactionTypes) + end function lattice_interaction_TwinBySlip - - + + !-------------------------------------------------------------------------------------------------- !> @brief Schmid matrix for slip !> details only active slip systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_slip(Nslip,structure,cOverA) result(SchmidMatrix) - use prec, only: & - tol_math_check - use IO, only: & - IO_error - use math, only: & - math_trace33, & - math_outer - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA - real(pReal), dimension(3,3,sum(Nslip)) :: SchmidMatrix - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - real(pReal), dimension(:,:), allocatable :: slipSystems - integer, dimension(:), allocatable :: NslipMax - integer :: i + use prec, only: & + tol_math_check + use IO, only: & + IO_error + use math, only: & + math_trace33, & + math_outer + + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA + real(pReal), dimension(3,3,sum(Nslip)) :: SchmidMatrix + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + real(pReal), dimension(:,:), allocatable :: slipSystems + integer, dimension(:), allocatable :: NslipMax + integer :: i + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + NslipMax = LATTICE_FCC_NSLIPSYSTEM + slipSystems = LATTICE_FCC_SYSTEMSLIP + case('bcc') + NslipMax = LATTICE_BCC_NSLIPSYSTEM + slipSystems = LATTICE_BCC_SYSTEMSLIP + case('hex') + NslipMax = LATTICE_HEX_NSLIPSYSTEM + slipSystems = LATTICE_HEX_SYSTEMSLIP + case('bct') + NslipMax = LATTICE_BCT_NSLIPSYSTEM + slipSystems = LATTICE_BCT_SYSTEMSLIP + case default + call IO_error(137,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure)) + end select + + if (any(NslipMax(1:size(Nslip)) - Nslip < 0)) & + call IO_error(145,ext_msg='Nslip '//trim(structure)) + if (any(Nslip < 0)) & + call IO_error(144,ext_msg='Nslip '//trim(structure)) + + coordinateSystem = buildCoordinateSystem(Nslip,NslipMax,slipSystems,structure,cOverA) + + do i = 1, sum(Nslip) + SchmidMatrix(1:3,1:3,i) = math_outer(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) + if (abs(math_trace33(SchmidMatrix(1:3,1:3,i))) > tol_math_check) & + call IO_error(0,i,ext_msg = 'dilatational Schmid matrix for slip') + enddo - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - NslipMax = LATTICE_FCC_NSLIPSYSTEM - slipSystems = LATTICE_FCC_SYSTEMSLIP - case('bcc') - NslipMax = LATTICE_BCC_NSLIPSYSTEM - slipSystems = LATTICE_BCC_SYSTEMSLIP - case('hex') - NslipMax = LATTICE_HEX_NSLIPSYSTEM - slipSystems = LATTICE_HEX_SYSTEMSLIP - case('bct') - NslipMax = LATTICE_BCT_NSLIPSYSTEM - slipSystems = LATTICE_BCT_SYSTEMSLIP - case default - call IO_error(137,ext_msg='lattice_SchmidMatrix_slip: '//trim(structure)) - end select - - if (any(NslipMax(1:size(Nslip)) - Nslip < 0)) & - call IO_error(145,ext_msg='Nslip '//trim(structure)) - if (any(Nslip < 0)) & - call IO_error(144,ext_msg='Nslip '//trim(structure)) - - coordinateSystem = buildCoordinateSystem(Nslip,NslipMax,slipSystems,structure,cOverA) - - do i = 1, sum(Nslip) - SchmidMatrix(1:3,1:3,i) = math_outer(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) - if (abs(math_trace33(SchmidMatrix(1:3,1:3,i))) > tol_math_check) & - call IO_error(0,i,ext_msg = 'dilatational Schmid matrix for slip') - enddo - end function lattice_SchmidMatrix_slip - - + + !-------------------------------------------------------------------------------------------------- !> @brief Schmid matrix for twinning !> details only active twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_twin(Ntwin,structure,cOverA) result(SchmidMatrix) - use prec, only: & - tol_math_check - use IO, only: & - IO_error - use math, only: & - math_trace33, & - math_outer - - implicit none - integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,3,sum(Ntwin)) :: SchmidMatrix - - real(pReal), dimension(3,3,sum(Ntwin)) :: coordinateSystem - real(pReal), dimension(:,:), allocatable :: twinSystems - integer, dimension(:), allocatable :: NtwinMax - integer :: i - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - NtwinMax = LATTICE_FCC_NTWINSYSTEM - twinSystems = LATTICE_FCC_SYSTEMTWIN - case('bcc') - NtwinMax = LATTICE_BCC_NTWINSYSTEM - twinSystems = LATTICE_BCC_SYSTEMTWIN - case('hex') - NtwinMax = LATTICE_HEX_NTWINSYSTEM - twinSystems = LATTICE_HEX_SYSTEMTWIN - case default - call IO_error(137,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure)) - end select - - if (any(NtwinMax(1:size(Ntwin)) - Ntwin < 0)) & - call IO_error(145,ext_msg='Ntwin '//trim(structure)) - if (any(Ntwin < 0)) & - call IO_error(144,ext_msg='Ntwin '//trim(structure)) - - coordinateSystem = buildCoordinateSystem(Ntwin,NtwinMax,twinSystems,structure,cOverA) - - do i = 1, sum(Ntwin) - SchmidMatrix(1:3,1:3,i) = math_outer(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) - if (abs(math_trace33(SchmidMatrix(1:3,1:3,i))) > tol_math_check) & - call IO_error(0,i,ext_msg = 'dilatational Schmid matrix for twin') - enddo - -end function lattice_SchmidMatrix_twin - - + use prec, only: & + tol_math_check + use IO, only: & + IO_error + use math, only: & + math_trace33, & + math_outer + + integer, dimension(:), intent(in) :: Ntwin !< number of active twin systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,3,sum(Ntwin)) :: SchmidMatrix + + real(pReal), dimension(3,3,sum(Ntwin)) :: coordinateSystem + real(pReal), dimension(:,:), allocatable :: twinSystems + integer, dimension(:), allocatable :: NtwinMax + integer :: i + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure)) + + select case(structure(1:3)) + case('fcc') + NtwinMax = LATTICE_FCC_NTWINSYSTEM + twinSystems = LATTICE_FCC_SYSTEMTWIN + case('bcc') + NtwinMax = LATTICE_BCC_NTWINSYSTEM + twinSystems = LATTICE_BCC_SYSTEMTWIN + case('hex') + NtwinMax = LATTICE_HEX_NTWINSYSTEM + twinSystems = LATTICE_HEX_SYSTEMTWIN + case default + call IO_error(137,ext_msg='lattice_SchmidMatrix_twin: '//trim(structure)) + end select + + if (any(NtwinMax(1:size(Ntwin)) - Ntwin < 0)) & + call IO_error(145,ext_msg='Ntwin '//trim(structure)) + if (any(Ntwin < 0)) & + call IO_error(144,ext_msg='Ntwin '//trim(structure)) + + coordinateSystem = buildCoordinateSystem(Ntwin,NtwinMax,twinSystems,structure,cOverA) + + do i = 1, sum(Ntwin) + SchmidMatrix(1:3,1:3,i) = math_outer(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) + if (abs(math_trace33(SchmidMatrix(1:3,1:3,i))) > tol_math_check) & + call IO_error(0,i,ext_msg = 'dilatational Schmid matrix for twin') + enddo + + end function lattice_SchmidMatrix_twin + + !-------------------------------------------------------------------------------------------------- !> @brief Schmid matrix for twinning !> details only active twin systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_trans(Ntrans,structure_target,cOverA,a_bcc,a_fcc) result(SchmidMatrix) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family - real(pReal), intent(in) :: cOverA !< c/a ratio - character(len=*), intent(in) :: structure_target !< lattice structure - real(pReal), dimension(3,3,sum(Ntrans)) :: SchmidMatrix - - real(pReal), dimension(3,3,sum(Ntrans)):: devNull - real(pReal) :: a_bcc, a_fcc - - if (len_trim(structure_target) /= 3) & - call IO_error(137,ext_msg='lattice_SchmidMatrix_trans (target): '//trim(structure_target)) - if (structure_target(1:3) /= 'bcc' .and. structure_target(1:3) /= 'hex') & - call IO_error(137,ext_msg='lattice_SchmidMatrix_trans (target): '//trim(structure_target)) - - !ToDo: add checks for CoverA_trans,a_fcc,a_bcc - - call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,cOverA,a_fcc,a_bcc) - - end function lattice_SchmidMatrix_trans - - + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ntrans !< number of active twin systems per family + real(pReal), intent(in) :: cOverA !< c/a ratio + character(len=*), intent(in) :: structure_target !< lattice structure + real(pReal), dimension(3,3,sum(Ntrans)) :: SchmidMatrix + + real(pReal), dimension(3,3,sum(Ntrans)):: devNull + real(pReal) :: a_bcc, a_fcc + + if (len_trim(structure_target) /= 3) & + call IO_error(137,ext_msg='lattice_SchmidMatrix_trans (target): '//trim(structure_target)) + if (structure_target(1:3) /= 'bcc' .and. structure_target(1:3) /= 'hex') & + call IO_error(137,ext_msg='lattice_SchmidMatrix_trans (target): '//trim(structure_target)) + + !ToDo: add checks for CoverA_trans,a_fcc,a_bcc + + call buildTransformationSystem(devNull,SchmidMatrix,Ntrans,cOverA,a_fcc,a_bcc) + +end function lattice_SchmidMatrix_trans + + !-------------------------------------------------------------------------------------------------- !> @brief Schmid matrix for cleavage !> details only active cleavage systems are considered !-------------------------------------------------------------------------------------------------- function lattice_SchmidMatrix_cleavage(Ncleavage,structure,cOverA) result(SchmidMatrix) - use math, only: & - math_outer - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix - - real(pReal), dimension(3,3,sum(Ncleavage)) :: coordinateSystem - real(pReal), dimension(:,:), allocatable :: cleavageSystems - integer, dimension(:), allocatable :: NcleavageMax - integer :: i + use math, only: & + math_outer + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: Ncleavage !< number of active cleavage systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,3,3,sum(Ncleavage)) :: SchmidMatrix + + real(pReal), dimension(3,3,sum(Ncleavage)) :: coordinateSystem + real(pReal), dimension(:,:), allocatable :: cleavageSystems + integer, dimension(:), allocatable :: NcleavageMax + integer :: i + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure)) + + select case(structure(1:3)) + case('iso') + NcleavageMax = LATTICE_ISO_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_ISO_SYSTEMCLEAVAGE + case('ort') + NcleavageMax = LATTICE_ORT_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_ORT_SYSTEMCLEAVAGE + case('fcc') + NcleavageMax = LATTICE_FCC_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_FCC_SYSTEMCLEAVAGE + case('bcc') + NcleavageMax = LATTICE_BCC_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_BCC_SYSTEMCLEAVAGE + case('hex') + NcleavageMax = LATTICE_HEX_NCLEAVAGESYSTEM + cleavageSystems = LATTICE_HEX_SYSTEMCLEAVAGE + case default + call IO_error(137,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure)) + end select + + if (any(NcleavageMax(1:size(Ncleavage)) - Ncleavage < 0)) & + call IO_error(145,ext_msg='Ncleavage '//trim(structure)) + if (any(Ncleavage < 0)) & + call IO_error(144,ext_msg='Ncleavage '//trim(structure)) + + coordinateSystem = buildCoordinateSystem(Ncleavage,NcleavageMax,cleavageSystems,structure,cOverA) + + do i = 1, sum(Ncleavage) + SchmidMatrix(1:3,1:3,1,i) = math_outer(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) + SchmidMatrix(1:3,1:3,2,i) = math_outer(coordinateSystem(1:3,3,i),coordinateSystem(1:3,2,i)) + SchmidMatrix(1:3,1:3,3,i) = math_outer(coordinateSystem(1:3,2,i),coordinateSystem(1:3,2,i)) + enddo - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure)) - - select case(structure(1:3)) - case('iso') - NcleavageMax = LATTICE_ISO_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_ISO_SYSTEMCLEAVAGE - case('ort') - NcleavageMax = LATTICE_ORT_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_ORT_SYSTEMCLEAVAGE - case('fcc') - NcleavageMax = LATTICE_FCC_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_FCC_SYSTEMCLEAVAGE - case('bcc') - NcleavageMax = LATTICE_BCC_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_BCC_SYSTEMCLEAVAGE - case('hex') - NcleavageMax = LATTICE_HEX_NCLEAVAGESYSTEM - cleavageSystems = LATTICE_HEX_SYSTEMCLEAVAGE - case default - call IO_error(137,ext_msg='lattice_SchmidMatrix_cleavage: '//trim(structure)) - end select - - if (any(NcleavageMax(1:size(Ncleavage)) - Ncleavage < 0)) & - call IO_error(145,ext_msg='Ncleavage '//trim(structure)) - if (any(Ncleavage < 0)) & - call IO_error(144,ext_msg='Ncleavage '//trim(structure)) - - coordinateSystem = buildCoordinateSystem(Ncleavage,NcleavageMax,cleavageSystems,structure,cOverA) - - do i = 1, sum(Ncleavage) - SchmidMatrix(1:3,1:3,1,i) = math_outer(coordinateSystem(1:3,1,i),coordinateSystem(1:3,2,i)) - SchmidMatrix(1:3,1:3,2,i) = math_outer(coordinateSystem(1:3,3,i),coordinateSystem(1:3,2,i)) - SchmidMatrix(1:3,1:3,3,i) = math_outer(coordinateSystem(1:3,2,i),coordinateSystem(1:3,2,i)) - enddo - end function lattice_SchmidMatrix_cleavage - - + + !-------------------------------------------------------------------------------------------------- !> @brief Slip direction of slip systems (|| b) !-------------------------------------------------------------------------------------------------- function lattice_slip_direction(Nslip,structure,cOverA) result(d) - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,sum(Nslip)) :: d - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) - d = coordinateSystem(1:3,1,1:sum(Nslip)) - + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,sum(Nslip)) :: d + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + + coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) + d = coordinateSystem(1:3,1,1:sum(Nslip)) + end function lattice_slip_direction - - + + !-------------------------------------------------------------------------------------------------- !> @brief Normal direction of slip systems (|| n) !-------------------------------------------------------------------------------------------------- function lattice_slip_normal(Nslip,structure,cOverA) result(n) - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,sum(Nslip)) :: n - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) - n = coordinateSystem(1:3,2,1:sum(Nslip)) - + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,sum(Nslip)) :: n + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + + coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) + n = coordinateSystem(1:3,2,1:sum(Nslip)) + end function lattice_slip_normal + !-------------------------------------------------------------------------------------------------- !> @brief Transverse direction of slip systems ( || t = b x n) !-------------------------------------------------------------------------------------------------- function lattice_slip_transverse(Nslip,structure,cOverA) result(t) - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,sum(Nslip)) :: t - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) - t = coordinateSystem(1:3,3,1:sum(Nslip)) - + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,sum(Nslip)) :: t + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + + coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) + t = coordinateSystem(1:3,3,1:sum(Nslip)) + end function lattice_slip_transverse - - + + !-------------------------------------------------------------------------------------------------- !> @brief Projection of the transverse direction onto the slip plane !> @details: This projection is used to calculate forest hardening for edge dislocations !-------------------------------------------------------------------------------------------------- function slipProjection_transverse(Nslip,structure,cOverA) result(projection) - use math, only: & - math_inner - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - integer :: i, j + use math, only: & + math_inner + + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + integer :: i, j + + coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) + + do i=1, sum(Nslip); do j=1, sum(Nslip) + projection(i,j) = abs(math_inner(coordinateSystem(1:3,2,i),coordinateSystem(1:3,3,j))) + enddo; enddo - coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) - - do i=1, sum(Nslip); do j=1, sum(Nslip) - projection(i,j) = abs(math_inner(coordinateSystem(1:3,2,i),coordinateSystem(1:3,3,j))) - enddo; enddo - end function slipProjection_transverse - - + + !-------------------------------------------------------------------------------------------------- !> @brief Projection of the slip direction onto the slip plane !> @details: This projection is used to calculate forest hardening for screw dislocations !-------------------------------------------------------------------------------------------------- function slipProjection_direction(Nslip,structure,cOverA) result(projection) - use math, only: & - math_inner - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection - - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - integer :: i, j + use math, only: & + math_inner + + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(sum(Nslip),sum(Nslip)) :: projection + + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + integer :: i, j + + coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) + + do i=1, sum(Nslip); do j=1, sum(Nslip) + projection(i,j) = abs(math_inner(coordinateSystem(1:3,2,i),coordinateSystem(1:3,1,j))) + enddo; enddo - coordinateSystem = coordinateSystem_slip(Nslip,structure,cOverA) - - do i=1, sum(Nslip); do j=1, sum(Nslip) - projection(i,j) = abs(math_inner(coordinateSystem(1:3,2,i),coordinateSystem(1:3,1,j))) - enddo; enddo - end function slipProjection_direction - - + + !-------------------------------------------------------------------------------------------------- !> @brief build a local coordinate system on slip systems !> @details Order: Direction, plane (normal), and common perpendicular !-------------------------------------------------------------------------------------------------- function coordinateSystem_slip(Nslip,structure,cOverA) result(coordinateSystem) - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family - character(len=*), intent(in) :: structure !< lattice structure - real(pReal), intent(in) :: cOverA !< c/a ratio - real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem - - real(pReal), dimension(:,:), allocatable :: slipSystems - integer, dimension(:), allocatable :: NslipMax - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='coordinateSystem_slip: '//trim(structure)) - - select case(structure(1:3)) - case('fcc') - NslipMax = LATTICE_FCC_NSLIPSYSTEM - slipSystems = LATTICE_FCC_SYSTEMSLIP - case('bcc') - NslipMax = LATTICE_BCC_NSLIPSYSTEM - slipSystems = LATTICE_BCC_SYSTEMSLIP - case('hex') - NslipMax = LATTICE_HEX_NSLIPSYSTEM - slipSystems = LATTICE_HEX_SYSTEMSLIP - case('bct') - NslipMax = LATTICE_BCT_NSLIPSYSTEM - slipSystems = LATTICE_BCT_SYSTEMSLIP - case default - call IO_error(137,ext_msg='coordinateSystem_slip: '//trim(structure)) - end select - - if (any(NslipMax(1:size(Nslip)) - Nslip < 0)) & - call IO_error(145,ext_msg='Nslip '//trim(structure)) - if (any(Nslip < 0)) & - call IO_error(144,ext_msg='Nslip '//trim(structure)) - - coordinateSystem = buildCoordinateSystem(Nslip,NslipMax,slipSystems,structure,cOverA) - -end function coordinateSystem_slip - - -!-------------------------------------------------------------------------------------------------- -!> @brief Populates reduced interaction matrix -!-------------------------------------------------------------------------------------------------- -function buildInteraction(acting_used,reacting_used,acting_max,reacting_max,values,matrix) use IO, only: & IO_error - implicit none - integer, dimension(:), intent(in) :: & - acting_used, & !< # of acting systems per family as specified in material.config - reacting_used, & !< # of reacting systems per family as specified in material.config - acting_max, & !< max # of acting systems per family for given lattice - reacting_max !< max # of reacting systems per family for given lattice - real(pReal), dimension(:), intent(in) :: values !< interaction values - integer, dimension(:,:), intent(in) :: matrix !< interaction types - real(pReal), dimension(sum(acting_used),sum(reacting_used)) :: buildInteraction + integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family + character(len=*), intent(in) :: structure !< lattice structure + real(pReal), intent(in) :: cOverA !< c/a ratio + real(pReal), dimension(3,3,sum(Nslip)) :: coordinateSystem + + real(pReal), dimension(:,:), allocatable :: slipSystems + integer, dimension(:), allocatable :: NslipMax - integer :: & - acting_family_index, acting_family, acting_system, & - reacting_family_index, reacting_family, reacting_system, & - i,j,k,l + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='coordinateSystem_slip: '//trim(structure)) - do acting_family = 1,size(acting_used,1) - acting_family_index = sum(acting_used(1:acting_family-1)) - do acting_system = 1,acting_used(acting_family) + select case(structure(1:3)) + case('fcc') + NslipMax = LATTICE_FCC_NSLIPSYSTEM + slipSystems = LATTICE_FCC_SYSTEMSLIP + case('bcc') + NslipMax = LATTICE_BCC_NSLIPSYSTEM + slipSystems = LATTICE_BCC_SYSTEMSLIP + case('hex') + NslipMax = LATTICE_HEX_NSLIPSYSTEM + slipSystems = LATTICE_HEX_SYSTEMSLIP + case('bct') + NslipMax = LATTICE_BCT_NSLIPSYSTEM + slipSystems = LATTICE_BCT_SYSTEMSLIP + case default + call IO_error(137,ext_msg='coordinateSystem_slip: '//trim(structure)) + end select + + if (any(NslipMax(1:size(Nslip)) - Nslip < 0)) & + call IO_error(145,ext_msg='Nslip '//trim(structure)) + if (any(Nslip < 0)) & + call IO_error(144,ext_msg='Nslip '//trim(structure)) + + coordinateSystem = buildCoordinateSystem(Nslip,NslipMax,slipSystems,structure,cOverA) + +end function coordinateSystem_slip + + +!-------------------------------------------------------------------------------------------------- +!> @brief Populates reduced interaction matrix +!-------------------------------------------------------------------------------------------------- +function buildInteraction(reacting_used,acting_used,reacting_max,acting_max,values,matrix) + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: & + reacting_used, & !< # of reacting systems per family as specified in material.config + acting_used, & !< # of acting systems per family as specified in material.config + reacting_max, & !< max # of reacting systems per family for given lattice + acting_max !< max # of acting systems per family for given lattice + real(pReal), dimension(:), intent(in) :: values !< interaction values + integer, dimension(:,:), intent(in) :: matrix !< interaction types + real(pReal), dimension(sum(reacting_used),sum(acting_used)) :: buildInteraction + + integer :: & + acting_family_index, acting_family, acting_system, & + reacting_family_index, reacting_family, reacting_system, & + i,j,k,l + + do acting_family = 1,size(acting_used,1) + acting_family_index = sum(acting_used(1:acting_family-1)) + do acting_system = 1,acting_used(acting_family) + + do reacting_family = 1,size(reacting_used,1) + reacting_family_index = sum(reacting_used(1:reacting_family-1)) + do reacting_system = 1,reacting_used(reacting_family) + + i = sum( acting_max(1: acting_family-1)) + acting_system + j = sum(reacting_max(1:reacting_family-1)) + reacting_system + + k = acting_family_index + acting_system + l = reacting_family_index + reacting_system + + if (matrix(i,j) > size(values)) call IO_error(138,ext_msg='buildInteraction') + + buildInteraction(l,k) = values(matrix(i,j)) + + enddo; enddo + enddo; enddo - do reacting_family = 1,size(reacting_used,1) - reacting_family_index = sum(reacting_used(1:reacting_family-1)) - do reacting_system = 1,reacting_used(reacting_family) - - i = sum( acting_max(1: acting_family-1)) + acting_system - j = sum(reacting_max(1:reacting_family-1)) + reacting_system - - k = acting_family_index + acting_system - l = reacting_family_index + reacting_system - - if (matrix(i,j) > size(values)) call IO_error(138,ext_msg='buildInteraction') - - buildInteraction(k,l) = values(matrix(i,j)) - - enddo; enddo - enddo; enddo - end function buildInteraction - - + + !-------------------------------------------------------------------------------------------------- !> @brief build a local coordinate system on slip, twin, trans, cleavage systems !> @details Order: Direction, plane (normal), and common perpendicular !-------------------------------------------------------------------------------------------------- function buildCoordinateSystem(active,complete,system,structure,cOverA) - use IO, only: & - IO_error - use math, only: & - math_cross - - implicit none - integer, dimension(:), intent(in) :: & - active, & - complete - real(pReal), dimension(:,:), intent(in) :: & - system - character(len=*), intent(in) :: & - structure !< lattice structure - real(pReal), intent(in) :: & - cOverA - real(pReal), dimension(3,3,sum(active)) :: & - buildCoordinateSystem - - real(pReal), dimension(3) :: & - direction, normal - integer :: & - a, & !< index of active system - c, & !< index in complete system matrix - f, & !< index of my family - s !< index of my system in current family - - if (len_trim(structure) /= 3) & - call IO_error(137,ext_msg='buildCoordinateSystem: '//trim(structure)) - if (trim(structure(1:3)) == 'bct' .and. cOverA > 2.0_pReal) & - call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(structure)) - if (trim(structure(1:3)) == 'hex' .and. (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal)) & - call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(structure)) - - a = 0 - activeFamilies: do f = 1,size(active,1) - activeSystems: do s = 1,active(f) - a = a + 1 - c = sum(complete(1:f-1))+s - - select case(trim(structure(1:3))) - - case ('fcc','bcc','iso','ort','bct') - direction = system(1:3,c) - normal = system(4:6,c) - - case ('hex') - direction = [ system(1,c)*1.5_pReal, & - (system(1,c)+2.0_pReal*system(2,c))*sqrt(0.75_pReal), & - system(4,c)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]) - normal = [ system(5,c), & - (system(5,c)+2.0_pReal*system(6,c))/sqrt(3.0_pReal), & - system(8,c)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) - - case default - call IO_error(137,ext_msg='buildCoordinateSystem: '//trim(structure)) - - end select - - buildCoordinateSystem(1:3,1,a) = direction/norm2(direction) - buildCoordinateSystem(1:3,2,a) = normal/norm2(normal) - buildCoordinateSystem(1:3,3,a) = math_cross(buildCoordinateSystem(1:3,1,a),& - buildCoordinateSystem(1:3,2,a)) - - enddo activeSystems - enddo activeFamilies - + use IO, only: & + IO_error + use math, only: & + math_cross + + integer, dimension(:), intent(in) :: & + active, & + complete + real(pReal), dimension(:,:), intent(in) :: & + system + character(len=*), intent(in) :: & + structure !< lattice structure + real(pReal), intent(in) :: & + cOverA + real(pReal), dimension(3,3,sum(active)) :: & + buildCoordinateSystem + + real(pReal), dimension(3) :: & + direction, normal + integer :: & + a, & !< index of active system + c, & !< index in complete system matrix + f, & !< index of my family + s !< index of my system in current family + + if (len_trim(structure) /= 3) & + call IO_error(137,ext_msg='buildCoordinateSystem: '//trim(structure)) + if (trim(structure(1:3)) == 'bct' .and. cOverA > 2.0_pReal) & + call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(structure)) + if (trim(structure(1:3)) == 'hex' .and. (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal)) & + call IO_error(131,ext_msg='buildCoordinateSystem:'//trim(structure)) + + a = 0 + activeFamilies: do f = 1,size(active,1) + activeSystems: do s = 1,active(f) + a = a + 1 + c = sum(complete(1:f-1))+s + + select case(trim(structure(1:3))) + + case ('fcc','bcc','iso','ort','bct') + direction = system(1:3,c) + normal = system(4:6,c) + + case ('hex') + direction = [ system(1,c)*1.5_pReal, & + (system(1,c)+2.0_pReal*system(2,c))*sqrt(0.75_pReal), & + system(4,c)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)]) + normal = [ system(5,c), & + (system(5,c)+2.0_pReal*system(6,c))/sqrt(3.0_pReal), & + system(8,c)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) + + case default + call IO_error(137,ext_msg='buildCoordinateSystem: '//trim(structure)) + + end select + + buildCoordinateSystem(1:3,1,a) = direction/norm2(direction) + buildCoordinateSystem(1:3,2,a) = normal/norm2(normal) + buildCoordinateSystem(1:3,3,a) = math_cross(buildCoordinateSystem(1:3,1,a),& + buildCoordinateSystem(1:3,2,a)) + + enddo activeSystems + enddo activeFamilies + end function buildCoordinateSystem - - + + !-------------------------------------------------------------------------------------------------- !> @brief Helper function to define transformation systems ! Needed to calculate Schmid matrix and rotated stiffness matrices. @@ -2396,139 +2370,138 @@ end function buildCoordinateSystem ! set a_bcc = 0.0 for fcc -> hex transformation !-------------------------------------------------------------------------------------------------- subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc) - use prec, only: & - dEq0 - use math, only: & - math_cross, & - math_outer, & - math_axisAngleToR, & - INRAD, & - MATH_I3 - use IO, only: & - IO_error - - implicit none - integer, dimension(:), intent(in) :: & - Ntrans - real(pReal), dimension(3,3,sum(Ntrans)), intent(out) :: & - Q, & !< Total rotation: Q = R*B - S !< Eigendeformation tensor for phase transformation - real(pReal), intent(in) :: & - cOverA, & !< c/a for target hex structure - a_bcc, & !< lattice parameter a for target bcc structure - a_fcc !< lattice parameter a for parent fcc structure - - real(pReal), dimension(3,3) :: & - R, & !< Pitsch rotation - U, & !< Bain deformation - B, & !< Rotation of fcc to Bain coordinate system - ss, sd - real(pReal), dimension(3) :: & - x, y, z - integer :: & - i - real(pReal), dimension(3+3,LATTICE_FCC_NTRANS), parameter :: & - LATTICE_FCCTOHEX_SYSTEMTRANS = reshape(real( [& - -2, 1, 1, 1, 1, 1, & - 1,-2, 1, 1, 1, 1, & - 1, 1,-2, 1, 1, 1, & - 2,-1, 1, -1,-1, 1, & - -1, 2, 1, -1,-1, 1, & - -1,-1,-2, -1,-1, 1, & - -2,-1,-1, 1,-1,-1, & - 1, 2,-1, 1,-1,-1, & - 1,-1, 2, 1,-1,-1, & - 2, 1,-1, -1, 1,-1, & - -1,-2,-1, -1, 1,-1, & - -1, 1, 2, -1, 1,-1 & - ],pReal),shape(LATTICE_FCCTOHEX_SYSTEMTRANS)) - real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter :: & - LATTICE_FCCTOBCC_SYSTEMTRANS = reshape([& - 0.0, 1.0, 0.0, 10.26, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) - 0.0, 1.0, 0.0, -10.26, & - 0.0, 0.0, 1.0, 10.26, & - 0.0, 0.0, 1.0, -10.26, & - 1.0, 0.0, 0.0, 10.26, & - 1.0, 0.0, 0.0, -10.26, & - 0.0, 0.0, 1.0, 10.26, & - 0.0, 0.0, 1.0, -10.26, & - 1.0, 0.0, 0.0, 10.26, & - 1.0, 0.0, 0.0, -10.26, & - 0.0, 1.0, 0.0, 10.26, & - 0.0, 1.0, 0.0, -10.26 & - ],shape(LATTICE_FCCTOBCC_SYSTEMTRANS)) - - integer, dimension(9,LATTICE_fcc_Ntrans), parameter :: & - LATTICE_FCCTOBCC_BAINVARIANT = reshape( [& - 1, 0, 0, 0, 1, 0, 0, 0, 1, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) - 1, 0, 0, 0, 1, 0, 0, 0, 1, & - 1, 0, 0, 0, 1, 0, 0, 0, 1, & - 1, 0, 0, 0, 1, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 1, 0, 1, 0, 0, 0, 0, 1, & - 0, 0, 1, 1, 0, 0, 0, 1, 0, & - 0, 0, 1, 1, 0, 0, 0, 1, 0, & - 0, 0, 1, 1, 0, 0, 0, 1, 0, & - 0, 0, 1, 1, 0, 0, 0, 1, 0 & - ],shape(LATTICE_FCCTOBCC_BAINVARIANT)) - - real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter :: & - LATTICE_FCCTOBCC_BAINROT = reshape([& - 1.0, 0.0, 0.0, 45.0, & ! Rotate fcc austensite to bain variant - 1.0, 0.0, 0.0, 45.0, & - 1.0, 0.0, 0.0, 45.0, & - 1.0, 0.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 1.0, 0.0, 45.0, & - 0.0, 0.0, 1.0, 45.0, & - 0.0, 0.0, 1.0, 45.0, & - 0.0, 0.0, 1.0, 45.0, & - 0.0, 0.0, 1.0, 45.0 & - ],shape(LATTICE_FCCTOBCC_BAINROT)) - - if (size(Ntrans) < 1 .or. size(Ntrans) > 1) & - call IO_error(0) !ToDo: define error - - if (a_bcc > 0.0_pReal .and. dEq0(cOverA)) then ! fcc -> bcc transformation - do i = 1,sum(Ntrans) - R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & - lattice_fccTobcc_systemTrans(4,i)*INRAD) - B = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & - lattice_fccTobcc_bainRot(4,i)*INRAD) - x = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) - y = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) - z = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) - - U = (a_bcc/a_fcc)*math_outer(x,x) & - + (a_bcc/a_fcc)*math_outer(y,y) * sqrt(2.0_pReal) & - + (a_bcc/a_fcc)*math_outer(z,z) * sqrt(2.0_pReal) - Q(1:3,1:3,i) = matmul(R,B) - S(1:3,1:3,i) = matmul(R,U) - MATH_I3 - enddo - elseif (cOverA > 0.0_pReal .and. dEq0(a_bcc)) then ! fcc -> hex transformation - ss = MATH_I3 - sd = MATH_I3 - ss(1,3) = sqrt(2.0_pReal)/4.0_pReal - if (cOverA > 1.0_pReal .and. cOverA < 2.0_pReal) & - sd(3,3) = cOverA/sqrt(8.0_pReal/3.0_pReal) - - do i = 1,sum(Ntrans) - x = lattice_fccTohex_systemTrans(1:3,i)/norm2(lattice_fccTohex_systemTrans(1:3,i)) - z = lattice_fccTohex_systemTrans(4:6,i)/norm2(lattice_fccTohex_systemTrans(4:6,i)) - y = -math_cross(x,z) - Q(1:3,1,i) = x - Q(1:3,2,i) = y - Q(1:3,3,i) = z - S(1:3,1:3,i) = matmul(Q(1:3,1:3,i), matmul(matmul(sd,ss), transpose(Q(1:3,1:3,i)))) - MATH_I3 ! ToDo: This is of interest for the Schmid matrix only - enddo - else - call IO_error(0) !ToDo: define error - endif - + use prec, only: & + dEq0 + use math, only: & + math_cross, & + math_outer, & + math_axisAngleToR, & + INRAD, & + MATH_I3 + use IO, only: & + IO_error + + integer, dimension(:), intent(in) :: & + Ntrans + real(pReal), dimension(3,3,sum(Ntrans)), intent(out) :: & + Q, & !< Total rotation: Q = R*B + S !< Eigendeformation tensor for phase transformation + real(pReal), intent(in) :: & + cOverA, & !< c/a for target hex structure + a_bcc, & !< lattice parameter a for target bcc structure + a_fcc !< lattice parameter a for parent fcc structure + + real(pReal), dimension(3,3) :: & + R, & !< Pitsch rotation + U, & !< Bain deformation + B, & !< Rotation of fcc to Bain coordinate system + ss, sd + real(pReal), dimension(3) :: & + x, y, z + integer :: & + i + real(pReal), dimension(3+3,LATTICE_FCC_NTRANS), parameter :: & + LATTICE_FCCTOHEX_SYSTEMTRANS = reshape(real( [& + -2, 1, 1, 1, 1, 1, & + 1,-2, 1, 1, 1, 1, & + 1, 1,-2, 1, 1, 1, & + 2,-1, 1, -1,-1, 1, & + -1, 2, 1, -1,-1, 1, & + -1,-1,-2, -1,-1, 1, & + -2,-1,-1, 1,-1,-1, & + 1, 2,-1, 1,-1,-1, & + 1,-1, 2, 1,-1,-1, & + 2, 1,-1, -1, 1,-1, & + -1,-2,-1, -1, 1,-1, & + -1, 1, 2, -1, 1,-1 & + ],pReal),shape(LATTICE_FCCTOHEX_SYSTEMTRANS)) + real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter :: & + LATTICE_FCCTOBCC_SYSTEMTRANS = reshape([& + 0.0, 1.0, 0.0, 10.26, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) + 0.0, 1.0, 0.0, -10.26, & + 0.0, 0.0, 1.0, 10.26, & + 0.0, 0.0, 1.0, -10.26, & + 1.0, 0.0, 0.0, 10.26, & + 1.0, 0.0, 0.0, -10.26, & + 0.0, 0.0, 1.0, 10.26, & + 0.0, 0.0, 1.0, -10.26, & + 1.0, 0.0, 0.0, 10.26, & + 1.0, 0.0, 0.0, -10.26, & + 0.0, 1.0, 0.0, 10.26, & + 0.0, 1.0, 0.0, -10.26 & + ],shape(LATTICE_FCCTOBCC_SYSTEMTRANS)) + + integer, dimension(9,LATTICE_fcc_Ntrans), parameter :: & + LATTICE_FCCTOBCC_BAINVARIANT = reshape( [& + 1, 0, 0, 0, 1, 0, 0, 0, 1, & ! Pitsch OR (Ma & Hartmaier 2014, Table 3) + 1, 0, 0, 0, 1, 0, 0, 0, 1, & + 1, 0, 0, 0, 1, 0, 0, 0, 1, & + 1, 0, 0, 0, 1, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 1, 0, 1, 0, 0, 0, 0, 1, & + 0, 0, 1, 1, 0, 0, 0, 1, 0, & + 0, 0, 1, 1, 0, 0, 0, 1, 0, & + 0, 0, 1, 1, 0, 0, 0, 1, 0, & + 0, 0, 1, 1, 0, 0, 0, 1, 0 & + ],shape(LATTICE_FCCTOBCC_BAINVARIANT)) + + real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter :: & + LATTICE_FCCTOBCC_BAINROT = reshape([& + 1.0, 0.0, 0.0, 45.0, & ! Rotate fcc austensite to bain variant + 1.0, 0.0, 0.0, 45.0, & + 1.0, 0.0, 0.0, 45.0, & + 1.0, 0.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 1.0, 0.0, 45.0, & + 0.0, 0.0, 1.0, 45.0, & + 0.0, 0.0, 1.0, 45.0, & + 0.0, 0.0, 1.0, 45.0, & + 0.0, 0.0, 1.0, 45.0 & + ],shape(LATTICE_FCCTOBCC_BAINROT)) + + if (size(Ntrans) < 1 .or. size(Ntrans) > 1) & + call IO_error(0) !ToDo: define error + + if (a_bcc > 0.0_pReal .and. dEq0(cOverA)) then ! fcc -> bcc transformation + do i = 1,sum(Ntrans) + R = math_axisAngleToR(lattice_fccTobcc_systemTrans(1:3,i), & + lattice_fccTobcc_systemTrans(4,i)*INRAD) + B = math_axisAngleToR(lattice_fccTobcc_bainRot(1:3,i), & + lattice_fccTobcc_bainRot(4,i)*INRAD) + x = real(LATTICE_fccTobcc_bainVariant(1:3,i),pReal) + y = real(LATTICE_fccTobcc_bainVariant(4:6,i),pReal) + z = real(LATTICE_fccTobcc_bainVariant(7:9,i),pReal) + + U = (a_bcc/a_fcc)*math_outer(x,x) & + + (a_bcc/a_fcc)*math_outer(y,y) * sqrt(2.0_pReal) & + + (a_bcc/a_fcc)*math_outer(z,z) * sqrt(2.0_pReal) + Q(1:3,1:3,i) = matmul(R,B) + S(1:3,1:3,i) = matmul(R,U) - MATH_I3 + enddo + elseif (cOverA > 0.0_pReal .and. dEq0(a_bcc)) then ! fcc -> hex transformation + ss = MATH_I3 + sd = MATH_I3 + ss(1,3) = sqrt(2.0_pReal)/4.0_pReal + if (cOverA > 1.0_pReal .and. cOverA < 2.0_pReal) & + sd(3,3) = cOverA/sqrt(8.0_pReal/3.0_pReal) + + do i = 1,sum(Ntrans) + x = lattice_fccTohex_systemTrans(1:3,i)/norm2(lattice_fccTohex_systemTrans(1:3,i)) + z = lattice_fccTohex_systemTrans(4:6,i)/norm2(lattice_fccTohex_systemTrans(4:6,i)) + y = -math_cross(x,z) + Q(1:3,1,i) = x + Q(1:3,2,i) = y + Q(1:3,3,i) = z + S(1:3,1:3,i) = matmul(Q(1:3,1:3,i), matmul(matmul(sd,ss), transpose(Q(1:3,1:3,i)))) - MATH_I3 ! ToDo: This is of interest for the Schmid matrix only + enddo + else + call IO_error(0) !ToDo: define error + endif + end subroutine buildTransformationSystem - + end module lattice diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 19df4bdce..13956dd59 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -134,7 +134,6 @@ subroutine plastic_disloUCLA_init() config_phase use lattice - implicit none integer :: & Ninstance, & p, i, & @@ -208,9 +207,9 @@ subroutine plastic_disloUCLA_init() prm%nonSchmid_neg = prm%Schmid endif - prm%h_sl_sl = transpose(lattice_interaction_SlipBySlip(prm%N_sl, & + prm%h_sl_sl = lattice_interaction_SlipBySlip(prm%N_sl, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%forestProjectionEdge = lattice_forestProjection(prm%N_sl,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) @@ -361,7 +360,6 @@ end subroutine plastic_disloUCLA_init !-------------------------------------------------------------------------------------------------- pure subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dMp, & Mp,T,instance,of) - implicit none real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & @@ -411,7 +409,6 @@ subroutine plastic_disloUCLA_dotState(Mp,T,instance,of) PI, & math_clip - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -472,7 +469,6 @@ end subroutine plastic_disloUCLA_dotState !-------------------------------------------------------------------------------------------------- subroutine plastic_disloUCLA_dependentState(instance,of) - implicit none integer, intent(in) :: & instance, & of @@ -507,7 +503,6 @@ function plastic_disloUCLA_postResults(Mp,T,instance,of) result(postResults) PI, & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -616,7 +611,6 @@ pure subroutine kinetics(Mp,T,instance,of, & PI, & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 8e52b3f41..858199ada 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -198,7 +198,6 @@ subroutine plastic_dislotwin_init config_phase use lattice - implicit none integer :: & Ninstance, & p, i, & @@ -268,9 +267,9 @@ subroutine plastic_dislotwin_init slipActive: if (prm%sum_N_sl > 0) then prm%P_sl = lattice_SchmidMatrix_slip(prm%N_sl,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%h_sl_sl = transpose(lattice_interaction_SlipBySlip(prm%N_sl, & + prm%h_sl_sl = lattice_interaction_SlipBySlip(prm%N_sl, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%forestProjection = lattice_forestProjection (prm%N_sl,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) @@ -332,9 +331,9 @@ subroutine plastic_dislotwin_init if (prm%sum_N_tw > 0) then prm%P_tw = lattice_SchmidMatrix_twin(prm%N_tw,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%h_tw_tw = transpose(lattice_interaction_TwinByTwin(prm%N_tw,& + prm%h_tw_tw = lattice_interaction_TwinByTwin(prm%N_tw,& config%getFloats('interaction_twintwin'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%b_tw = config%getFloats('twinburgers', requiredSize=size(prm%N_tw)) prm%t_tw = config%getFloats('twinsize', requiredSize=size(prm%N_tw)) @@ -374,15 +373,15 @@ subroutine plastic_dislotwin_init prm%b_tr = config%getFloats('transburgers') prm%b_tr = math_expand(prm%b_tr,prm%N_tr) - prm%h = config%getFloat('transstackheight', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%i_tr = config%getFloat('cmfptrans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%gamma_fcc_hex = config%getFloat('deltag') - prm%xc_trans = config%getFloat('xc_trans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? - prm%L_tr = config%getFloat('l0_trans') + prm%h = config%getFloat('transstackheight', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%i_tr = config%getFloat('cmfptrans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%gamma_fcc_hex = config%getFloat('deltag') + prm%xc_trans = config%getFloat('xc_trans', defaultVal=0.0_pReal) ! ToDo: How to handle that??? + prm%L_tr = config%getFloat('l0_trans') - prm%h_tr_tr = transpose(lattice_interaction_TransByTrans(prm%N_tr,& - config%getFloats('interaction_transtrans'), & - config%getString('lattice_structure'))) + prm%h_tr_tr = lattice_interaction_TransByTrans(prm%N_tr,& + config%getFloats('interaction_transtrans'), & + config%getString('lattice_structure')) prm%C66_tr = lattice_C66_trans(prm%N_tr,prm%C66, & config%getString('trans_lattice_structure'), & @@ -390,7 +389,7 @@ subroutine plastic_dislotwin_init config%getFloat('a_bcc', defaultVal=0.0_pReal), & config%getFloat('a_fcc', defaultVal=0.0_pReal)) - prm%P_tr = lattice_SchmidMatrix_trans(prm%N_tr, & + prm%P_tr = lattice_SchmidMatrix_trans(prm%N_tr, & config%getString('trans_lattice_structure'), & 0.0_pReal, & config%getFloat('a_bcc', defaultVal=0.0_pReal), & @@ -416,16 +415,16 @@ subroutine plastic_dislotwin_init endif if (prm%sum_N_sl > 0 .and. prm%sum_N_tw > 0) then - prm%h_sl_tw = transpose(lattice_interaction_SlipByTwin(prm%N_sl,prm%N_tw,& + prm%h_sl_tw = lattice_interaction_SlipByTwin(prm%N_sl,prm%N_tw,& config%getFloats('interaction_sliptwin'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) if (prm%fccTwinTransNucleation .and. prm%sum_N_tw > 12) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if N_tw is [6,6] endif if (prm%sum_N_sl > 0 .and. prm%sum_N_tr > 0) then - prm%h_sl_tr = transpose(lattice_interaction_SlipByTrans(prm%N_sl,prm%N_tr,& + prm%h_sl_tr = lattice_interaction_SlipByTrans(prm%N_sl,prm%N_tr,& config%getFloats('interaction_sliptrans'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) if (prm%fccTwinTransNucleation .and. prm%sum_N_tr > 12) write(6,*) 'mist' ! ToDo: implement better test. The model will fail also if N_tr is [6,6] endif @@ -605,7 +604,6 @@ function plastic_dislotwin_homogenizedC(ipc,ip,el) result(homogenizedC) phase_plasticityInstance, & phasememberAt - implicit none real(pReal), dimension(6,6) :: & homogenizedC integer, intent(in) :: & @@ -653,7 +651,6 @@ subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMp,Mp,T,instance,of) math_symmetric33, & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(out) :: Lp real(pReal), dimension(3,3,3,3), intent(out) :: dLp_dMp real(pReal), dimension(3,3), intent(in) :: Mp @@ -776,7 +773,6 @@ subroutine plastic_dislotwin_dotState(Mp,T,instance,of) math_mul33xx33, & PI - implicit none real(pReal), dimension(3,3), intent(in):: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -869,7 +865,6 @@ subroutine plastic_dislotwin_dependentState(T,instance,of) use math, only: & PI - implicit none integer, intent(in) :: & instance, & of @@ -987,7 +982,6 @@ function plastic_dislotwin_postResults(Mp,T,instance,of) result(postResults) PI, & math_mul33xx33 - implicit none real(pReal), dimension(3,3),intent(in) :: & Mp !< 2nd Piola Kirchhoff stress tensor in Mandel notation real(pReal), intent(in) :: & @@ -1133,7 +1127,6 @@ pure subroutine kinetics_slip(Mp,T,instance,of, & use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -1212,7 +1205,6 @@ pure subroutine kinetics_twin(Mp,T,dot_gamma_sl,instance,of,& use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & @@ -1284,7 +1276,6 @@ pure subroutine kinetics_trans(Mp,T,dot_gamma_sl,instance,of,& use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress real(pReal), intent(in) :: & diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index facfa6d80..1049dc9cf 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -108,7 +108,6 @@ subroutine plastic_isotropic_init config_phase use lattice - implicit none integer :: & Ninstance, & p, i, & @@ -259,7 +258,6 @@ subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) math_deviatoric33, & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & @@ -326,7 +324,6 @@ subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar,Tstar,instance,of) math_spherical33, & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(out) :: & Li !< inleastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & @@ -383,7 +380,6 @@ subroutine plastic_isotropic_dotState(Mp,instance,of) math_mul33xx33, & math_deviatoric33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -436,7 +432,6 @@ function plastic_isotropic_postResults(Mp,instance,of) result(postResults) math_mul33xx33, & math_deviatoric33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 04927c85b..27bae7e40 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -129,7 +129,6 @@ subroutine plastic_kinehardening_init config_phase use lattice - implicit none integer :: & Ninstance, & p, i, o, & @@ -204,9 +203,9 @@ subroutine plastic_kinehardening_init prm%nonSchmid_pos = prm%Schmid prm%nonSchmid_neg = prm%Schmid endif - prm%interaction_SlipSlip = transpose(lattice_interaction_SlipBySlip(prm%Nslip, & + prm%interaction_SlipSlip = lattice_interaction_SlipBySlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%crss0 = config%getFloats('crss0', requiredSize=size(prm%Nslip)) prm%tau1 = config%getFloats('tau1', requiredSize=size(prm%Nslip)) @@ -347,7 +346,6 @@ end subroutine plastic_kinehardening_init !-------------------------------------------------------------------------------------------------- pure subroutine plastic_kinehardening_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) - implicit none real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & @@ -390,7 +388,6 @@ end subroutine plastic_kinehardening_LpAndItsTangent !-------------------------------------------------------------------------------------------------- subroutine plastic_kinehardening_dotState(Mp,instance,of) - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -443,7 +440,6 @@ subroutine plastic_kinehardening_deltaState(Mp,instance,of) debug_levelSelective #endif - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -494,7 +490,6 @@ function plastic_kinehardening_postResults(Mp,instance,of) result(postResults) use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -608,7 +603,6 @@ pure subroutine kinetics(Mp,instance,of, & use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & diff --git a/src/plastic_none.f90 b/src/plastic_none.f90 index b73bd20ab..e34fd533b 100644 --- a/src/plastic_none.f90 +++ b/src/plastic_none.f90 @@ -5,13 +5,13 @@ !> @brief Dummy plasticity for purely elastic material !-------------------------------------------------------------------------------------------------- module plastic_none - - implicit none - private - - public :: & - plastic_none_init - + + implicit none + private + + public :: & + plastic_none_init + contains !-------------------------------------------------------------------------------------------------- @@ -19,39 +19,39 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine plastic_none_init - use debug, only: & - debug_level, & - debug_constitutive, & - debug_levelBasic - use material, only: & - phase_plasticity, & - material_allocatePlasticState, & - PLASTICITY_NONE_label, & - PLASTICITY_NONE_ID, & - material_phase, & - plasticState - - implicit none - integer :: & - Ninstance, & - p, & - NipcMyPhase - - write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_NONE_label//' init -+>>>' - - Ninstance = count(phase_plasticity == PLASTICITY_NONE_ID) - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & - write(6,'(a16,1x,i5,/)') '# instances:',Ninstance - - do p = 1, size(phase_plasticity) - if (phase_plasticity(p) /= PLASTICITY_NONE_ID) cycle - - NipcMyPhase = count(material_phase == p) - call material_allocatePlasticState(p,NipcMyPhase,0,0,0, & - 0,0,0) - plasticState(p)%sizePostResults = 0 - - enddo + use debug, only: & + debug_level, & + debug_constitutive, & + debug_levelBasic + use material, only: & + phase_plasticity, & + material_allocatePlasticState, & + PLASTICITY_NONE_label, & + PLASTICITY_NONE_ID, & + material_phase, & + plasticState + + implicit none + integer :: & + Ninstance, & + p, & + NipcMyPhase + + write(6,'(/,a)') ' <<<+- plastic_'//PLASTICITY_NONE_label//' init -+>>>' + + Ninstance = count(phase_plasticity == PLASTICITY_NONE_ID) + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + + do p = 1, size(phase_plasticity) + if (phase_plasticity(p) /= PLASTICITY_NONE_ID) cycle + + NipcMyPhase = count(material_phase == p) + call material_allocatePlasticState(p,NipcMyPhase,0,0,0, & + 0,0,0) + plasticState(p)%sizePostResults = 0 + + enddo end subroutine plastic_none_init diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index a9ef98b06..c14223045 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -260,7 +260,6 @@ subroutine plastic_nonlocal_init use config use lattice - implicit none character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer, dimension(0), parameter :: emptyIntArray = [integer::] real(pReal), dimension(0), parameter :: emptyRealArray = [real(pReal)::] @@ -751,7 +750,6 @@ subroutine plastic_nonlocal_init material_phase, & phase_plasticityInstance, & phasememberAt - implicit none integer,intent(in) ::& phase, & @@ -867,7 +865,6 @@ subroutine plastic_nonlocal_dependentState(Fe, Fp, ip, el) LATTICE_fcc_ID, & lattice_structure - implicit none integer, intent(in) :: & ip, & el @@ -1090,7 +1087,6 @@ end subroutine plastic_nonlocal_dependentState !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_kinetics(v, dv_dtau, dv_dtauNS, tau, tauNS, & tauThreshold, c, Temperature, instance, of) - implicit none integer, intent(in) :: & c, & !< dislocation character (1:edge, 2:screw) instance, of @@ -1239,7 +1235,6 @@ subroutine plastic_nonlocal_LpAndItsTangent(Lp, dLp_dMp, & phaseAt, phasememberAt, & phase_plasticityInstance - implicit none integer, intent(in) :: & ip, & !< current integration point el !< current element number @@ -1392,7 +1387,6 @@ subroutine plastic_nonlocal_deltaState(Mp,ip,el) phaseAt, phasememberAt, & phase_plasticityInstance - implicit none integer, intent(in) :: & ip, & el @@ -1553,7 +1547,6 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & LATTICE_bcc_ID, & LATTICE_fcc_ID - implicit none integer, intent(in) :: & ip, & !< current integration point el !< current element number @@ -2027,7 +2020,6 @@ subroutine plastic_nonlocal_updateCompatibility(orientation,i,e) use lattice, only: & lattice_qDisorientation - implicit none integer, intent(in) :: & i, & e @@ -2175,7 +2167,6 @@ function plastic_nonlocal_postResults(ph,instance,of) result(postResults) use material, only: & plasticState - implicit none integer, intent(in) :: & ph, & instance, & @@ -2378,7 +2369,6 @@ end function plastic_nonlocal_postResults function getRho(instance,of,ip,el) use mesh - implicit none integer, intent(in) :: instance, of,ip,el real(pReal), dimension(param(instance)%totalNslip,10) :: getRho diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index 272c4d631..f2692a489 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -129,7 +129,6 @@ subroutine plastic_phenopowerlaw_init config_phase use lattice - implicit none integer :: & Ninstance, & p, i, & @@ -203,9 +202,9 @@ subroutine plastic_phenopowerlaw_init prm%nonSchmid_pos = prm%Schmid_slip prm%nonSchmid_neg = prm%Schmid_slip endif - prm%interaction_SlipSlip = transpose(lattice_interaction_SlipBySlip(prm%Nslip, & + prm%interaction_SlipSlip = lattice_interaction_SlipBySlip(prm%Nslip, & config%getFloats('interaction_slipslip'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%xi_slip_0 = config%getFloats('tau0_slip', requiredSize=size(prm%Nslip)) prm%xi_slip_sat = config%getFloats('tausat_slip', requiredSize=size(prm%Nslip)) @@ -240,9 +239,9 @@ subroutine plastic_phenopowerlaw_init twinActive: if (prm%totalNtwin > 0) then prm%Schmid_twin = lattice_SchmidMatrix_twin(prm%Ntwin,config%getString('lattice_structure'),& config%getFloat('c/a',defaultVal=0.0_pReal)) - prm%interaction_TwinTwin = transpose(lattice_interaction_TwinByTwin(prm%Ntwin,& + prm%interaction_TwinTwin = lattice_interaction_TwinByTwin(prm%Ntwin,& config%getFloats('interaction_twintwin'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) prm%gamma_twin_char = lattice_characteristicShear_twin(prm%Ntwin,config%getString('lattice_structure'),& config%getFloat('c/a')) @@ -268,12 +267,12 @@ subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- ! slip-twin related parameters slipAndTwinActive: if (prm%totalNslip > 0 .and. prm%totalNtwin > 0) then - prm%interaction_SlipTwin = transpose(lattice_interaction_SlipByTwin(prm%Nslip,prm%Ntwin,& + prm%interaction_SlipTwin = lattice_interaction_SlipByTwin(prm%Nslip,prm%Ntwin,& config%getFloats('interaction_sliptwin'), & - config%getString('lattice_structure'))) - prm%interaction_TwinSlip = transpose(lattice_interaction_TwinBySlip(prm%Ntwin,prm%Nslip,& + config%getString('lattice_structure')) + prm%interaction_TwinSlip = lattice_interaction_TwinBySlip(prm%Ntwin,prm%Nslip,& config%getFloats('interaction_twinslip'), & - config%getString('lattice_structure'))) + config%getString('lattice_structure')) else slipAndTwinActive allocate(prm%interaction_SlipTwin(prm%TotalNslip,prm%TotalNtwin)) ! at least one dimension is 0 allocate(prm%interaction_TwinSlip(prm%TotalNtwin,prm%TotalNslip)) ! at least one dimension is 0 @@ -387,7 +386,6 @@ end subroutine plastic_phenopowerlaw_init !-------------------------------------------------------------------------------------------------- pure subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMp,Mp,instance,of) - implicit none real(pReal), dimension(3,3), intent(out) :: & Lp !< plastic velocity gradient real(pReal), dimension(3,3,3,3), intent(out) :: & @@ -439,7 +437,6 @@ end subroutine plastic_phenopowerlaw_LpAndItsTangent !-------------------------------------------------------------------------------------------------- subroutine plastic_phenopowerlaw_dotState(Mp,instance,of) - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -498,7 +495,6 @@ function plastic_phenopowerlaw_postResults(Mp,instance,of) result(postResults) use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -616,7 +612,6 @@ pure subroutine kinetics_slip(Mp,instance,of, & use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & @@ -693,7 +688,6 @@ pure subroutine kinetics_twin(Mp,instance,of,& use math, only: & math_mul33xx33 - implicit none real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress integer, intent(in) :: & From 89679147e894d27b62c1d3712fb70902dc4942db Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 13 Apr 2019 09:47:56 +0200 Subject: [PATCH 50/97] leaner group structure, centrally handled --- src/constitutive.f90 | 4 +--- src/crystallite.f90 | 6 ++---- src/results.f90 | 15 +++++++++++++++ 3 files changed, 18 insertions(+), 7 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 1158ddc07..5031616d8 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -1107,11 +1107,9 @@ subroutine constitutive_results integer :: p character(len=256) :: group - - call HDF5_closeGroup(results_addGroup('current/constitutive')) do p=1,size(config_name_phase) - group = trim('current/constitutive')//'/'//trim(config_name_phase(p)) + group = trim('current/constituent')//'/'//trim(config_name_phase(p)) call HDF5_closeGroup(results_addGroup(group)) group = trim(group)//'/'//'plastic' diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 69c7839c7..c330c8733 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1077,7 +1077,7 @@ end function crystallite_postResults !-------------------------------------------------------------------------------------------------- -!> @brief writes constitutive results to HDF5 output file +!> @brief writes crystallite results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine crystallite_results #if defined(PETSc) || defined(DAMASK_HDF5) @@ -1096,12 +1096,10 @@ subroutine crystallite_results real(pReal), allocatable, dimension(:,:,:) :: selected_tensors type(rotation), allocatable, dimension(:) :: selected_rotations character(len=256) :: group,lattice_label - - call HDF5_closeGroup(results_addGroup('current/constituent')) do p=1,size(config_name_phase) group = trim('current/constituent')//'/'//trim(config_name_phase(p)) - call HDF5_closeGroup(results_addGroup(group)) + do o = 1, size(output_constituent(p)%label) select case (output_constituent(p)%label(o)) case('f') diff --git a/src/results.f90 b/src/results.f90 index 20c2aa143..a969816d5 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -115,6 +115,9 @@ subroutine results_addIncrement(inc,time) call HDF5_closeGroup(results_addGroup(trim('inc'//trim(adjustl(incChar))))) call results_setLink(trim('inc'//trim(adjustl(incChar))),'current') call HDF5_addAttribute(resultsFile,'time/s',time,trim('inc'//trim(adjustl(incChar)))) + + call HDF5_closeGroup(results_addGroup('current/constituent')) + call HDF5_closeGroup(results_addGroup('current/materialpoint')) end subroutine results_addIncrement @@ -253,6 +256,8 @@ subroutine results_writeScalarDataset_real(group,dataset,label,description,SIuni call HDF5_addAttribute(groupHandle,'Description',description,label) if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) call HDF5_closeGroup(groupHandle) end subroutine results_writeScalarDataset_real @@ -278,6 +283,8 @@ subroutine results_writeVectorDataset_real(group,dataset,label,description,SIuni call HDF5_addAttribute(groupHandle,'Description',description,label) if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) call HDF5_closeGroup(groupHandle) end subroutine results_writeVectorDataset_real @@ -304,6 +311,8 @@ subroutine results_writeTensorDataset_real(group,dataset,label,description,SIuni call HDF5_addAttribute(groupHandle,'Description',description,label) if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) call HDF5_closeGroup(groupHandle) end subroutine results_writeTensorDataset_real @@ -330,6 +339,8 @@ subroutine results_writeVectorDataset_int(group,dataset,label,description,SIunit call HDF5_addAttribute(groupHandle,'Description',description,label) if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) call HDF5_closeGroup(groupHandle) end subroutine results_writeVectorDataset_int @@ -356,6 +367,8 @@ subroutine results_writeTensorDataset_int(group,dataset,label,description,SIunit call HDF5_addAttribute(groupHandle,'Description',description,label) if (HDF5_objectExists(groupHandle,label) .and. present(SIunit)) & call HDF5_addAttribute(groupHandle,'Unit',SIunit,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) call HDF5_closeGroup(groupHandle) end subroutine results_writeTensorDataset_int @@ -384,6 +397,8 @@ subroutine results_writeScalarDataset_rotation(group,dataset,label,description,l call HDF5_addAttribute(groupHandle,'Description',description,label) if (HDF5_objectExists(groupHandle,label) .and. present(lattice_structure)) & call HDF5_addAttribute(groupHandle,'Lattice',lattice_structure,label) + if (HDF5_objectExists(groupHandle,label)) & + call HDF5_addAttribute(groupHandle,'Creator','DAMASK '//DAMASKVERSION,label) call HDF5_closeGroup(groupHandle) end subroutine results_writeScalarDataset_rotation From 8eb1a35dfb649aef6590b03cc04b672cda93ed89 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 13 Apr 2019 11:11:32 +0200 Subject: [PATCH 51/97] first version of a library to parse HDF5 - preliminarly called DADF5 (DAMASK HDF5) - script to write (empty undeformed) geometries is also added --- processing/post/DADF5_vtk_cells.py | 64 ++++++++++++++++++++++++++++++ python/damask/__init__.py | 1 + python/damask/dadf5.py | 38 ++++++++++++++++++ 3 files changed, 103 insertions(+) create mode 100755 processing/post/DADF5_vtk_cells.py create mode 100644 python/damask/dadf5.py diff --git a/processing/post/DADF5_vtk_cells.py b/processing/post/DADF5_vtk_cells.py new file mode 100755 index 000000000..008ac5f66 --- /dev/null +++ b/processing/post/DADF5_vtk_cells.py @@ -0,0 +1,64 @@ +#!/usr/bin/env python3 +# -*- coding: UTF-8 no BOM -*- + +import os,vtk +import numpy as np +import argparse +import damask + +scriptName = os.path.splitext(os.path.basename(__file__))[0] +scriptID = ' '.join([scriptName,damask.version]) + +# -------------------------------------------------------------------- +# MAIN +# -------------------------------------------------------------------- +parser = argparse.ArgumentParser() + +#ToDo: We need to decide on a way of handling arguments of variable lentght +#https://stackoverflow.com/questions/15459997/passing-integer-lists-to-python + +#parser.add_argument('--version', action='version', version='%(prog)s {}'.format(scriptID)) +parser.add_argument('filenames', nargs='+', + help='DADF5 files') + +options = parser.parse_args() + + +# --- loop over input files ------------------------------------------------------------------------ + +for filename in options.filenames: + data = damask.DADF5(filename) + + if data.structured: # for grid solvers use rectilinear grid + rGrid = vtk.vtkRectilinearGrid() + coordArray = [vtk.vtkDoubleArray(), + vtk.vtkDoubleArray(), + vtk.vtkDoubleArray(), + ] + + rGrid.SetDimensions(*data.grid) + for dim in [0,1,2]: + for c in np.linspace(0,data.size[dim],1+data.grid[dim]): + coordArray[dim].InsertNextValue(c) + + rGrid.SetXCoordinates(coordArray[0]) + rGrid.SetYCoordinates(coordArray[1]) + rGrid.SetZCoordinates(coordArray[2]) + + + for i,inc in enumerate(data.increments): + if not inc['active']: pass + + if data.structured: + writer = vtk.vtkXMLRectilinearGridWriter() + + writer.SetCompressorTypeToZLib() + writer.SetDataModeToBinary() + writer.SetFileName(os.path.join(os.path.split(filename)[0], + os.path.splitext(os.path.split(filename)[1])[0] + + '_inc{:04d}'.format(i) + # ToDo: adjust to lenght of increments + '.' + writer.GetDefaultFileExtension())) + if data.structured: + writer.SetInputData(rGrid) + + writer.Write() diff --git a/python/damask/__init__.py b/python/damask/__init__.py index d7ed4a9f9..2dfdac567 100644 --- a/python/damask/__init__.py +++ b/python/damask/__init__.py @@ -14,6 +14,7 @@ from .asciitable import ASCIItable # noqa from .config import Material # noqa from .colormaps import Colormap, Color # noqa from .orientation import Symmetry, Lattice, Rotation, Orientation # noqa +from .dadf5 import DADF5 # noqa #from .block import Block # only one class from .result import Result # noqa diff --git a/python/damask/dadf5.py b/python/damask/dadf5.py new file mode 100644 index 000000000..6342b18e7 --- /dev/null +++ b/python/damask/dadf5.py @@ -0,0 +1,38 @@ +# -*- coding: UTF-8 no BOM -*- +import h5py +import re + +# ------------------------------------------------------------------ +class DADF5(): + """Read and write to DADF5 files""" + +# ------------------------------------------------------------------ + def __init__(self, + filename, + mode = 'r', + ): + + if mode not in ['a','r']: + print('Invalid file access mode') + with h5py.File(filename,mode): + pass + + with h5py.File(filename,'r') as f: + + if f.attrs['DADF5-major'] != 0 or f.attrs['DADF5-minor'] != 1: + print('Unsupported DADF5 version {} '.format(f.attrs['DADF5-version'])) + + self.structured = 'grid' in f['mapping'].attrs.keys() + + if self.structured: + self.grid = f['mapping'].attrs['grid'] + self.size = f['mapping'].attrs['size'] + + r=re.compile('inc[0-9]+') + self.increments = [{'group': u, + 'time': f[u].attrs['time/s'], + 'active': True + } for u in f.keys() if r.match(u)] + + self.filename = filename + self.mode = mode From c4784e66735e6c364ee0555f8e2816ba1f4a8ad4 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 13 Apr 2019 15:34:51 +0200 Subject: [PATCH 52/97] better readable --- src/crystallite.f90 | 70 ++++++++++++++++++++++----------------------- 1 file changed, 34 insertions(+), 36 deletions(-) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index 69c7839c7..d97763ef3 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1163,64 +1163,62 @@ subroutine crystallite_results !-------------------------------------------------------------------------------------------------- !> @brief select tensors for output !-------------------------------------------------------------------------------------------------- - function select_tensors(dataset,instance) + function select_tensors(dataset,instance) use material, only: & homogenization_maxNgrains, & material_phaseAt - integer, intent(in) :: instance - real(pReal), dimension(:,:,:,:,:), intent(in) :: dataset - real(pReal), allocatable, dimension(:,:,:) :: select_tensors - integer :: e,i,c,j - - allocate(select_tensors(3,3,count(material_phaseAt==instance)*homogenization_maxNgrains)) + integer, intent(in) :: instance + real(pReal), dimension(:,:,:,:,:), intent(in) :: dataset + real(pReal), allocatable, dimension(:,:,:) :: select_tensors + integer :: e,i,c,j + + allocate(select_tensors(3,3,count(material_phaseAt==instance)*homogenization_maxNgrains)) - j=1 - do e = 1, size(material_phaseAt,2) - do i = 1, homogenization_maxNgrains !ToDo: this needs to be changed for varying Ngrains - do c = 1, size(material_phaseAt,1) - if (material_phaseAt(c,e) == instance) then - select_tensors(1:3,1:3,j) = dataset(1:3,1:3,c,i,e) + j=0 + do e = 1, size(material_phaseAt,2) + do i = 1, homogenization_maxNgrains !ToDo: this needs to be changed for varying Ngrains + do c = 1, size(material_phaseAt,1) + if (material_phaseAt(c,e) == instance) then j = j + 1 - endif - enddo + select_tensors(1:3,1:3,j) = dataset(1:3,1:3,c,i,e) + endif + enddo + enddo enddo - enddo - - end function select_tensors + end function select_tensors !-------------------------------------------------------------------------------------------------- !> @brief select rotations for output !-------------------------------------------------------------------------------------------------- - function select_rotations(dataset,instance) + function select_rotations(dataset,instance) use material, only: & homogenization_maxNgrains, & material_phaseAt - integer, intent(in) :: instance - type(rotation), dimension(:,:,:), intent(in) :: dataset - type(rotation), allocatable, dimension(:) :: select_rotations - integer :: e,i,c,j - - allocate(select_rotations(count(material_phaseAt==instance)*homogenization_maxNgrains)) + integer, intent(in) :: instance + type(rotation), dimension(:,:,:), intent(in) :: dataset + type(rotation), allocatable, dimension(:) :: select_rotations + integer :: e,i,c,j + + allocate(select_rotations(count(material_phaseAt==instance)*homogenization_maxNgrains)) - j=1 - do e = 1, size(material_phaseAt,2) - do i = 1, homogenization_maxNgrains !ToDo: this needs to be changed for varying Ngrains - do c = 1, size(material_phaseAt,1) - if (material_phaseAt(c,e) == instance) then - select_rotations(j) = dataset(c,i,e) + j=0 + do e = 1, size(material_phaseAt,2) + do i = 1, homogenization_maxNgrains !ToDo: this needs to be changed for varying Ngrains + do c = 1, size(material_phaseAt,1) + if (material_phaseAt(c,e) == instance) then j = j + 1 - endif - enddo - enddo - enddo + select_rotations(j) = dataset(c,i,e) + endif + enddo + enddo + enddo - end function select_rotations #endif From 1e2766cda67258b5d32515a0675b5c061f618383 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 13 Apr 2019 15:37:34 +0200 Subject: [PATCH 53/97] not needed --- src/plastic_disloUCLA.f90 | 1 - src/plastic_dislotwin.f90 | 1 - src/plastic_isotropic.f90 | 1 - src/plastic_kinematichardening.f90 | 1 - src/plastic_none.f90 | 1 - src/plastic_nonlocal.f90 | 1 - src/plastic_phenopowerlaw.f90 | 1 - 7 files changed, 7 deletions(-) diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 13956dd59..efab7bc0b 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -559,7 +559,6 @@ subroutine plastic_disloUCLA_results(instance,group) use results, only: & results_writeDataset - implicit none integer, intent(in) :: instance character(len=*), intent(in) :: group diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 index 858199ada..e8aca7f89 100644 --- a/src/plastic_dislotwin.f90 +++ b/src/plastic_dislotwin.f90 @@ -1061,7 +1061,6 @@ subroutine plastic_dislotwin_results(instance,group) use results, only: & results_writeDataset - implicit none integer, intent(in) :: instance character(len=*) :: group integer :: o diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 index 1049dc9cf..4f2892f57 100644 --- a/src/plastic_isotropic.f90 +++ b/src/plastic_isotropic.f90 @@ -483,7 +483,6 @@ subroutine plastic_isotropic_results(instance,group) use results, only: & results_writeDataset - implicit none integer, intent(in) :: instance character(len=*), intent(in) :: group diff --git a/src/plastic_kinematichardening.f90 b/src/plastic_kinematichardening.f90 index 27bae7e40..a255572e1 100644 --- a/src/plastic_kinematichardening.f90 +++ b/src/plastic_kinematichardening.f90 @@ -550,7 +550,6 @@ subroutine plastic_kinehardening_results(instance,group) use results, only: & results_writeDataset - implicit none integer, intent(in) :: instance character(len=*) :: group integer :: o diff --git a/src/plastic_none.f90 b/src/plastic_none.f90 index e34fd533b..6f2ef2230 100644 --- a/src/plastic_none.f90 +++ b/src/plastic_none.f90 @@ -31,7 +31,6 @@ subroutine plastic_none_init material_phase, & plasticState - implicit none integer :: & Ninstance, & p, & diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index c14223045..caaa0e4a2 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -2396,7 +2396,6 @@ subroutine plastic_nonlocal_results(instance,group) use results, only: & results_writeDataset - implicit none integer, intent(in) :: instance character(len=*) :: group integer :: o diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 index f2692a489..f8ebae68d 100644 --- a/src/plastic_phenopowerlaw.f90 +++ b/src/plastic_phenopowerlaw.f90 @@ -563,7 +563,6 @@ subroutine plastic_phenopowerlaw_results(instance,group) use results, only: & results_writeDataset - implicit none integer, intent(in) :: instance character(len=*), intent(in) :: group From 18f9deef1a7f59b9ebc26cacaafcc2368a91a528 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 15 Apr 2019 15:27:58 +0200 Subject: [PATCH 54/97] fixed deadlock --- src/grid_mech_spectral_basic.f90 | 1 - src/grid_mech_spectral_polarisation.f90 | 19 +++++++------------ 2 files changed, 7 insertions(+), 13 deletions(-) diff --git a/src/grid_mech_spectral_basic.f90 b/src/grid_mech_spectral_basic.f90 index 2ed8bc683..d07c4c4d9 100644 --- a/src/grid_mech_spectral_basic.f90 +++ b/src/grid_mech_spectral_basic.f90 @@ -335,7 +335,6 @@ subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTi write(rankStr,'(a1,i0)')'_',worldrank fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') - print*, trim(getSolverJobName())//trim(rankStr)//'.hdf5';flush(6) call HDF5_write(fileHandle,F_aim, 'F_aim') call HDF5_write(fileHandle,F_aim_lastInc,'F_aim_lastInc') call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 index 12183db0e..568451971 100644 --- a/src/grid_mech_spectral_polarisation.f90 +++ b/src/grid_mech_spectral_polarisation.f90 @@ -107,8 +107,7 @@ subroutine grid_mech_spectral_polarisation_init use spectral_utilities, only: & utilities_constitutiveResponse, & utilities_updateGamma, & - utilities_updateIPcoords, & - wgt + utilities_updateIPcoords use mesh, only: & grid, & grid3 @@ -196,7 +195,6 @@ subroutine grid_mech_spectral_polarisation_init call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') call HDF5_read(fileHandle,F_tau, 'F_tau') call HDF5_read(fileHandle,F_tau_lastInc, 'F_tau_lastInc') - elseif (restartInc == 0) then restart F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity @@ -343,7 +341,6 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa integer :: i, j, k real(pReal), dimension(3,3) :: F_lambda33 - integer :: fileUnit integer(HID_T) :: fileHandle character(len=32) :: rankStr @@ -363,15 +360,13 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa write(rankStr,'(a1,i0)')'_',worldrank fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') - if (worldrank == 0) then - call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') - call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') - call HDF5_write(fileHandle,F_aim, 'F_aim') - call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') - call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') - endif + call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_write(fileHandle,F_aim, 'F_aim') + call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') + - write(rankStr,'(a1,i0)')'_',worldrank call HDF5_write(fileHandle,F, 'F') call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') call HDF5_write(fileHandle,F_tau, 'F_tau') From 4793f964f8cc309f8126f6c4e948164012575bc0 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 15 Apr 2019 15:53:46 +0200 Subject: [PATCH 55/97] unified style --- src/grid_mech_spectral_basic.f90 | 33 +- src/grid_mech_spectral_polarisation.f90 | 830 ++++++++++++------------ 2 files changed, 430 insertions(+), 433 deletions(-) diff --git a/src/grid_mech_spectral_basic.f90 b/src/grid_mech_spectral_basic.f90 index d07c4c4d9..06f898224 100644 --- a/src/grid_mech_spectral_basic.f90 +++ b/src/grid_mech_spectral_basic.f90 @@ -27,8 +27,7 @@ module grid_mech_spectral_basic type(tSolutionParams), private :: params type, private :: tNumerics - logical :: & - update_gamma !< update gamma operator with current stiffness + logical :: update_gamma !< update gamma operator with current stiffness end type tNumerics type(tNumerics) :: num ! numerics parameters. Better name? @@ -42,8 +41,8 @@ module grid_mech_spectral_basic !-------------------------------------------------------------------------------------------------- ! common pointwise data real(pReal), private, dimension(:,:,:,:,:), allocatable :: & - F_lastInc, & - Fdot + F_lastInc, & !< field of previous compatible deformation gradients + Fdot !< field of assumed rate of compatible deformation gradient !-------------------------------------------------------------------------------------------------- ! stress, stiffness and compliance average etc. @@ -101,8 +100,7 @@ subroutine grid_mech_spectral_basic_init use spectral_utilities, only: & utilities_constitutiveResponse, & utilities_updateGamma, & - utilities_updateIPcoords, & - wgt + utilities_updateIPcoords use mesh, only: & grid, & grid3 @@ -179,6 +177,7 @@ subroutine grid_mech_spectral_basic_init write(rankStr,'(a1,i0)')'_',worldrank fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') + call HDF5_read(fileHandle,F_aim, 'F_aim') call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') @@ -226,7 +225,6 @@ function grid_mech_spectral_basic_solution(incInfoIn,timeinc,timeinc_old,stress_ terminallyIll implicit none - !-------------------------------------------------------------------------------------------------- ! input data for solution character(len=*), intent(in) :: & @@ -248,8 +246,8 @@ function grid_mech_spectral_basic_solution(incInfoIn,timeinc,timeinc_old,stress_ !-------------------------------------------------------------------------------------------------- ! update stiffness (and gamma operator) - S = Utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) - if (num%update_gamma) call Utilities_updateGamma(C_minMaxAvg,restartWrite) + S = utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) + if (num%update_gamma) call utilities_updateGamma(C_minMaxAvg,restartWrite) !-------------------------------------------------------------------------------------------------- ! set module wide available data @@ -329,7 +327,7 @@ subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTi else !-------------------------------------------------------------------------------------------------- ! restart information for spectral solver - if (restartWrite) then ! QUESTION: where is this logical properly set? + if (restartWrite) then write(6,'(/,a)') ' writing converged results for restart';flush(6) write(rankStr,'(a1,i0)')'_',worldrank @@ -344,6 +342,7 @@ subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTi call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') call HDF5_write(fileHandle,C_minMaxAvg, 'C_minMaxAvg') + call HDF5_closeFile(fileHandle) endif @@ -390,7 +389,7 @@ end subroutine grid_mech_spectral_basic_forward !-------------------------------------------------------------------------------------------------- !> @brief convergence check !-------------------------------------------------------------------------------------------------- -subroutine converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) +subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dummy,ierr) use numerics, only: & itmax, & itmin, & @@ -403,11 +402,11 @@ subroutine converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) implicit none SNES :: snes_local - PetscInt :: PETScIter - PetscReal :: & - xnorm, & ! not used - snorm, & ! not used - fnorm ! not used + PetscInt, intent(in) :: PETScIter + PetscReal, intent(in) :: & + devNull1, & + devNull2, & + devNull3 SNESConvergedReason :: reason PetscObject :: dummy PetscErrorCode :: ierr @@ -506,7 +505,7 @@ subroutine formResidual(in, F, & !-------------------------------------------------------------------------------------------------- ! evaluate constitutive response - call Utilities_constitutiveResponse(residuum, & ! "residuum" gets field of first PK stress (to save memory) + call utilities_constitutiveResponse(residuum, & ! "residuum" gets field of first PK stress (to save memory) P_av,C_volAvg,C_minMaxAvg, & F,params%timeinc,params%rotation_BC) call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 index 568451971..1d470bed3 100644 --- a/src/grid_mech_spectral_polarisation.f90 +++ b/src/grid_mech_spectral_polarisation.f90 @@ -7,80 +7,79 @@ module grid_mech_spectral_polarisation #include #include - use DAMASK_interface - use HDF5_utilities - use PETScdmda - use PETScsnes - use prec, only: & - pReal - use math, only: & - math_I3 - use spectral_utilities, only: & - tSolutionState, & - tSolutionParams - - implicit none - private + use DAMASK_interface + use HDF5_utilities + use PETScdmda + use PETScsnes + use prec, only: & + pReal + use math, only: & + math_I3 + use spectral_utilities, only: & + tSolutionState, & + tSolutionParams + + implicit none + private !-------------------------------------------------------------------------------------------------- ! derived types type(tSolutionParams), private :: params type, private :: tNumerics - logical :: & - update_gamma !< update gamma operator with current stiffness + logical :: update_gamma !< update gamma operator with current stiffness end type tNumerics type(tNumerics) :: num ! numerics parameters. Better name? !-------------------------------------------------------------------------------------------------- ! PETSc data - DM, private :: da - SNES, private :: snes - Vec, private :: solution_vec + DM, private :: da + SNES, private :: snes + Vec, private :: solution_vec !-------------------------------------------------------------------------------------------------- ! common pointwise data - real(pReal), private, dimension(:,:,:,:,:), allocatable :: & - F_lastInc, & !< field of previous compatible deformation gradients - F_tau_lastInc, & !< field of previous incompatible deformation gradient - Fdot, & !< field of assumed rate of compatible deformation gradient - F_tauDot !< field of assumed rate of incopatible deformation gradient + real(pReal), private, dimension(:,:,:,:,:), allocatable :: & + F_lastInc, & !< field of previous compatible deformation gradients + F_tau_lastInc, & !< field of previous incompatible deformation gradient + Fdot, & !< field of assumed rate of compatible deformation gradient + F_tauDot !< field of assumed rate of incopatible deformation gradient !-------------------------------------------------------------------------------------------------- ! stress, stiffness and compliance average etc. - real(pReal), private, dimension(3,3) :: & - F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient - F_aim = math_I3, & !< current prescribed deformation gradient - F_aim_lastInc = math_I3, & !< previous average deformation gradient - F_av = 0.0_pReal, & !< average incompatible def grad field - P_av = 0.0_pReal !< average 1st Piola--Kirchhoff stress - - character(len=1024), private :: incInfo !< time and increment information - real(pReal), private, dimension(3,3,3,3) :: & - C_volAvg = 0.0_pReal, & !< current volume average stiffness - C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness - C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness - C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness - S = 0.0_pReal, & !< current compliance (filled up with zeros) - C_scale = 0.0_pReal, & - S_scale = 0.0_pReal - - real(pReal), private :: & - err_BC, & !< deviation from stress BC - err_curl, & !< RMS of curl of F - err_div !< RMS of div of P + real(pReal), private, dimension(3,3) :: & + F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient + F_aim = math_I3, & !< current prescribed deformation gradient + F_aim_lastInc = math_I3, & !< previous average deformation gradient + F_av = 0.0_pReal, & !< average incompatible def grad field + P_av = 0.0_pReal !< average 1st Piola--Kirchhoff stress - integer, private :: & - totalIter = 0 !< total iteration in current increment + character(len=1024), private :: incInfo !< time and increment information + real(pReal), private, dimension(3,3,3,3) :: & + C_volAvg = 0.0_pReal, & !< current volume average stiffness + C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness + C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness + C_minMaxAvgLastInc = 0.0_pReal, & !< previous (min+max)/2 stiffness + S = 0.0_pReal, & !< current compliance (filled up with zeros) + C_scale = 0.0_pReal, & + S_scale = 0.0_pReal - public :: & - grid_mech_spectral_polarisation_init, & - grid_mech_spectral_polarisation_solution, & - grid_mech_spectral_polarisation_forward - private :: & - converged, & - formResidual + real(pReal), private :: & + err_BC, & !< deviation from stress BC + err_curl, & !< RMS of curl of F + err_div !< RMS of div of P + + integer, private :: & + totalIter = 0 !< total iteration in current increment + + public :: & + grid_mech_spectral_polarisation_init, & + grid_mech_spectral_polarisation_solution, & + grid_mech_spectral_polarisation_forward + private :: & + converged, & + formResidual contains @@ -88,141 +87,142 @@ contains !> @brief allocates all necessary fields and fills them with data, potentially from restart info !-------------------------------------------------------------------------------------------------- subroutine grid_mech_spectral_polarisation_init - use IO, only: & - IO_intOut, & - IO_error, & - IO_open_jobFile_binary - use FEsolving, only: & - restartInc - use config, only :& - config_numerics - use numerics, only: & - worldrank, & - worldsize, & - petsc_options - use homogenization, only: & - materialpoint_F0 - use DAMASK_interface, only: & - getSolverJobName - use spectral_utilities, only: & - utilities_constitutiveResponse, & - utilities_updateGamma, & - utilities_updateIPcoords - use mesh, only: & - grid, & - grid3 - use math, only: & - math_invSym3333 - - implicit none - real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P - real(pReal), dimension(3,3) :: & - temp33_Real = 0.0_pReal - - PetscErrorCode :: ierr - PetscScalar, pointer, dimension(:,:,:,:) :: & - FandF_tau, & ! overall pointer to solution data - F, & ! specific (sub)pointer - F_tau ! specific (sub)pointer - PetscInt, dimension(worldsize) :: localK - integer(HID_T) :: fileHandle - integer :: fileUnit - character(len=1024) :: rankStr + use IO, only: & + IO_intOut, & + IO_error, & + IO_open_jobFile_binary + use FEsolving, only: & + restartInc + use config, only :& + config_numerics + use numerics, only: & + worldrank, & + worldsize, & + petsc_options + use homogenization, only: & + materialpoint_F0 + use DAMASK_interface, only: & + getSolverJobName + use spectral_utilities, only: & + utilities_constitutiveResponse, & + utilities_updateGamma, & + utilities_updateIPcoords + use mesh, only: & + grid, & + grid3 + use math, only: & + math_invSym3333 + + implicit none + real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P + real(pReal), dimension(3,3) :: & + temp33_Real = 0.0_pReal - write(6,'(/,a)') ' <<<+- grid_mech_spectral_polarisation init -+>>>' - - write(6,'(/,a)') ' Shanthraj et al., International Journal of Plasticity 66:31–45, 2015' - write(6,'(a)') ' https://doi.org/10.1016/j.ijplas.2014.02.006' + PetscErrorCode :: ierr + PetscScalar, pointer, dimension(:,:,:,:) :: & + FandF_tau, & ! overall pointer to solution data + F, & ! specific (sub)pointer + F_tau ! specific (sub)pointer + PetscInt, dimension(worldsize) :: localK + integer(HID_T) :: fileHandle + integer :: fileUnit + character(len=1024) :: rankStr + + write(6,'(/,a)') ' <<<+- grid_mech_spectral_polarisation init -+>>>' - num%update_gamma = config_numerics%getInt('update_gamma',defaultVal=0) > 0 + write(6,'(/,a)') ' Shanthraj et al., International Journal of Plasticity 66:31–45, 2015' + write(6,'(a)') ' https://doi.org/10.1016/j.ijplas.2014.02.006' + + num%update_gamma = config_numerics%getInt('update_gamma',defaultVal=0) > 0 !-------------------------------------------------------------------------------------------------- ! set default and user defined options for PETSc - call PETScOptionsInsertString(PETSC_NULL_OPTIONS,'-mech_snes_type ngmres',ierr) - CHKERRQ(ierr) - call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) - CHKERRQ(ierr) + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,'-mech_snes_type ngmres',ierr) + CHKERRQ(ierr) + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) + CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! allocate global fields - allocate (F_lastInc (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (Fdot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (F_tau_lastInc(3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (F_tauDot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(F_lastInc (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(Fdot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(F_tau_lastInc(3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(F_tauDot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) !-------------------------------------------------------------------------------------------------- ! initialize solver specific parts of PETSc - call SNESCreate(PETSC_COMM_WORLD,snes,ierr); CHKERRQ(ierr) - call SNESSetOptionsPrefix(snes,'mech_',ierr);CHKERRQ(ierr) - localK = 0 - localK(worldrank+1) = grid3 - call MPI_Allreduce(MPI_IN_PLACE,localK,worldsize,MPI_INTEGER,MPI_SUM,PETSC_COMM_WORLD,ierr) - call DMDACreate3d(PETSC_COMM_WORLD, & - DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary - DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point - grid(1),grid(2),grid(3), & ! global grid - 1 , 1, worldsize, & - 18, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) - [grid(1)],[grid(2)],localK, & ! local grid - da,ierr) ! handle, error - CHKERRQ(ierr) - call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) ! connect snes to da - call DMsetFromOptions(da,ierr); CHKERRQ(ierr) - call DMsetUp(da,ierr); CHKERRQ(ierr) - call DMcreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 18, i.e. every def grad tensor) - call DMDASNESsetFunctionLocal(da,INSERT_VALUES,formResidual,PETSC_NULL_SNES,ierr) ! residual vector of same shape as solution vector - CHKERRQ(ierr) - call SNESsetConvergenceTest(snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "converged" - CHKERRQ(ierr) - call SNESsetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional CLI arguments + call SNESCreate(PETSC_COMM_WORLD,snes,ierr); CHKERRQ(ierr) + call SNESSetOptionsPrefix(snes,'mech_',ierr);CHKERRQ(ierr) + localK = 0 + localK(worldrank+1) = grid3 + call MPI_Allreduce(MPI_IN_PLACE,localK,worldsize,MPI_INTEGER,MPI_SUM,PETSC_COMM_WORLD,ierr) + call DMDACreate3d(PETSC_COMM_WORLD, & + DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary + DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point + grid(1),grid(2),grid(3), & ! global grid + 1 , 1, worldsize, & + 18, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) + [grid(1)],[grid(2)],localK, & ! local grid + da,ierr) ! handle, error + CHKERRQ(ierr) + call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) ! connect snes to da + call DMsetFromOptions(da,ierr); CHKERRQ(ierr) + call DMsetUp(da,ierr); CHKERRQ(ierr) + call DMcreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 18, i.e. every def grad tensor) + call DMDASNESsetFunctionLocal(da,INSERT_VALUES,formResidual,PETSC_NULL_SNES,ierr) ! residual vector of same shape as solution vector + CHKERRQ(ierr) + call SNESsetConvergenceTest(snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "converged" + CHKERRQ(ierr) + call SNESsetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional CLI arguments !-------------------------------------------------------------------------------------------------- ! init fields - call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) ! places pointer on PETSc data - F => FandF_tau( 0: 8,:,:,:) - F_tau => FandF_tau( 9:17,:,:,:) + call DMDAVecGetArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) ! places pointer on PETSc data + F => FandF_tau( 0: 8,:,:,:) + F_tau => FandF_tau( 9:17,:,:,:) + + restart: if (restartInc > 0) then + write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading values of increment ', restartInc, ' from file' + + write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') + + call HDF5_read(fileHandle,F_aim, 'F_aim') + call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') + call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_read(fileHandle,F, 'F') + call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_read(fileHandle,F_tau, 'F_tau') + call HDF5_read(fileHandle,F_tau_lastInc,'F_tau_lastInc') + + elseif (restartInc == 0) then restart + F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity + F = reshape(F_lastInc,[9,grid(1),grid(2),grid3]) + F_tau = 2.0_pReal*F + F_tau_lastInc = 2.0_pReal*F_lastInc + endif restart + + materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent + call Utilities_updateIPcoords(reshape(F,shape(F_lastInc))) + call Utilities_constitutiveResponse(P,temp33_Real,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2 + reshape(F,shape(F_lastInc)), & ! target F + 0.0_pReal, & ! time increment + math_I3) ! no rotation of boundary condition + call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) ! deassociate pointer + + restartRead: if (restartInc > 0) then + write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading more values of increment ', restartInc, ' from file' + call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_closeFile(fileHandle) - restart: if (restartInc > 0) then - write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading values of increment ', restartInc, ' from file' - - write(rankStr,'(a1,i0)')'_',worldrank - fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') - - call HDF5_read(fileHandle,F_aim, 'F_aim') - call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') - call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') - call HDF5_read(fileHandle,F, 'F') - call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') - call HDF5_read(fileHandle,F_tau, 'F_tau') - call HDF5_read(fileHandle,F_tau_lastInc, 'F_tau_lastInc') - - elseif (restartInc == 0) then restart - F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity - F = reshape(F_lastInc,[9,grid(1),grid(2),grid3]) - F_tau = 2.0_pReal*F - F_tau_lastInc = 2.0_pReal*F_lastInc - endif restart - - materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent - call Utilities_updateIPcoords(reshape(F,shape(F_lastInc))) - call Utilities_constitutiveResponse(P,temp33_Real,C_volAvg,C_minMaxAvg, & ! stress field, stress avg, global average of stiffness and (min+max)/2 - reshape(F,shape(F_lastInc)), & ! target F - 0.0_pReal, & ! time increment - math_I3) ! no rotation of boundary condition - call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) ! deassociate pointer - - restartRead: if (restartInc > 0) then - write(6,'(/,a,'//IO_intOut(restartInc)//',a)') ' reading more values of increment ', restartInc, ' from file' - call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') - call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') - call HDF5_closeFile(fileHandle) - fileUnit = IO_open_jobFile_binary('C_ref') - read(fileUnit) C_minMaxAvg; close(fileUnit) - endif restartRead - - call Utilities_updateGamma(C_minMaxAvg,.true.) - C_scale = C_minMaxAvg - S_scale = math_invSym3333(C_minMaxAvg) + fileUnit = IO_open_jobFile_binary('C_ref') + read(fileUnit) C_minMaxAvg; close(fileUnit) + endif restartRead + + call Utilities_updateGamma(C_minMaxAvg,.true.) + C_scale = C_minMaxAvg + S_scale = math_invSym3333(C_minMaxAvg) end subroutine grid_mech_spectral_polarisation_init @@ -231,66 +231,65 @@ end subroutine grid_mech_spectral_polarisation_init !> @brief solution for the Polarisation scheme with internal iterations !-------------------------------------------------------------------------------------------------- function grid_mech_spectral_polarisation_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation_BC) result(solution) - use math, only: & - math_invSym3333 - use spectral_utilities, only: & - tBoundaryCondition, & - utilities_maskedCompliance, & - utilities_updateGamma - use FEsolving, only: & - restartWrite, & - terminallyIll + use math, only: & + math_invSym3333 + use spectral_utilities, only: & + tBoundaryCondition, & + utilities_maskedCompliance, & + utilities_updateGamma + use FEsolving, only: & + restartWrite, & + terminallyIll implicit none - !-------------------------------------------------------------------------------------------------- ! input data for solution - character(len=*), intent(in) :: & - incInfoIn - real(pReal), intent(in) :: & - timeinc, & !< time increment of current solution - timeinc_old !< time increment of last successful increment - type(tBoundaryCondition), intent(in) :: & - stress_BC - real(pReal), dimension(3,3), intent(in) :: rotation_BC - type(tSolutionState) :: & - solution + character(len=*), intent(in) :: & + incInfoIn + real(pReal), intent(in) :: & + timeinc, & !< time increment of current solution + timeinc_old !< time increment of last successful increment + type(tBoundaryCondition), intent(in) :: & + stress_BC + real(pReal), dimension(3,3), intent(in) :: rotation_BC + type(tSolutionState) :: & + solution !-------------------------------------------------------------------------------------------------- ! PETSc Data - PetscErrorCode :: ierr - SNESConvergedReason :: reason - - incInfo = incInfoIn + PetscErrorCode :: ierr + SNESConvergedReason :: reason + + incInfo = incInfoIn !-------------------------------------------------------------------------------------------------- ! update stiffness (and gamma operator) - S = Utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) - if (num%update_gamma) then - call utilities_updateGamma(C_minMaxAvg,restartWrite) - C_scale = C_minMaxAvg - S_scale = math_invSym3333(C_minMaxAvg) - endif + S = utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) + if (num%update_gamma) then + call utilities_updateGamma(C_minMaxAvg,restartWrite) + C_scale = C_minMaxAvg + S_scale = math_invSym3333(C_minMaxAvg) + endif !-------------------------------------------------------------------------------------------------- ! set module wide available data - params%stress_mask = stress_BC%maskFloat - params%stress_BC = stress_BC%values - params%rotation_BC = rotation_BC - params%timeinc = timeinc - params%timeincOld = timeinc_old + params%stress_mask = stress_BC%maskFloat + params%stress_BC = stress_BC%values + params%rotation_BC = rotation_BC + params%timeinc = timeinc + params%timeincOld = timeinc_old !-------------------------------------------------------------------------------------------------- ! solve BVP - call SNESsolve(snes,PETSC_NULL_VEC,solution_vec,ierr); CHKERRQ(ierr) + call SNESsolve(snes,PETSC_NULL_VEC,solution_vec,ierr); CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! check convergence - call SNESGetConvergedReason(snes,reason,ierr); CHKERRQ(ierr) - - solution%converged = reason > 0 - solution%iterationsNeeded = totalIter - solution%termIll = terminallyIll - terminallyIll = .false. + call SNESGetConvergedReason(snes,reason,ierr); CHKERRQ(ierr) + + solution%converged = reason > 0 + solution%iterationsNeeded = totalIter + solution%termIll = terminallyIll + terminallyIll = .false. end function grid_mech_spectral_polarisation_solution @@ -324,13 +323,12 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa use FEsolving, only: & restartWrite - implicit none logical, intent(in) :: & guess real(pReal), intent(in) :: & timeinc_old, & timeinc, & - loadCaseTime !< remaining time of current load case + loadCaseTime !< remaining time of current load case type(tBoundaryCondition), intent(in) :: & stress_BC, & deformation_BC @@ -349,30 +347,29 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa F_tau => FandF_tau( 9:17,:,:,:) if (cutBack) then - C_volAvg = C_volAvgLastInc ! QUESTION: where is this required? - C_minMaxAvg = C_minMaxAvgLastInc ! QUESTION: where is this required? + C_volAvg = C_volAvgLastInc ! QUESTION: where is this required? + C_minMaxAvg = C_minMaxAvgLastInc ! QUESTION: where is this required? else !-------------------------------------------------------------------------------------------------- ! restart information for spectral solver - if (restartWrite) then ! QUESTION: where is this logical properly set? + if (restartWrite) then write(6,'(/,a)') ' writing converged results for restart';flush(6) write(rankStr,'(a1,i0)')'_',worldrank fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') + call HDF5_write(fileHandle,F_aim, 'F_aim') + call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') + call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_write(fileHandle,F, 'F') + call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_write(fileHandle,F_tau, 'F_tau') + call HDF5_write(fileHandle,F_tau_lastInc, 'F_tau_lastInc') + call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') - call HDF5_write(fileHandle,F_aim, 'F_aim') - call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') - call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') - - call HDF5_write(fileHandle,F, 'F') - call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') - call HDF5_write(fileHandle,F_tau, 'F_tau') - call HDF5_write(fileHandle,F_tau_lastInc, 'F_tau_lastInc') call HDF5_closeFile(fileHandle) - endif call CPFEM_age ! age state and kinematics @@ -386,13 +383,13 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa !-------------------------------------------------------------------------------------------------- ! calculate rate for aim - if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F + if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F F_aimDot = & F_aimDot + deformation_BC%maskFloat * matmul(deformation_BC%values, F_aim_lastInc) - elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed + elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed F_aimDot = & F_aimDot + deformation_BC%maskFloat * deformation_BC%values - elseif (deformation_BC%myType=='f') then ! aim at end of load case is prescribed + elseif (deformation_BC%myType=='f') then ! aim at end of load case is prescribed F_aimDot = & F_aimDot + deformation_BC%maskFloat * (deformation_BC%values - F_aim_lastInc)/loadCaseTime endif @@ -404,33 +401,33 @@ subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loa F_tauDot = utilities_calculateRate(guess, & F_tau_lastInc,reshape(F_tau,[3,3,grid(1),grid(2),grid3]), timeinc_old, & math_rotate_backward33(F_aimDot,rotation_BC)) - F_lastInc = reshape(F, [3,3,grid(1),grid(2),grid3]) ! winding F forward - F_tau_lastInc = reshape(F_tau, [3,3,grid(1),grid(2),grid3]) ! winding F_tau forward - materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent + F_lastInc = reshape(F, [3,3,grid(1),grid(2),grid3]) ! winding F forward + F_tau_lastInc = reshape(F_tau, [3,3,grid(1),grid(2),grid3]) ! winding F_tau forward + materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent endif !-------------------------------------------------------------------------------------------------- ! update average and local deformation gradients F_aim = F_aim_lastInc + F_aimDot * timeinc - F = reshape(utilities_forwardField(timeinc,F_lastInc,Fdot, & ! estimate of F at end of time+timeinc that matches rotated F_aim on average + F = reshape(utilities_forwardField(timeinc,F_lastInc,Fdot, & ! estimate of F at end of time+timeinc that matches rotated F_aim on average math_rotate_backward33(F_aim,rotation_BC)),& [9,grid(1),grid(2),grid3]) - if (guess) then - F_tau = reshape(Utilities_forwardField(timeinc,F_tau_lastInc,F_taudot), & - [9,grid(1),grid(2),grid3]) ! does not have any average value as boundary condition - else - do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) - F_lambda33 = reshape(F_tau(1:9,i,j,k)-F(1:9,i,j,k),[3,3]) - F_lambda33 = math_mul3333xx33(S_scale,matmul(F_lambda33, & - math_mul3333xx33(C_scale,& - matmul(transpose(F_lambda33),& - F_lambda33)-math_I3))*0.5_pReal)& - + math_I3 - F_tau(1:9,i,j,k) = reshape(F_lambda33,[9])+F(1:9,i,j,k) - enddo; enddo; enddo - endif - - call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) + if (guess) then + F_tau = reshape(Utilities_forwardField(timeinc,F_tau_lastInc,F_taudot), & + [9,grid(1),grid(2),grid3]) ! does not have any average value as boundary condition + else + do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) + F_lambda33 = reshape(F_tau(1:9,i,j,k)-F(1:9,i,j,k),[3,3]) + F_lambda33 = math_mul3333xx33(S_scale,matmul(F_lambda33, & + math_mul3333xx33(C_scale,& + matmul(transpose(F_lambda33),& + F_lambda33)-math_I3))*0.5_pReal)& + + math_I3 + F_tau(1:9,i,j,k) = reshape(F_lambda33,[9])+F(1:9,i,j,k) + enddo; enddo; enddo + endif + + call DMDAVecRestoreArrayF90(da,solution_vec,FandF_tau,ierr); CHKERRQ(ierr) end subroutine grid_mech_spectral_polarisation_forward @@ -438,61 +435,61 @@ end subroutine grid_mech_spectral_polarisation_forward !-------------------------------------------------------------------------------------------------- !> @brief convergence check !-------------------------------------------------------------------------------------------------- -subroutine converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) - use numerics, only: & - itmax, & - itmin, & - err_div_tolRel, & - err_div_tolAbs, & - err_curl_tolRel, & - err_curl_tolAbs, & - err_stress_tolRel, & - err_stress_tolAbs - use FEsolving, only: & - terminallyIll - - implicit none - SNES :: snes_local - PetscInt :: PETScIter - PetscReal :: & - xnorm, & ! not used - snorm, & ! not used - fnorm ! not used - SNESConvergedReason :: reason - PetscObject :: dummy - PetscErrorCode :: ierr - real(pReal) :: & - curlTol, & - divTol, & - BCTol - - curlTol = max(maxval(abs(F_aim-math_I3))*err_curl_tolRel ,err_curl_tolAbs) - divTol = max(maxval(abs(P_av)) *err_div_tolRel ,err_div_tolAbs) - BCTol = max(maxval(abs(P_av)) *err_stress_tolRel,err_stress_tolAbs) - - if ((totalIter >= itmin .and. & - all([ err_div /divTol, & - err_curl/curlTol, & - err_BC /BCTol ] < 1.0_pReal)) & - .or. terminallyIll) then - reason = 1 - elseif (totalIter >= itmax) then - reason = -1 - else - reason = 0 - endif +subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dummy,ierr) + use numerics, only: & + itmax, & + itmin, & + err_div_tolRel, & + err_div_tolAbs, & + err_curl_tolRel, & + err_curl_tolAbs, & + err_stress_tolRel, & + err_stress_tolAbs + use FEsolving, only: & + terminallyIll + + implicit none + SNES :: snes_local + PetscInt, intent(in) :: PETScIter + PetscReal, intent(in) :: & + devNull1, & + devNull2, & + devNull3 + SNESConvergedReason :: reason + PetscObject :: dummy + PetscErrorCode :: ierr + real(pReal) :: & + curlTol, & + divTol, & + BCTol + + curlTol = max(maxval(abs(F_aim-math_I3))*err_curl_tolRel ,err_curl_tolAbs) + divTol = max(maxval(abs(P_av)) *err_div_tolRel ,err_div_tolAbs) + BCTol = max(maxval(abs(P_av)) *err_stress_tolRel,err_stress_tolAbs) + + if ((totalIter >= itmin .and. & + all([ err_div /divTol, & + err_curl/curlTol, & + err_BC /BCTol ] < 1.0_pReal)) & + .or. terminallyIll) then + reason = 1 + elseif (totalIter >= itmax) then + reason = -1 + else + reason = 0 + endif !-------------------------------------------------------------------------------------------------- ! report - write(6,'(1/,a)') ' ... reporting .............................................................' - write(6,'(1/,a,f12.2,a,es8.2,a,es9.2,a)') ' error divergence = ', & - err_div/divTol, ' (',err_div, ' / m, tol = ',divTol,')' - write(6, '(a,f12.2,a,es8.2,a,es9.2,a)') ' error curl = ', & - err_curl/curlTol,' (',err_curl,' -, tol = ',curlTol,')' - write(6, '(a,f12.2,a,es8.2,a,es9.2,a)') ' error BC = ', & - err_BC/BCTol, ' (',err_BC, ' Pa, tol = ',BCTol,')' - write(6,'(/,a)') ' ===========================================================================' - flush(6) + write(6,'(1/,a)') ' ... reporting .............................................................' + write(6,'(1/,a,f12.2,a,es8.2,a,es9.2,a)') ' error divergence = ', & + err_div/divTol, ' (',err_div, ' / m, tol = ',divTol,')' + write(6, '(a,f12.2,a,es8.2,a,es9.2,a)') ' error curl = ', & + err_curl/curlTol,' (',err_curl,' -, tol = ',curlTol,')' + write(6, '(a,f12.2,a,es8.2,a,es9.2,a)') ' error BC = ', & + err_BC/BCTol, ' (',err_BC, ' Pa, tol = ',BCTol,')' + write(6,'(/,a)') ' ===========================================================================' + flush(6) end subroutine converged @@ -502,144 +499,145 @@ end subroutine converged !-------------------------------------------------------------------------------------------------- subroutine formResidual(in, FandF_tau, & residuum, dummy,ierr) - use numerics, only: & - itmax, & - itmin, & - polarAlpha, & - polarBeta - use mesh, only: & - grid, & - grid3 - use math, only: & - math_rotate_forward33, & - math_rotate_backward33, & - math_mul3333xx33, & - math_invSym3333 - use debug, only: & - debug_level, & - debug_spectral, & - debug_spectralRotation - use spectral_utilities, only: & - wgt, & - tensorField_real, & - utilities_FFTtensorForward, & - utilities_fourierGammaConvolution, & - utilities_FFTtensorBackward, & - utilities_constitutiveResponse, & - utilities_divergenceRMS, & - utilities_curlRMS - use IO, only: & - IO_intOut - use homogenization, only: & - materialpoint_dPdF - use FEsolving, only: & - terminallyIll + use numerics, only: & + itmax, & + itmin, & + polarAlpha, & + polarBeta + use mesh, only: & + grid, & + grid3 + use math, only: & + math_rotate_forward33, & + math_rotate_backward33, & + math_mul3333xx33, & + math_invSym3333 + use debug, only: & + debug_level, & + debug_spectral, & + debug_spectralRotation + use spectral_utilities, only: & + wgt, & + tensorField_real, & + utilities_FFTtensorForward, & + utilities_fourierGammaConvolution, & + utilities_FFTtensorBackward, & + utilities_constitutiveResponse, & + utilities_divergenceRMS, & + utilities_curlRMS + use IO, only: & + IO_intOut + use homogenization, only: & + materialpoint_dPdF + use FEsolving, only: & + terminallyIll - implicit none - DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: in !< DMDA info (needs to be named "in" for macros like XRANGE to work) - PetscScalar, dimension(3,3,2,XG_RANGE,YG_RANGE,ZG_RANGE), & - target, intent(in) :: FandF_tau - PetscScalar, dimension(3,3,2,X_RANGE,Y_RANGE,Z_RANGE),& - target, intent(out) :: residuum !< residuum field - PetscScalar, pointer, dimension(:,:,:,:,:) :: & - F, & - F_tau, & - residual_F, & - residual_F_tau - PetscInt :: & - PETScIter, & - nfuncs - PetscObject :: dummy - PetscErrorCode :: ierr - integer :: & - i, j, k, e + implicit none + DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: in !< DMDA info (needs to be named "in" for macros like XRANGE to work) + PetscScalar, dimension(3,3,2,XG_RANGE,YG_RANGE,ZG_RANGE), & + target, intent(in) :: FandF_tau + PetscScalar, dimension(3,3,2,X_RANGE,Y_RANGE,Z_RANGE),& + target, intent(out) :: residuum !< residuum field + PetscScalar, pointer, dimension(:,:,:,:,:) :: & + F, & + F_tau, & + residual_F, & + residual_F_tau + PetscInt :: & + PETScIter, & + nfuncs + PetscObject :: dummy + PetscErrorCode :: ierr + integer :: & + i, j, k, e - F => FandF_tau(1:3,1:3,1,& - XG_RANGE,YG_RANGE,ZG_RANGE) - F_tau => FandF_tau(1:3,1:3,2,& - XG_RANGE,YG_RANGE,ZG_RANGE) - residual_F => residuum(1:3,1:3,1,& - X_RANGE, Y_RANGE, Z_RANGE) - residual_F_tau => residuum(1:3,1:3,2,& - X_RANGE, Y_RANGE, Z_RANGE) + F => FandF_tau(1:3,1:3,1,& + XG_RANGE,YG_RANGE,ZG_RANGE) + F_tau => FandF_tau(1:3,1:3,2,& + XG_RANGE,YG_RANGE,ZG_RANGE) + residual_F => residuum(1:3,1:3,1,& + X_RANGE, Y_RANGE, Z_RANGE) + residual_F_tau => residuum(1:3,1:3,2,& + X_RANGE, Y_RANGE, Z_RANGE) - F_av = sum(sum(sum(F,dim=5),dim=4),dim=3) * wgt - call MPI_Allreduce(MPI_IN_PLACE,F_av,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) - - call SNESGetNumberFunctionEvals(snes,nfuncs,ierr); CHKERRQ(ierr) - call SNESGetIterationNumber(snes,PETScIter,ierr); CHKERRQ(ierr) + F_av = sum(sum(sum(F,dim=5),dim=4),dim=3) * wgt + call MPI_Allreduce(MPI_IN_PLACE,F_av,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + + call SNESGetNumberFunctionEvals(snes,nfuncs,ierr); CHKERRQ(ierr) + call SNESGetIterationNumber(snes,PETScIter,ierr); CHKERRQ(ierr) - if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1 ! new increment + if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1 ! new increment !-------------------------------------------------------------------------------------------------- ! begin of new iteration - newIteration: if (totalIter <= PETScIter) then - totalIter = totalIter + 1 - write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') & - trim(incInfo), ' @ Iteration ', itmin, '≤',totalIter, '≤', itmax - if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & - write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & - ' deformation gradient aim (lab) =', transpose(math_rotate_backward33(F_aim,params%rotation_BC)) - write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & - ' deformation gradient aim =', transpose(F_aim) - flush(6) - endif newIteration + newIteration: if (totalIter <= PETScIter) then + totalIter = totalIter + 1 + write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') & + trim(incInfo), ' @ Iteration ', itmin, '≤',totalIter, '≤', itmax + if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & + ' deformation gradient aim (lab) =', transpose(math_rotate_backward33(F_aim,params%rotation_BC)) + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & + ' deformation gradient aim =', transpose(F_aim) + flush(6) + endif newIteration !-------------------------------------------------------------------------------------------------- ! - tensorField_real = 0.0_pReal - do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) - tensorField_real(1:3,1:3,i,j,k) = & - polarBeta*math_mul3333xx33(C_scale,F(1:3,1:3,i,j,k) - math_I3) -& - polarAlpha*matmul(F(1:3,1:3,i,j,k), & - math_mul3333xx33(C_scale,F_tau(1:3,1:3,i,j,k) - F(1:3,1:3,i,j,k) - math_I3)) - enddo; enddo; enddo + tensorField_real = 0.0_pReal + do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) + tensorField_real(1:3,1:3,i,j,k) = & + polarBeta*math_mul3333xx33(C_scale,F(1:3,1:3,i,j,k) - math_I3) -& + polarAlpha*matmul(F(1:3,1:3,i,j,k), & + math_mul3333xx33(C_scale,F_tau(1:3,1:3,i,j,k) - F(1:3,1:3,i,j,k) - math_I3)) + enddo; enddo; enddo !-------------------------------------------------------------------------------------------------- ! doing convolution in Fourier space - call utilities_FFTtensorForward - call utilities_fourierGammaConvolution(math_rotate_backward33(polarBeta*F_aim,params%rotation_BC)) - call utilities_FFTtensorBackward + call utilities_FFTtensorForward + call utilities_fourierGammaConvolution(math_rotate_backward33(polarBeta*F_aim,params%rotation_BC)) + call utilities_FFTtensorBackward !-------------------------------------------------------------------------------------------------- ! constructing residual - residual_F_tau = polarBeta*F - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) + residual_F_tau = polarBeta*F - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) !-------------------------------------------------------------------------------------------------- ! evaluate constitutive response - call utilities_constitutiveResponse(residual_F, & ! "residuum" gets field of first PK stress (to save memory) - P_av,C_volAvg,C_minMaxAvg, & - F - residual_F_tau/polarBeta,params%timeinc,params%rotation_BC) - call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) + call utilities_constitutiveResponse(residual_F, & ! "residuum" gets field of first PK stress (to save memory) + P_av,C_volAvg,C_minMaxAvg, & + F - residual_F_tau/polarBeta,params%timeinc,params%rotation_BC) + call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) !-------------------------------------------------------------------------------------------------- ! stress BC handling - F_aim = F_aim - math_mul3333xx33(S, ((P_av - params%stress_BC))) ! S = 0.0 for no bc - err_BC = maxval(abs((1.0_pReal-params%stress_mask) * math_mul3333xx33(C_scale,F_aim & - -math_rotate_forward33(F_av,params%rotation_BC)) + & - params%stress_mask * (P_av-params%stress_BC))) ! mask = 0.0 for no bc + F_aim = F_aim - math_mul3333xx33(S, ((P_av - params%stress_BC))) ! S = 0.0 for no bc + err_BC = maxval(abs((1.0_pReal-params%stress_mask) * math_mul3333xx33(C_scale,F_aim & + -math_rotate_forward33(F_av,params%rotation_BC)) + & + params%stress_mask * (P_av-params%stress_BC))) ! mask = 0.0 for no bc ! calculate divergence - tensorField_real = 0.0_pReal - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = residual_F !< stress field in disguise - call utilities_FFTtensorForward - err_div = Utilities_divergenceRMS() !< root mean squared error in divergence of stress + tensorField_real = 0.0_pReal + tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = residual_F !< stress field in disguise + call utilities_FFTtensorForward + err_div = Utilities_divergenceRMS() !< root mean squared error in divergence of stress + !-------------------------------------------------------------------------------------------------- ! constructing residual - e = 0 - do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) - e = e + 1 - residual_F(1:3,1:3,i,j,k) = & - math_mul3333xx33(math_invSym3333(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,e) + C_scale), & - residual_F(1:3,1:3,i,j,k) - matmul(F(1:3,1:3,i,j,k), & - math_mul3333xx33(C_scale,F_tau(1:3,1:3,i,j,k) - F(1:3,1:3,i,j,k) - math_I3))) & - + residual_F_tau(1:3,1:3,i,j,k) - enddo; enddo; enddo + e = 0 + do k = 1, grid3; do j = 1, grid(2); do i = 1, grid(1) + e = e + 1 + residual_F(1:3,1:3,i,j,k) = & + math_mul3333xx33(math_invSym3333(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,e) + C_scale), & + residual_F(1:3,1:3,i,j,k) - matmul(F(1:3,1:3,i,j,k), & + math_mul3333xx33(C_scale,F_tau(1:3,1:3,i,j,k) - F(1:3,1:3,i,j,k) - math_I3))) & + + residual_F_tau(1:3,1:3,i,j,k) + enddo; enddo; enddo !-------------------------------------------------------------------------------------------------- ! calculating curl - tensorField_real = 0.0_pReal - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = F - call utilities_FFTtensorForward - err_curl = Utilities_curlRMS() + tensorField_real = 0.0_pReal + tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = F + call utilities_FFTtensorForward + err_curl = Utilities_curlRMS() end subroutine formResidual From 19dfefc2f48ed34255e1595a7814441af4dea7c3 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 15 Apr 2019 16:16:14 +0200 Subject: [PATCH 56/97] fixed deadlock in grid_mech_FEM --- src/grid_mech_FEM.f90 | 58 ++++++++++++------------- src/grid_mech_spectral_basic.f90 | 9 ++-- src/grid_mech_spectral_polarisation.f90 | 7 +-- 3 files changed, 33 insertions(+), 41 deletions(-) diff --git a/src/grid_mech_FEM.f90 b/src/grid_mech_FEM.f90 index adcbb626b..8ec42d918 100644 --- a/src/grid_mech_FEM.f90 +++ b/src/grid_mech_FEM.f90 @@ -208,6 +208,7 @@ subroutine grid_mech_FEM_init write(rankStr,'(a1,i0)')'_',worldrank fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') + call HDF5_read(fileHandle,F_aim, 'F_aim') call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') @@ -221,8 +222,8 @@ subroutine grid_mech_FEM_init F = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) endif restart materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent - call Utilities_updateIPcoords(F) - call Utilities_constitutiveResponse(P_current,temp33_Real,C_volAvg,devNull, & ! stress field, stress avg, global average of stiffness and (min+max)/2 + call utilities_updateIPcoords(F) + call utilities_constitutiveResponse(P_current,temp33_Real,C_volAvg,devNull, & ! stress field, stress avg, global average of stiffness and (min+max)/2 F, & ! target F 0.0_pReal, & ! time increment math_I3) ! no rotation of boundary condition @@ -255,7 +256,6 @@ function grid_mech_FEM_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation terminallyIll implicit none - !-------------------------------------------------------------------------------------------------- ! input data for solution character(len=*), intent(in) :: & @@ -268,7 +268,6 @@ function grid_mech_FEM_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation real(pReal), dimension(3,3), intent(in) :: rotation_BC type(tSolutionState) :: & solution - !-------------------------------------------------------------------------------------------------- ! PETSc Data PetscErrorCode :: ierr @@ -278,7 +277,7 @@ function grid_mech_FEM_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation !-------------------------------------------------------------------------------------------------- ! update stiffness (and gamma operator) - S = Utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) + S = utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) !-------------------------------------------------------------------------------------------------- ! set module wide available data params%stress_mask = stress_BC%maskFloat @@ -357,27 +356,26 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat !-------------------------------------------------------------------------------------------------- ! restart information for spectral solver if (restartWrite) then ! QUESTION: where is this logical properly set? - write(6,'(/,a)') ' writing converged results for restart' - flush(6) + write(6,'(/,a)') ' writing converged results for restart';flush(6) write(rankStr,'(a1,i0)')'_',worldrank fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','w') - if (worldrank == 0) then - call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') - call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') - call HDF5_write(fileHandle,F_aim, 'F_aim') - call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') - call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') - call HDF5_write(fileHandle,F, 'F') - call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') - call HDF5_write(fileHandle,u_current, 'u') - call HDF5_write(fileHandle,u_lastInc, 'u_lastInc') - call HDF5_closeFile(fileHandle) - endif + call HDF5_write(fileHandle,F_aim, 'F_aim') + call HDF5_write(fileHandle,F_aim_lastInc, 'F_aim_lastInc') + call HDF5_write(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_write(fileHandle,F, 'F') + call HDF5_write(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_write(fileHandle,u_current, 'u') + call HDF5_write(fileHandle,u_lastInc, 'u_lastInc') + + call HDF5_write(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_write(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + + call HDF5_closeFile(fileHandle) endif - call CPFEM_age() ! age state and kinematics + call CPFEM_age ! age state and kinematics call utilities_updateIPcoords(F) C_volAvgLastInc = C_volAvg @@ -429,9 +427,9 @@ end subroutine grid_mech_FEM_forward !-------------------------------------------------------------------------------------------------- !> @brief convergence check !-------------------------------------------------------------------------------------------------- -subroutine converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) -use mesh -use spectral_utilities +subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dummy,ierr) + use mesh + use spectral_utilities use numerics, only: & itmax, & itmin, & @@ -444,11 +442,11 @@ use spectral_utilities implicit none SNES :: snes_local - PetscInt :: PETScIter - PetscReal :: & - xnorm, & ! not used - snorm, & ! not used - fnorm + PetscInt, intent(in) :: PETScIter + PetscReal, intent(in) :: & + devNull1, & + devNull2, & + devNull3 SNESConvergedReason :: reason PetscObject :: dummy PetscErrorCode :: ierr @@ -461,7 +459,6 @@ use spectral_utilities divTol = max(maxval(abs(P_av))*err_div_tolRel ,err_div_tolAbs) BCTol = max(maxval(abs(P_av))*err_stress_tolRel,err_stress_tolAbs) - if ((totalIter >= itmin .and. & all([ err_div/divTol, & err_BC /BCTol ] < 1.0_pReal)) & @@ -489,7 +486,8 @@ end subroutine converged !-------------------------------------------------------------------------------------------------- !> @brief forms the residual vector !-------------------------------------------------------------------------------------------------- -subroutine formResidual(da_local,x_local,f_local,dummy,ierr) +subroutine formResidual(da_local,x_local, & + f_local,dummy,ierr) use numerics, only: & itmax, & itmin diff --git a/src/grid_mech_spectral_basic.f90 b/src/grid_mech_spectral_basic.f90 index 06f898224..91dcd03b4 100644 --- a/src/grid_mech_spectral_basic.f90 +++ b/src/grid_mech_spectral_basic.f90 @@ -117,7 +117,6 @@ subroutine grid_mech_spectral_basic_init F ! pointer to solution data PetscInt, dimension(worldsize) :: localK integer(HID_T) :: fileHandle - integer :: fileUnit character(len=1024) :: rankStr write(6,'(/,a)') ' <<<+- grid_mech_spectral_basic init -+>>>' @@ -164,7 +163,7 @@ subroutine grid_mech_spectral_basic_init call DMcreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 9, i.e. every def grad tensor) call DMDASNESsetFunctionLocal(da,INSERT_VALUES,formResidual,PETSC_NULL_SNES,ierr) ! residual vector of same shape as solution vector CHKERRQ(ierr) - call SNESsetConvergenceTest(snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr)! specify custom convergence check function "converged" + call SNESsetConvergenceTest(snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "converged" CHKERRQ(ierr) call SNESsetFromOptions(snes,ierr); CHKERRQ(ierr) ! pull it all together with additional CLI arguments @@ -203,11 +202,9 @@ subroutine grid_mech_spectral_basic_init call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') call HDF5_closeFile(fileHandle) - fileUnit = IO_open_jobFile_binary('C_ref') - read(fileUnit) C_minMaxAvg; close(fileUnit) endif restartRead - call Utilities_updateGamma(C_minMaxAvg,.true.) + call utilities_updateGamma(C_minMaxAvg,.true.) end subroutine grid_mech_spectral_basic_init @@ -442,7 +439,7 @@ end subroutine converged !-------------------------------------------------------------------------------------------------- -!> @brief forms the basic residual vector +!> @brief forms the residual vector !-------------------------------------------------------------------------------------------------- subroutine formResidual(in, F, & residuum, dummy, ierr) diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 index 1d470bed3..a7bf75209 100644 --- a/src/grid_mech_spectral_polarisation.f90 +++ b/src/grid_mech_spectral_polarisation.f90 @@ -125,7 +125,6 @@ subroutine grid_mech_spectral_polarisation_init F_tau ! specific (sub)pointer PetscInt, dimension(worldsize) :: localK integer(HID_T) :: fileHandle - integer :: fileUnit character(len=1024) :: rankStr write(6,'(/,a)') ' <<<+- grid_mech_spectral_polarisation init -+>>>' @@ -216,11 +215,9 @@ subroutine grid_mech_spectral_polarisation_init call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') call HDF5_closeFile(fileHandle) - fileUnit = IO_open_jobFile_binary('C_ref') - read(fileUnit) C_minMaxAvg; close(fileUnit) endif restartRead - call Utilities_updateGamma(C_minMaxAvg,.true.) + call utilities_updateGamma(C_minMaxAvg,.true.) C_scale = C_minMaxAvg S_scale = math_invSym3333(C_minMaxAvg) @@ -495,7 +492,7 @@ end subroutine converged !-------------------------------------------------------------------------------------------------- -!> @brief forms the polarisation residual vector +!> @brief forms the residual vector !-------------------------------------------------------------------------------------------------- subroutine formResidual(in, FandF_tau, & residuum, dummy,ierr) From 8f58f1348ea91d6b55190ee607b1a4c9dc34f357 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 15 Apr 2019 16:19:30 +0200 Subject: [PATCH 57/97] _pInt not needed --- src/grid_mech_FEM.f90 | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/src/grid_mech_FEM.f90 b/src/grid_mech_FEM.f90 index 8ec42d918..70332a040 100644 --- a/src/grid_mech_FEM.f90 +++ b/src/grid_mech_FEM.f90 @@ -12,7 +12,6 @@ module grid_mech_FEM use PETScdmda use PETScsnes use prec, only: & - pInt, & pReal use math, only: & math_I3 @@ -61,8 +60,8 @@ module grid_mech_FEM real(pReal), private :: & err_BC !< deviation from stress BC - integer(pInt), private :: & - totalIter = 0_pInt !< total iteration in current increment + integer, private :: & + totalIter = 0 !< total iteration in current increment public :: & grid_mech_FEM_init, & @@ -115,8 +114,7 @@ subroutine grid_mech_FEM_init 1.0_pReal,-1.0_pReal,-1.0_pReal,-1.0_pReal, & 1.0_pReal, 1.0_pReal, 1.0_pReal, 1.0_pReal], [4,8]) PetscErrorCode :: ierr - integer(pInt) :: rank - integer :: fileUnit + integer :: rank integer(HID_T) :: fileHandle character(len=1024) :: rankStr real(pReal), dimension(3,3,3,3) :: devNull @@ -232,7 +230,7 @@ subroutine grid_mech_FEM_init call DMDAVecRestoreArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr) CHKERRQ(ierr) - restartRead: if (restartInc > 0_pInt) then + restartRead: if (restartInc > 0) then write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading more values of increment ', restartInc, ' from file' call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') @@ -342,7 +340,6 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat rotation_BC PetscErrorCode :: ierr integer(HID_T) :: fileHandle - integer :: fileUnit character(len=32) :: rankStr PetscScalar, pointer, dimension(:,:,:,:) :: & u_current,u_lastInc @@ -530,12 +527,12 @@ subroutine formResidual(da_local,x_local, & call SNESGetNumberFunctionEvals(mech_snes,nfuncs,ierr); CHKERRQ(ierr) call SNESGetIterationNumber(mech_snes,PETScIter,ierr); CHKERRQ(ierr) - if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1_pInt ! new increment + if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1 ! new increment !-------------------------------------------------------------------------------------------------- ! begin of new iteration newIteration: if (totalIter <= PETScIter) then - totalIter = totalIter + 1_pInt + totalIter = totalIter + 1 write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') & trim(incInfo), ' @ Iteration ', itmin, '≤',totalIter+1, '≤', itmax if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & From d0a4cbf8d5804d4e6c093970e924f206fbfabb79 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 15 Apr 2019 16:30:54 +0200 Subject: [PATCH 58/97] one implicit none is enough --- src/grid_damage_spectral.f90 | 4 - src/grid_mech_FEM.f90 | 962 ++++++++++++------------ src/grid_mech_spectral_basic.f90 | 5 - src/grid_mech_spectral_polarisation.f90 | 4 - src/grid_thermal_spectral.f90 | 4 - 5 files changed, 478 insertions(+), 501 deletions(-) diff --git a/src/grid_damage_spectral.f90 b/src/grid_damage_spectral.f90 index c5e9a254b..3ce37c5ff 100644 --- a/src/grid_damage_spectral.f90 +++ b/src/grid_damage_spectral.f90 @@ -64,7 +64,6 @@ subroutine grid_damage_spectral_init worldsize, & petsc_options - implicit none PetscInt, dimension(worldsize) :: localK integer :: i, j, k, cell DM :: damage_grid @@ -164,7 +163,6 @@ function grid_damage_spectral_solution(timeinc,timeinc_old,loadCaseTime) result( use damage_nonlocal, only: & damage_nonlocal_putNonLocalDamage - implicit none real(pReal), intent(in) :: & timeinc, & !< increment in time for current solution timeinc_old, & !< increment in time of last increment @@ -236,7 +234,6 @@ subroutine grid_damage_spectral_forward damage_nonlocal_getDiffusion33, & damage_nonlocal_getMobility - implicit none integer :: i, j, k, cell DM :: dm_local PetscScalar, dimension(:,:,:), pointer :: x_scal @@ -301,7 +298,6 @@ subroutine formResidual(in,x_scal,f_scal,dummy,ierr) damage_nonlocal_getDiffusion33, & damage_nonlocal_getMobility - implicit none DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & in PetscScalar, dimension( & diff --git a/src/grid_mech_FEM.f90 b/src/grid_mech_FEM.f90 index 70332a040..2feec76df 100644 --- a/src/grid_mech_FEM.f90 +++ b/src/grid_mech_FEM.f90 @@ -7,66 +7,66 @@ module grid_mech_FEM #include #include - use DAMASK_interface - use HDF5_utilities - use PETScdmda - use PETScsnes - use prec, only: & - pReal - use math, only: & - math_I3 - use spectral_utilities, only: & - tSolutionState, & - tSolutionParams - - implicit none - private + use DAMASK_interface + use HDF5_utilities + use PETScdmda + use PETScsnes + use prec, only: & + pReal + use math, only: & + math_I3 + use spectral_utilities, only: & + tSolutionState, & + tSolutionParams + + implicit none + private !-------------------------------------------------------------------------------------------------- ! derived types - type(tSolutionParams), private :: params + type(tSolutionParams), private :: params !-------------------------------------------------------------------------------------------------- ! PETSc data - DM, private :: mech_grid - SNES, private :: mech_snes - Vec, private :: solution_current, solution_lastInc, solution_rate + DM, private :: mech_grid + SNES, private :: mech_snes + Vec, private :: solution_current, solution_lastInc, solution_rate !-------------------------------------------------------------------------------------------------- ! common pointwise data - real(pReal), private, dimension(:,:,:,:,:), allocatable :: F, P_current, F_lastInc - real(pReal), private :: detJ - real(pReal), private, dimension(3) :: delta - real(pReal), private, dimension(3,8) :: BMat - real(pReal), private, dimension(8,8) :: HGMat - PetscInt, private :: xstart,ystart,zstart,xend,yend,zend + real(pReal), private, dimension(:,:,:,:,:), allocatable :: F, P_current, F_lastInc + real(pReal), private :: detJ + real(pReal), private, dimension(3) :: delta + real(pReal), private, dimension(3,8) :: BMat + real(pReal), private, dimension(8,8) :: HGMat + PetscInt, private :: xstart,ystart,zstart,xend,yend,zend !-------------------------------------------------------------------------------------------------- ! stress, stiffness and compliance average etc. - real(pReal), private, dimension(3,3) :: & - F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient - F_aim = math_I3, & !< current prescribed deformation gradient - F_aim_lastIter = math_I3, & - F_aim_lastInc = math_I3, & !< previous average deformation gradient - P_av = 0.0_pReal !< average 1st Piola--Kirchhoff stress - - character(len=1024), private :: incInfo !< time and increment information - - real(pReal), private, dimension(3,3,3,3) :: & - C_volAvg = 0.0_pReal, & !< current volume average stiffness - C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness - S = 0.0_pReal !< current compliance (filled up with zeros) - - real(pReal), private :: & - err_BC !< deviation from stress BC - - integer, private :: & - totalIter = 0 !< total iteration in current increment - - public :: & - grid_mech_FEM_init, & - grid_mech_FEM_solution, & - grid_mech_FEM_forward + real(pReal), private, dimension(3,3) :: & + F_aimDot = 0.0_pReal, & !< assumed rate of average deformation gradient + F_aim = math_I3, & !< current prescribed deformation gradient + F_aim_lastIter = math_I3, & + F_aim_lastInc = math_I3, & !< previous average deformation gradient + P_av = 0.0_pReal !< average 1st Piola--Kirchhoff stress + + character(len=1024), private :: incInfo !< time and increment information + + real(pReal), private, dimension(3,3,3,3) :: & + C_volAvg = 0.0_pReal, & !< current volume average stiffness + C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness + S = 0.0_pReal !< current compliance (filled up with zeros) + + real(pReal), private :: & + err_BC !< deviation from stress BC + + integer, private :: & + totalIter = 0 !< total iteration in current increment + + public :: & + grid_mech_FEM_init, & + grid_mech_FEM_solution, & + grid_mech_FEM_forward contains @@ -78,164 +78,163 @@ subroutine grid_mech_FEM_init IO_intOut, & IO_error, & IO_open_jobFile_binary - use FEsolving, only: & - restartInc - use numerics, only: & - worldrank, & - worldsize, & - petsc_options - use homogenization, only: & - materialpoint_F0 - use DAMASK_interface, only: & - getSolverJobName - use spectral_utilities, only: & - utilities_constitutiveResponse, & - utilities_updateIPcoords, & - wgt - use mesh, only: & - geomSize, & - grid, & - grid3 - use math, only: & - math_invSym3333 - - implicit none - real(pReal) :: HGCoeff = 0e-2_pReal - PetscInt, dimension(:), allocatable :: localK - real(pReal), dimension(3,3) :: & - temp33_Real = 0.0_pReal - real(pReal), dimension(4,8) :: & - HGcomp = reshape([ 1.0_pReal, 1.0_pReal, 1.0_pReal,-1.0_pReal, & - 1.0_pReal,-1.0_pReal,-1.0_pReal, 1.0_pReal, & - -1.0_pReal, 1.0_pReal,-1.0_pReal, 1.0_pReal, & - -1.0_pReal,-1.0_pReal, 1.0_pReal,-1.0_pReal, & - -1.0_pReal,-1.0_pReal, 1.0_pReal, 1.0_pReal, & - -1.0_pReal, 1.0_pReal,-1.0_pReal,-1.0_pReal, & - 1.0_pReal,-1.0_pReal,-1.0_pReal,-1.0_pReal, & - 1.0_pReal, 1.0_pReal, 1.0_pReal, 1.0_pReal], [4,8]) - PetscErrorCode :: ierr - integer :: rank - integer(HID_T) :: fileHandle - character(len=1024) :: rankStr - real(pReal), dimension(3,3,3,3) :: devNull - PetscScalar, pointer, dimension(:,:,:,:) :: & - u_current,u_lastInc - - write(6,'(/,a)') ' <<<+- grid_mech_FEM init -+>>>' + use FEsolving, only: & + restartInc + use numerics, only: & + worldrank, & + worldsize, & + petsc_options + use homogenization, only: & + materialpoint_F0 + use DAMASK_interface, only: & + getSolverJobName + use spectral_utilities, only: & + utilities_constitutiveResponse, & + utilities_updateIPcoords, & + wgt + use mesh, only: & + geomSize, & + grid, & + grid3 + use math, only: & + math_invSym3333 + + real(pReal) :: HGCoeff = 0e-2_pReal + PetscInt, dimension(:), allocatable :: localK + real(pReal), dimension(3,3) :: & + temp33_Real = 0.0_pReal + real(pReal), dimension(4,8) :: & + HGcomp = reshape([ 1.0_pReal, 1.0_pReal, 1.0_pReal,-1.0_pReal, & + 1.0_pReal,-1.0_pReal,-1.0_pReal, 1.0_pReal, & + -1.0_pReal, 1.0_pReal,-1.0_pReal, 1.0_pReal, & + -1.0_pReal,-1.0_pReal, 1.0_pReal,-1.0_pReal, & + -1.0_pReal,-1.0_pReal, 1.0_pReal, 1.0_pReal, & + -1.0_pReal, 1.0_pReal,-1.0_pReal,-1.0_pReal, & + 1.0_pReal,-1.0_pReal,-1.0_pReal,-1.0_pReal, & + 1.0_pReal, 1.0_pReal, 1.0_pReal, 1.0_pReal], [4,8]) + PetscErrorCode :: ierr + integer :: rank + integer(HID_T) :: fileHandle + character(len=1024) :: rankStr + real(pReal), dimension(3,3,3,3) :: devNull + PetscScalar, pointer, dimension(:,:,:,:) :: & + u_current,u_lastInc + + write(6,'(/,a)') ' <<<+- grid_mech_FEM init -+>>>' !-------------------------------------------------------------------------------------------------- ! set default and user defined options for PETSc - call PETScOptionsInsertString(PETSC_NULL_OPTIONS,'-mech_snes_type newtonls -mech_ksp_type fgmres & - &-mech_ksp_max_it 25 -mech_pc_type ml -mech_mg_levels_ksp_type chebyshev',ierr) - CHKERRQ(ierr) - call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) - CHKERRQ(ierr) + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,'-mech_snes_type newtonls -mech_ksp_type fgmres & + &-mech_ksp_max_it 25 -mech_pc_type ml -mech_mg_levels_ksp_type chebyshev',ierr) + CHKERRQ(ierr) + call PETScOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) + CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! allocate global fields - allocate (F (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (P_current (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) - allocate (F_lastInc (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(F (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(P_current (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate(F_lastInc (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) !-------------------------------------------------------------------------------------------------- ! initialize solver specific parts of PETSc - call SNESCreate(PETSC_COMM_WORLD,mech_snes,ierr); CHKERRQ(ierr) - call SNESSetOptionsPrefix(mech_snes,'mech_',ierr);CHKERRQ(ierr) - allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 - do rank = 1, worldsize - call MPI_Bcast(localK(rank),1,MPI_INTEGER,rank-1,PETSC_COMM_WORLD,ierr) - enddo - call DMDACreate3d(PETSC_COMM_WORLD, & - DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, & - DMDA_STENCIL_BOX, & - grid(1),grid(2),grid(3), & - 1, 1, worldsize, & - 3, 1, & - [grid(1)],[grid(2)],localK, & - mech_grid,ierr) - CHKERRQ(ierr) - call DMDASetUniformCoordinates(mech_grid,0.0_pReal,geomSize(1),0.0_pReal,geomSize(2),0.0_pReal,geomSize(3),ierr) - CHKERRQ(ierr) - call SNESSetDM(mech_snes,mech_grid,ierr); CHKERRQ(ierr) - call DMsetFromOptions(mech_grid,ierr); CHKERRQ(ierr) - call DMsetUp(mech_grid,ierr); CHKERRQ(ierr) - call DMCreateGlobalVector(mech_grid,solution_current,ierr); CHKERRQ(ierr) - call DMCreateGlobalVector(mech_grid,solution_lastInc,ierr); CHKERRQ(ierr) - call DMCreateGlobalVector(mech_grid,solution_rate ,ierr); CHKERRQ(ierr) - call DMSNESSetFunctionLocal(mech_grid,formResidual,PETSC_NULL_SNES,ierr) - CHKERRQ(ierr) - call DMSNESSetJacobianLocal(mech_grid,formJacobian,PETSC_NULL_SNES,ierr) - CHKERRQ(ierr) - call SNESSetConvergenceTest(mech_snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) - CHKERRQ(ierr) ! specify custom convergence check function "_converged" - call SNESSetMaxLinearSolveFailures(mech_snes, huge(1), ierr); CHKERRQ(ierr) ! ignore linear solve failures - call SNESSetFromOptions(mech_snes,ierr); CHKERRQ(ierr) ! pull it all together with additional cli arguments + call SNESCreate(PETSC_COMM_WORLD,mech_snes,ierr); CHKERRQ(ierr) + call SNESSetOptionsPrefix(mech_snes,'mech_',ierr);CHKERRQ(ierr) + allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 + do rank = 1, worldsize + call MPI_Bcast(localK(rank),1,MPI_INTEGER,rank-1,PETSC_COMM_WORLD,ierr) + enddo + call DMDACreate3d(PETSC_COMM_WORLD, & + DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, DM_BOUNDARY_PERIODIC, & + DMDA_STENCIL_BOX, & + grid(1),grid(2),grid(3), & + 1, 1, worldsize, & + 3, 1, & + [grid(1)],[grid(2)],localK, & + mech_grid,ierr) + CHKERRQ(ierr) + call DMDASetUniformCoordinates(mech_grid,0.0_pReal,geomSize(1),0.0_pReal,geomSize(2),0.0_pReal,geomSize(3),ierr) + CHKERRQ(ierr) + call SNESSetDM(mech_snes,mech_grid,ierr); CHKERRQ(ierr) + call DMsetFromOptions(mech_grid,ierr); CHKERRQ(ierr) + call DMsetUp(mech_grid,ierr); CHKERRQ(ierr) + call DMCreateGlobalVector(mech_grid,solution_current,ierr); CHKERRQ(ierr) + call DMCreateGlobalVector(mech_grid,solution_lastInc,ierr); CHKERRQ(ierr) + call DMCreateGlobalVector(mech_grid,solution_rate ,ierr); CHKERRQ(ierr) + call DMSNESSetFunctionLocal(mech_grid,formResidual,PETSC_NULL_SNES,ierr) + CHKERRQ(ierr) + call DMSNESSetJacobianLocal(mech_grid,formJacobian,PETSC_NULL_SNES,ierr) + CHKERRQ(ierr) + call SNESSetConvergenceTest(mech_snes,converged,PETSC_NULL_SNES,PETSC_NULL_FUNCTION,ierr) ! specify custom convergence check function "_converged" + CHKERRQ(ierr) + call SNESSetMaxLinearSolveFailures(mech_snes, huge(1), ierr); CHKERRQ(ierr) ! ignore linear solve failures + call SNESSetFromOptions(mech_snes,ierr); CHKERRQ(ierr) ! pull it all together with additional cli arguments !-------------------------------------------------------------------------------------------------- ! init fields - call VecSet(solution_current,0.0_pReal,ierr);CHKERRQ(ierr) - call VecSet(solution_lastInc,0.0_pReal,ierr);CHKERRQ(ierr) - call VecSet(solution_rate ,0.0_pReal,ierr);CHKERRQ(ierr) - call DMDAVecGetArrayF90(mech_grid,solution_current,u_current,ierr); CHKERRQ(ierr) - call DMDAVecGetArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr); CHKERRQ(ierr) - - call DMDAGetCorners(mech_grid,xstart,ystart,zstart,xend,yend,zend,ierr) ! local grid extent - CHKERRQ(ierr) - xend = xstart+xend-1 - yend = ystart+yend-1 - zend = zstart+zend-1 - delta = geomSize/real(grid,pReal) ! grid spacing - detJ = product(delta) ! cell volume - - BMat = reshape(real([-1.0_pReal/delta(1),-1.0_pReal/delta(2),-1.0_pReal/delta(3), & - 1.0_pReal/delta(1),-1.0_pReal/delta(2),-1.0_pReal/delta(3), & - -1.0_pReal/delta(1), 1.0_pReal/delta(2),-1.0_pReal/delta(3), & - 1.0_pReal/delta(1), 1.0_pReal/delta(2),-1.0_pReal/delta(3), & - -1.0_pReal/delta(1),-1.0_pReal/delta(2), 1.0_pReal/delta(3), & - 1.0_pReal/delta(1),-1.0_pReal/delta(2), 1.0_pReal/delta(3), & - -1.0_pReal/delta(1), 1.0_pReal/delta(2), 1.0_pReal/delta(3), & - 1.0_pReal/delta(1), 1.0_pReal/delta(2), 1.0_pReal/delta(3)],pReal), [3,8])/4.0_pReal ! shape function derivative matrix - - HGMat = matmul(transpose(HGcomp),HGcomp) & - * HGCoeff*(delta(1)*delta(2) + delta(2)*delta(3) + delta(3)*delta(1))/16.0_pReal ! hourglass stabilization matrix + call VecSet(solution_current,0.0_pReal,ierr);CHKERRQ(ierr) + call VecSet(solution_lastInc,0.0_pReal,ierr);CHKERRQ(ierr) + call VecSet(solution_rate ,0.0_pReal,ierr);CHKERRQ(ierr) + call DMDAVecGetArrayF90(mech_grid,solution_current,u_current,ierr); CHKERRQ(ierr) + call DMDAVecGetArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr); CHKERRQ(ierr) + + call DMDAGetCorners(mech_grid,xstart,ystart,zstart,xend,yend,zend,ierr) ! local grid extent + CHKERRQ(ierr) + xend = xstart+xend-1 + yend = ystart+yend-1 + zend = zstart+zend-1 + delta = geomSize/real(grid,pReal) ! grid spacing + detJ = product(delta) ! cell volume + + BMat = reshape(real([-1.0_pReal/delta(1),-1.0_pReal/delta(2),-1.0_pReal/delta(3), & + 1.0_pReal/delta(1),-1.0_pReal/delta(2),-1.0_pReal/delta(3), & + -1.0_pReal/delta(1), 1.0_pReal/delta(2),-1.0_pReal/delta(3), & + 1.0_pReal/delta(1), 1.0_pReal/delta(2),-1.0_pReal/delta(3), & + -1.0_pReal/delta(1),-1.0_pReal/delta(2), 1.0_pReal/delta(3), & + 1.0_pReal/delta(1),-1.0_pReal/delta(2), 1.0_pReal/delta(3), & + -1.0_pReal/delta(1), 1.0_pReal/delta(2), 1.0_pReal/delta(3), & + 1.0_pReal/delta(1), 1.0_pReal/delta(2), 1.0_pReal/delta(3)],pReal), [3,8])/4.0_pReal ! shape function derivative matrix + + HGMat = matmul(transpose(HGcomp),HGcomp) & + * HGCoeff*(delta(1)*delta(2) + delta(2)*delta(3) + delta(3)*delta(1))/16.0_pReal ! hourglass stabilization matrix !-------------------------------------------------------------------------------------------------- ! init fields - restart: if (restartInc > 0) then - write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading values of increment ', restartInc, ' from file' - - write(rankStr,'(a1,i0)')'_',worldrank - fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') - - call HDF5_read(fileHandle,F_aim, 'F_aim') - call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') - call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') - call HDF5_read(fileHandle,F, 'F') - call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') - call HDF5_read(fileHandle,u_current, 'u') - call HDF5_read(fileHandle,u_lastInc, 'u_lastInc') - - elseif (restartInc == 0) then restart - F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity - F = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) - endif restart - materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent - call utilities_updateIPcoords(F) - call utilities_constitutiveResponse(P_current,temp33_Real,C_volAvg,devNull, & ! stress field, stress avg, global average of stiffness and (min+max)/2 - F, & ! target F - 0.0_pReal, & ! time increment - math_I3) ! no rotation of boundary condition - call DMDAVecRestoreArrayF90(mech_grid,solution_current,u_current,ierr) - CHKERRQ(ierr) - call DMDAVecRestoreArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr) - CHKERRQ(ierr) - - restartRead: if (restartInc > 0) then - write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading more values of increment ', restartInc, ' from file' - call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') - call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') - call HDF5_closeFile(fileHandle) - endif restartRead + restart: if (restartInc > 0) then + write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading values of increment ', restartInc, ' from file' + + write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') + + call HDF5_read(fileHandle,F_aim, 'F_aim') + call HDF5_read(fileHandle,F_aim_lastInc,'F_aim_lastInc') + call HDF5_read(fileHandle,F_aimDot, 'F_aimDot') + call HDF5_read(fileHandle,F, 'F') + call HDF5_read(fileHandle,F_lastInc, 'F_lastInc') + call HDF5_read(fileHandle,u_current, 'u') + call HDF5_read(fileHandle,u_lastInc, 'u_lastInc') + + elseif (restartInc == 0) then restart + F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity + F = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) + endif restart + materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent + call utilities_updateIPcoords(F) + call utilities_constitutiveResponse(P_current,temp33_Real,C_volAvg,devNull, & ! stress field, stress avg, global average of stiffness and (min+max)/2 + F, & ! target F + 0.0_pReal, & ! time increment + math_I3) ! no rotation of boundary condition + call DMDAVecRestoreArrayF90(mech_grid,solution_current,u_current,ierr) + CHKERRQ(ierr) + call DMDAVecRestoreArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr) + CHKERRQ(ierr) + + restartRead: if (restartInc > 0) then + write(6,'(/,a,'//IO_intOut(restartInc)//',a)') 'reading more values of increment ', restartInc, ' from file' + call HDF5_read(fileHandle,C_volAvg, 'C_volAvg') + call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') + call HDF5_closeFile(fileHandle) + endif restartRead end subroutine grid_mech_FEM_init @@ -244,58 +243,57 @@ end subroutine grid_mech_FEM_init !> @brief solution for the FEM scheme with internal iterations !-------------------------------------------------------------------------------------------------- function grid_mech_FEM_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation_BC) result(solution) - use IO, only: & - IO_error - use spectral_utilities, only: & - tBoundaryCondition, & - utilities_maskedCompliance - use FEsolving, only: & - restartWrite, & - terminallyIll + use IO, only: & + IO_error + use spectral_utilities, only: & + tBoundaryCondition, & + utilities_maskedCompliance + use FEsolving, only: & + restartWrite, & + terminallyIll - implicit none !-------------------------------------------------------------------------------------------------- ! input data for solution - character(len=*), intent(in) :: & - incInfoIn - real(pReal), intent(in) :: & - timeinc, & !< time increment of current solution - timeinc_old !< time increment of last successful increment - type(tBoundaryCondition), intent(in) :: & - stress_BC - real(pReal), dimension(3,3), intent(in) :: rotation_BC - type(tSolutionState) :: & - solution + character(len=*), intent(in) :: & + incInfoIn + real(pReal), intent(in) :: & + timeinc, & !< time increment of current solution + timeinc_old !< time increment of last successful increment + type(tBoundaryCondition), intent(in) :: & + stress_BC + real(pReal), dimension(3,3), intent(in) :: rotation_BC + type(tSolutionState) :: & + solution !-------------------------------------------------------------------------------------------------- ! PETSc Data - PetscErrorCode :: ierr - SNESConvergedReason :: reason - - incInfo = incInfoIn + PetscErrorCode :: ierr + SNESConvergedReason :: reason + + incInfo = incInfoIn !-------------------------------------------------------------------------------------------------- ! update stiffness (and gamma operator) - S = utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) + S = utilities_maskedCompliance(rotation_BC,stress_BC%maskLogical,C_volAvg) !-------------------------------------------------------------------------------------------------- ! set module wide available data - params%stress_mask = stress_BC%maskFloat - params%stress_BC = stress_BC%values - params%rotation_BC = rotation_BC - params%timeinc = timeinc - params%timeincOld = timeinc_old + params%stress_mask = stress_BC%maskFloat + params%stress_BC = stress_BC%values + params%rotation_BC = rotation_BC + params%timeinc = timeinc + params%timeincOld = timeinc_old !-------------------------------------------------------------------------------------------------- ! solve BVP - call SNESsolve(mech_snes,PETSC_NULL_VEC,solution_current,ierr);CHKERRQ(ierr) + call SNESsolve(mech_snes,PETSC_NULL_VEC,solution_current,ierr);CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! check convergence - call SNESGetConvergedReason(mech_snes,reason,ierr);CHKERRQ(ierr) - - solution%converged = reason > 0 - solution%iterationsNeeded = totalIter - solution%termIll = terminallyIll - terminallyIll = .false. + call SNESGetConvergedReason(mech_snes,reason,ierr);CHKERRQ(ierr) + + solution%converged = reason > 0 + solution%iterationsNeeded = totalIter + solution%termIll = terminallyIll + terminallyIll = .false. end function grid_mech_FEM_solution @@ -326,13 +324,12 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat use FEsolving, only: & restartWrite - implicit none logical, intent(in) :: & guess real(pReal), intent(in) :: & timeinc_old, & timeinc, & - loadCaseTime !< remaining time of current load case + loadCaseTime !< remaining time of current load case type(tBoundaryCondition), intent(in) :: & stress_BC, & deformation_BC @@ -344,15 +341,15 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat PetscScalar, pointer, dimension(:,:,:,:) :: & u_current,u_lastInc - call DMDAVecGetArrayF90(mech_grid,solution_current,u_current,ierr); CHKERRQ(ierr) - call DMDAVecGetArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr); CHKERRQ(ierr) + call DMDAVecGetArrayF90(mech_grid,solution_current,u_current,ierr); CHKERRQ(ierr) + call DMDAVecGetArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr); CHKERRQ(ierr) if (cutBack) then C_volAvg = C_volAvgLastInc ! QUESTION: where is this required? else !-------------------------------------------------------------------------------------------------- ! restart information for spectral solver - if (restartWrite) then ! QUESTION: where is this logical properly set? + if (restartWrite) then write(6,'(/,a)') ' writing converged results for restart';flush(6) write(rankStr,'(a1,i0)')'_',worldrank @@ -372,7 +369,7 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat call HDF5_closeFile(fileHandle) endif - call CPFEM_age ! age state and kinematics + call CPFEM_age ! age state and kinematics call utilities_updateIPcoords(F) C_volAvgLastInc = C_volAvg @@ -382,13 +379,13 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat !-------------------------------------------------------------------------------------------------- ! calculate rate for aim - if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F + if (deformation_BC%myType=='l') then ! calculate F_aimDot from given L and current F F_aimDot = & F_aimDot + deformation_BC%maskFloat * matmul(deformation_BC%values, F_aim_lastInc) - elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed + elseif(deformation_BC%myType=='fdot') then ! F_aimDot is prescribed F_aimDot = & F_aimDot + deformation_BC%maskFloat * deformation_BC%values - elseif (deformation_BC%myType=='f') then ! aim at end of load case is prescribed + elseif (deformation_BC%myType=='f') then ! aim at end of load case is prescribed F_aimDot = & F_aimDot + deformation_BC%maskFloat * (deformation_BC%values - F_aim_lastInc)/loadCaseTime endif @@ -403,20 +400,20 @@ subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformat endif call VecCopy(solution_current,solution_lastInc,ierr); CHKERRQ(ierr) - F_lastInc = F ! winding F forward - materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent + F_lastInc = F ! winding F forward + materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) ! set starting condition for materialpoint_stressAndItsTangent endif !-------------------------------------------------------------------------------------------------- ! update average and local deformation gradients - F_aim = F_aim_lastInc + F_aimDot * timeinc - call VecAXPY(solution_current,timeinc,solution_rate,ierr); CHKERRQ(ierr) + F_aim = F_aim_lastInc + F_aimDot * timeinc + call VecAXPY(solution_current,timeinc,solution_rate,ierr); CHKERRQ(ierr) - call DMDAVecRestoreArrayF90(mech_grid,solution_current,u_current,ierr) - CHKERRQ(ierr) - call DMDAVecRestoreArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr) - CHKERRQ(ierr) + call DMDAVecRestoreArrayF90(mech_grid,solution_current,u_current,ierr) + CHKERRQ(ierr) + call DMDAVecRestoreArrayF90(mech_grid,solution_lastInc,u_lastInc,ierr) + CHKERRQ(ierr) end subroutine grid_mech_FEM_forward @@ -424,58 +421,57 @@ end subroutine grid_mech_FEM_forward !-------------------------------------------------------------------------------------------------- !> @brief convergence check !-------------------------------------------------------------------------------------------------- -subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dummy,ierr) - use mesh - use spectral_utilities - use numerics, only: & - itmax, & - itmin, & - err_div_tolRel, & - err_div_tolAbs, & - err_stress_tolRel, & - err_stress_tolAbs - use FEsolving, only: & - terminallyIll +subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,ierr) + use mesh + use spectral_utilities + use numerics, only: & + itmax, & + itmin, & + err_div_tolRel, & + err_div_tolAbs, & + err_stress_tolRel, & + err_stress_tolAbs + use FEsolving, only: & + terminallyIll - implicit none - SNES :: snes_local - PetscInt, intent(in) :: PETScIter - PetscReal, intent(in) :: & - devNull1, & - devNull2, & - devNull3 - SNESConvergedReason :: reason - PetscObject :: dummy - PetscErrorCode :: ierr - real(pReal) :: & - err_div, & - divTol, & - BCTol + SNES :: snes_local + PetscInt, intent(in) :: PETScIter + PetscReal, intent(in) :: & + devNull1, & + devNull2, & + fnorm + SNESConvergedReason :: reason + PetscObject :: dummy + PetscErrorCode :: ierr + real(pReal) :: & + err_div, & + divTol, & + BCTol - err_div = fnorm*sqrt(wgt)*geomSize(1)/scaledGeomSize(1)/detJ - divTol = max(maxval(abs(P_av))*err_div_tolRel ,err_div_tolAbs) - BCTol = max(maxval(abs(P_av))*err_stress_tolRel,err_stress_tolAbs) + err_div = fnorm*sqrt(wgt)*geomSize(1)/scaledGeomSize(1)/detJ + divTol = max(maxval(abs(P_av))*err_div_tolRel ,err_div_tolAbs) + BCTol = max(maxval(abs(P_av))*err_stress_tolRel,err_stress_tolAbs) - if ((totalIter >= itmin .and. & - all([ err_div/divTol, & - err_BC /BCTol ] < 1.0_pReal)) & - .or. terminallyIll) then - reason = 1 - elseif (totalIter >= itmax) then - reason = -1 - else - reason = 0 - endif + if ((totalIter >= itmin .and. & + all([ err_div/divTol, & + err_BC /BCTol ] < 1.0_pReal)) & + .or. terminallyIll) then + reason = 1 + elseif (totalIter >= itmax) then + reason = -1 + else + reason = 0 + endif !-------------------------------------------------------------------------------------------------- ! report - write(6,'(1/,a)') ' ... reporting .............................................................' - write(6,'(1/,a,f12.2,a,es8.2,a,es9.2,a)') ' error divergence = ', & - err_div/divTol, ' (',err_div,' / m, tol = ',divTol,')' - write(6,'(a,f12.2,a,es8.2,a,es9.2,a)') ' error stress BC = ', & - err_BC/BCTol, ' (',err_BC, ' Pa, tol = ',BCTol,')' - write(6,'(/,a)') ' ===========================================================================' - flush(6) + write(6,'(1/,a)') ' ... reporting .............................................................' + write(6,'(1/,a,f12.2,a,es8.2,a,es9.2,a)') ' error divergence = ', & + err_div/divTol, ' (',err_div,' / m, tol = ',divTol,')' + write(6,'(a,f12.2,a,es8.2,a,es9.2,a)') ' error stress BC = ', & + err_BC/BCTol, ' (',err_BC, ' Pa, tol = ',BCTol,')' + write(6,'(/,a)') ' ===========================================================================' + flush(6) end subroutine converged @@ -485,135 +481,134 @@ end subroutine converged !-------------------------------------------------------------------------------------------------- subroutine formResidual(da_local,x_local, & f_local,dummy,ierr) - use numerics, only: & - itmax, & - itmin - use numerics, only: & - worldrank - use mesh, only: & - grid - use math, only: & - math_rotate_backward33, & - math_mul3333xx33 - use debug, only: & - debug_level, & - debug_spectral, & - debug_spectralRotation - use spectral_utilities, only: & - utilities_constitutiveResponse - use IO, only: & - IO_intOut - use FEsolving, only: & - terminallyIll - use homogenization, only: & - materialpoint_dPdF + use numerics, only: & + itmax, & + itmin + use numerics, only: & + worldrank + use mesh, only: & + grid + use math, only: & + math_rotate_backward33, & + math_mul3333xx33 + use debug, only: & + debug_level, & + debug_spectral, & + debug_spectralRotation + use spectral_utilities, only: & + utilities_constitutiveResponse + use IO, only: & + IO_intOut + use FEsolving, only: & + terminallyIll + use homogenization, only: & + materialpoint_dPdF - implicit none - DM :: da_local - Vec :: x_local, f_local - PetscScalar, pointer,dimension(:,:,:,:) :: x_scal, f_scal - PetscScalar, dimension(8,3) :: x_elem, f_elem - PetscInt :: i, ii, j, jj, k, kk, ctr, ele - real(pReal), dimension(3,3) :: & - deltaF_aim - PetscInt :: & - PETScIter, & - nfuncs - PetscObject :: dummy - PetscErrorCode :: ierr - real(pReal), dimension(3,3,3,3) :: devNull + DM :: da_local + Vec :: x_local, f_local + PetscScalar, pointer,dimension(:,:,:,:) :: x_scal, f_scal + PetscScalar, dimension(8,3) :: x_elem, f_elem + PetscInt :: i, ii, j, jj, k, kk, ctr, ele + real(pReal), dimension(3,3) :: & + deltaF_aim + PetscInt :: & + PETScIter, & + nfuncs + PetscObject :: dummy + PetscErrorCode :: ierr + real(pReal), dimension(3,3,3,3) :: devNull - call SNESGetNumberFunctionEvals(mech_snes,nfuncs,ierr); CHKERRQ(ierr) - call SNESGetIterationNumber(mech_snes,PETScIter,ierr); CHKERRQ(ierr) + call SNESGetNumberFunctionEvals(mech_snes,nfuncs,ierr); CHKERRQ(ierr) + call SNESGetIterationNumber(mech_snes,PETScIter,ierr); CHKERRQ(ierr) - if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1 ! new increment + if (nfuncs == 0 .and. PETScIter == 0) totalIter = -1 ! new increment !-------------------------------------------------------------------------------------------------- ! begin of new iteration - newIteration: if (totalIter <= PETScIter) then - totalIter = totalIter + 1 - write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') & - trim(incInfo), ' @ Iteration ', itmin, '≤',totalIter+1, '≤', itmax - if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & - write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & - ' deformation gradient aim (lab) =', transpose(math_rotate_backward33(F_aim,params%rotation_BC)) - write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & - ' deformation gradient aim =', transpose(F_aim) - flush(6) - endif newIteration + newIteration: if (totalIter <= PETScIter) then + totalIter = totalIter + 1 + write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') & + trim(incInfo), ' @ Iteration ', itmin, '≤',totalIter+1, '≤', itmax + if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & + ' deformation gradient aim (lab) =', transpose(math_rotate_backward33(F_aim,params%rotation_BC)) + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') & + ' deformation gradient aim =', transpose(F_aim) + flush(6) + endif newIteration !-------------------------------------------------------------------------------------------------- ! get deformation gradient - call DMDAVecGetArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) - do k = zstart, zend; do j = ystart, yend; do i = xstart, xend - ctr = 0 - do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 - ctr = ctr + 1 - x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) - enddo; enddo; enddo - ii = i-xstart+1; jj = j-ystart+1; kk = k-zstart+1 - F(1:3,1:3,ii,jj,kk) = math_rotate_backward33(F_aim,params%rotation_BC) + transpose(matmul(BMat,x_elem)) - enddo; enddo; enddo - call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) + call DMDAVecGetArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) + do k = zstart, zend; do j = ystart, yend; do i = xstart, xend + ctr = 0 + do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 + ctr = ctr + 1 + x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) + enddo; enddo; enddo + ii = i-xstart+1; jj = j-ystart+1; kk = k-zstart+1 + F(1:3,1:3,ii,jj,kk) = math_rotate_backward33(F_aim,params%rotation_BC) + transpose(matmul(BMat,x_elem)) + enddo; enddo; enddo + call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! evaluate constitutive response - call Utilities_constitutiveResponse(P_current,& - P_av,C_volAvg,devNull, & - F,params%timeinc,params%rotation_BC) - call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) + call Utilities_constitutiveResponse(P_current,& + P_av,C_volAvg,devNull, & + F,params%timeinc,params%rotation_BC) + call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) !-------------------------------------------------------------------------------------------------- ! stress BC handling - F_aim_lastIter = F_aim - deltaF_aim = math_mul3333xx33(S, P_av - params%stress_BC) - F_aim = F_aim - deltaF_aim - err_BC = maxval(abs(params%stress_mask * (P_av - params%stress_BC))) ! mask = 0.0 when no stress bc + F_aim_lastIter = F_aim + deltaF_aim = math_mul3333xx33(S, P_av - params%stress_BC) + F_aim = F_aim - deltaF_aim + err_BC = maxval(abs(params%stress_mask * (P_av - params%stress_BC))) ! mask = 0.0 when no stress bc !-------------------------------------------------------------------------------------------------- ! constructing residual - call VecSet(f_local,0.0_pReal,ierr);CHKERRQ(ierr) - call DMDAVecGetArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) - call DMDAVecGetArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) - ele = 0 - do k = zstart, zend; do j = ystart, yend; do i = xstart, xend - ctr = 0 - do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 - ctr = ctr + 1 - x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) - enddo; enddo; enddo - ii = i-xstart+1; jj = j-ystart+1; kk = k-zstart+1 - ele = ele + 1 - f_elem = matmul(transpose(BMat),transpose(P_current(1:3,1:3,ii,jj,kk)))*detJ + & - matmul(HGMat,x_elem)*(materialpoint_dPdF(1,1,1,1,1,ele) + & - materialpoint_dPdF(2,2,2,2,1,ele) + & - materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal - ctr = 0 - do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 - ctr = ctr + 1 - f_scal(0:2,i+ii,j+jj,k+kk) = f_scal(0:2,i+ii,j+jj,k+kk) + f_elem(ctr,1:3) - enddo; enddo; enddo - enddo; enddo; enddo - call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) - call DMDAVecRestoreArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) + call VecSet(f_local,0.0_pReal,ierr);CHKERRQ(ierr) + call DMDAVecGetArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) + call DMDAVecGetArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) + ele = 0 + do k = zstart, zend; do j = ystart, yend; do i = xstart, xend + ctr = 0 + do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 + ctr = ctr + 1 + x_elem(ctr,1:3) = x_scal(0:2,i+ii,j+jj,k+kk) + enddo; enddo; enddo + ii = i-xstart+1; jj = j-ystart+1; kk = k-zstart+1 + ele = ele + 1 + f_elem = matmul(transpose(BMat),transpose(P_current(1:3,1:3,ii,jj,kk)))*detJ + & + matmul(HGMat,x_elem)*(materialpoint_dPdF(1,1,1,1,1,ele) + & + materialpoint_dPdF(2,2,2,2,1,ele) + & + materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal + ctr = 0 + do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 + ctr = ctr + 1 + f_scal(0:2,i+ii,j+jj,k+kk) = f_scal(0:2,i+ii,j+jj,k+kk) + f_elem(ctr,1:3) + enddo; enddo; enddo + enddo; enddo; enddo + call DMDAVecRestoreArrayF90(da_local,x_local,x_scal,ierr);CHKERRQ(ierr) + call DMDAVecRestoreArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! applying boundary conditions - call DMDAVecGetArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) - if (zstart == 0) then - f_scal(0:2,xstart,ystart,zstart) = 0.0 - f_scal(0:2,xend+1,ystart,zstart) = 0.0 - f_scal(0:2,xstart,yend+1,zstart) = 0.0 - f_scal(0:2,xend+1,yend+1,zstart) = 0.0 - endif - if (zend + 1 == grid(3)) then - f_scal(0:2,xstart,ystart,zend+1) = 0.0 - f_scal(0:2,xend+1,ystart,zend+1) = 0.0 - f_scal(0:2,xstart,yend+1,zend+1) = 0.0 - f_scal(0:2,xend+1,yend+1,zend+1) = 0.0 - endif - call DMDAVecRestoreArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) + call DMDAVecGetArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) + if (zstart == 0) then + f_scal(0:2,xstart,ystart,zstart) = 0.0 + f_scal(0:2,xend+1,ystart,zstart) = 0.0 + f_scal(0:2,xstart,yend+1,zstart) = 0.0 + f_scal(0:2,xend+1,yend+1,zstart) = 0.0 + endif + if (zend + 1 == grid(3)) then + f_scal(0:2,xstart,ystart,zend+1) = 0.0 + f_scal(0:2,xend+1,ystart,zend+1) = 0.0 + f_scal(0:2,xstart,yend+1,zend+1) = 0.0 + f_scal(0:2,xend+1,yend+1,zend+1) = 0.0 + endif + call DMDAVecRestoreArrayF90(da_local,f_local,f_scal,ierr);CHKERRQ(ierr) end subroutine formResidual @@ -622,97 +617,96 @@ end subroutine formResidual !> @brief forms the FEM stiffness matrix !-------------------------------------------------------------------------------------------------- subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,ierr) - use mesh, only: & - mesh_ipCoordinates - use homogenization, only: & - materialpoint_dPdF - - implicit none - - DM :: da_local - Vec :: x_local, coordinates - Mat :: Jac_pre, Jac - MatStencil,dimension(4,24) :: row, col - PetscScalar,pointer,dimension(:,:,:,:) :: x_scal - PetscScalar,dimension(24,24) :: K_ele - PetscScalar,dimension(9,24) :: BMatFull - PetscInt :: i, ii, j, jj, k, kk, ctr, ele - PetscInt,dimension(3) :: rows - PetscScalar :: diag - PetscObject :: dummy - MatNullSpace :: matnull - PetscErrorCode :: ierr + use mesh, only: & + mesh_ipCoordinates + use homogenization, only: & + materialpoint_dPdF - BMatFull = 0.0 - BMatFull(1:3,1 :8 ) = BMat - BMatFull(4:6,9 :16) = BMat - BMatFull(7:9,17:24) = BMat - call MatSetOption(Jac,MAT_KEEP_NONZERO_PATTERN,PETSC_TRUE,ierr); CHKERRQ(ierr) - call MatSetOption(Jac,MAT_NEW_NONZERO_ALLOCATION_ERR,PETSC_FALSE,ierr); CHKERRQ(ierr) - call MatZeroEntries(Jac,ierr); CHKERRQ(ierr) - ele = 0 - do k = zstart, zend; do j = ystart, yend; do i = xstart, xend - ctr = 0 - do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 - ctr = ctr + 1 - col(MatStencil_i,ctr ) = i+ii - col(MatStencil_j,ctr ) = j+jj - col(MatStencil_k,ctr ) = k+kk - col(MatStencil_c,ctr ) = 0 - col(MatStencil_i,ctr+8 ) = i+ii - col(MatStencil_j,ctr+8 ) = j+jj - col(MatStencil_k,ctr+8 ) = k+kk - col(MatStencil_c,ctr+8 ) = 1 - col(MatStencil_i,ctr+16) = i+ii - col(MatStencil_j,ctr+16) = j+jj - col(MatStencil_k,ctr+16) = k+kk - col(MatStencil_c,ctr+16) = 2 - enddo; enddo; enddo - row = col - ele = ele + 1 - K_ele = 0.0 - K_ele(1 :8 ,1 :8 ) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & - materialpoint_dPdF(2,2,2,2,1,ele) + & - materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal - K_ele(9 :16,9 :16) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & - materialpoint_dPdF(2,2,2,2,1,ele) + & - materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal - K_ele(17:24,17:24) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & - materialpoint_dPdF(2,2,2,2,1,ele) + & - materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal - K_ele = K_ele + & - matmul(transpose(BMatFull), & - matmul(reshape(reshape(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,ele), & - shape=[3,3,3,3], order=[2,1,4,3]),shape=[9,9]),BMatFull))*detJ - call MatSetValuesStencil(Jac,24,row,24,col,K_ele,ADD_VALUES,ierr) - CHKERRQ(ierr) - enddo; enddo; enddo - call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - call MatAssemblyBegin(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - call MatAssemblyEnd(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + + DM :: da_local + Vec :: x_local, coordinates + Mat :: Jac_pre, Jac + MatStencil,dimension(4,24) :: row, col + PetscScalar,pointer,dimension(:,:,:,:) :: x_scal + PetscScalar,dimension(24,24) :: K_ele + PetscScalar,dimension(9,24) :: BMatFull + PetscInt :: i, ii, j, jj, k, kk, ctr, ele + PetscInt,dimension(3) :: rows + PetscScalar :: diag + PetscObject :: dummy + MatNullSpace :: matnull + PetscErrorCode :: ierr + + BMatFull = 0.0 + BMatFull(1:3,1 :8 ) = BMat + BMatFull(4:6,9 :16) = BMat + BMatFull(7:9,17:24) = BMat + call MatSetOption(Jac,MAT_KEEP_NONZERO_PATTERN,PETSC_TRUE,ierr); CHKERRQ(ierr) + call MatSetOption(Jac,MAT_NEW_NONZERO_ALLOCATION_ERR,PETSC_FALSE,ierr); CHKERRQ(ierr) + call MatZeroEntries(Jac,ierr); CHKERRQ(ierr) + ele = 0 + do k = zstart, zend; do j = ystart, yend; do i = xstart, xend + ctr = 0 + do kk = 0, 1; do jj = 0, 1; do ii = 0, 1 + ctr = ctr + 1 + col(MatStencil_i,ctr ) = i+ii + col(MatStencil_j,ctr ) = j+jj + col(MatStencil_k,ctr ) = k+kk + col(MatStencil_c,ctr ) = 0 + col(MatStencil_i,ctr+8 ) = i+ii + col(MatStencil_j,ctr+8 ) = j+jj + col(MatStencil_k,ctr+8 ) = k+kk + col(MatStencil_c,ctr+8 ) = 1 + col(MatStencil_i,ctr+16) = i+ii + col(MatStencil_j,ctr+16) = j+jj + col(MatStencil_k,ctr+16) = k+kk + col(MatStencil_c,ctr+16) = 2 + enddo; enddo; enddo + row = col + ele = ele + 1 + K_ele = 0.0 + K_ele(1 :8 ,1 :8 ) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & + materialpoint_dPdF(2,2,2,2,1,ele) + & + materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal + K_ele(9 :16,9 :16) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & + materialpoint_dPdF(2,2,2,2,1,ele) + & + materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal + K_ele(17:24,17:24) = HGMat*(materialpoint_dPdF(1,1,1,1,1,ele) + & + materialpoint_dPdF(2,2,2,2,1,ele) + & + materialpoint_dPdF(3,3,3,3,1,ele))/3.0_pReal + K_ele = K_ele + & + matmul(transpose(BMatFull), & + matmul(reshape(reshape(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,ele), & + shape=[3,3,3,3], order=[2,1,4,3]),shape=[9,9]),BMatFull))*detJ + call MatSetValuesStencil(Jac,24,row,24,col,K_ele,ADD_VALUES,ierr) + CHKERRQ(ierr) + enddo; enddo; enddo + call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyBegin(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyEnd(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! applying boundary conditions - rows = [0, 1, 2] - diag = (C_volAvg(1,1,1,1)/delta(1)**2.0_pReal + & - C_volAvg(2,2,2,2)/delta(2)**2.0_pReal + & - C_volAvg(3,3,3,3)/delta(3)**2.0_pReal)*detJ - call MatZeroRowsColumns(Jac,size(rows),rows,diag,PETSC_NULL_VEC,PETSC_NULL_VEC,ierr) - CHKERRQ(ierr) - call DMGetGlobalVector(da_local,coordinates,ierr);CHKERRQ(ierr) - call DMDAVecGetArrayF90(da_local,coordinates,x_scal,ierr);CHKERRQ(ierr) - ele = 0 - do k = zstart, zend; do j = ystart, yend; do i = xstart, xend - ele = ele + 1 - x_scal(0:2,i,j,k) = mesh_ipCoordinates(1:3,1,ele) - enddo; enddo; enddo - call DMDAVecRestoreArrayF90(da_local,coordinates,x_scal,ierr);CHKERRQ(ierr) ! initialize to undeformed coordinates (ToDo: use ip coordinates) - call MatNullSpaceCreateRigidBody(coordinates,matnull,ierr);CHKERRQ(ierr) ! get rigid body deformation modes - call DMRestoreGlobalVector(da_local,coordinates,ierr);CHKERRQ(ierr) - call MatSetNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) - call MatSetNearNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) - call MatNullSpaceDestroy(matnull,ierr); CHKERRQ(ierr) + rows = [0, 1, 2] + diag = (C_volAvg(1,1,1,1)/delta(1)**2.0_pReal + & + C_volAvg(2,2,2,2)/delta(2)**2.0_pReal + & + C_volAvg(3,3,3,3)/delta(3)**2.0_pReal)*detJ + call MatZeroRowsColumns(Jac,size(rows),rows,diag,PETSC_NULL_VEC,PETSC_NULL_VEC,ierr) + CHKERRQ(ierr) + call DMGetGlobalVector(da_local,coordinates,ierr);CHKERRQ(ierr) + call DMDAVecGetArrayF90(da_local,coordinates,x_scal,ierr);CHKERRQ(ierr) + ele = 0 + do k = zstart, zend; do j = ystart, yend; do i = xstart, xend + ele = ele + 1 + x_scal(0:2,i,j,k) = mesh_ipCoordinates(1:3,1,ele) + enddo; enddo; enddo + call DMDAVecRestoreArrayF90(da_local,coordinates,x_scal,ierr);CHKERRQ(ierr) ! initialize to undeformed coordinates (ToDo: use ip coordinates) + call MatNullSpaceCreateRigidBody(coordinates,matnull,ierr);CHKERRQ(ierr) ! get rigid body deformation modes + call DMRestoreGlobalVector(da_local,coordinates,ierr);CHKERRQ(ierr) + call MatSetNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) + call MatSetNearNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) + call MatNullSpaceDestroy(matnull,ierr); CHKERRQ(ierr) end subroutine formJacobian diff --git a/src/grid_mech_spectral_basic.f90 b/src/grid_mech_spectral_basic.f90 index 91dcd03b4..f698fdc6d 100644 --- a/src/grid_mech_spectral_basic.f90 +++ b/src/grid_mech_spectral_basic.f90 @@ -107,7 +107,6 @@ subroutine grid_mech_spectral_basic_init use math, only: & math_invSym3333 - implicit none real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P real(pReal), dimension(3,3) :: & temp33_Real = 0.0_pReal @@ -221,7 +220,6 @@ function grid_mech_spectral_basic_solution(incInfoIn,timeinc,timeinc_old,stress_ restartWrite, & terminallyIll - implicit none !-------------------------------------------------------------------------------------------------- ! input data for solution character(len=*), intent(in) :: & @@ -298,7 +296,6 @@ subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTi use FEsolving, only: & restartWrite - implicit none logical, intent(in) :: & guess real(pReal), intent(in) :: & @@ -397,7 +394,6 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dumm use FEsolving, only: & terminallyIll - implicit none SNES :: snes_local PetscInt, intent(in) :: PETScIter PetscReal, intent(in) :: & @@ -468,7 +464,6 @@ subroutine formResidual(in, F, & use FEsolving, only: & terminallyIll - implicit none DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: in !< DMDA info (needs to be named "in" for macros like XRANGE to work) PetscScalar, dimension(3,3,XG_RANGE,YG_RANGE,ZG_RANGE), & intent(in) :: F !< deformation gradient field diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 index a7bf75209..55df4455f 100644 --- a/src/grid_mech_spectral_polarisation.f90 +++ b/src/grid_mech_spectral_polarisation.f90 @@ -113,7 +113,6 @@ subroutine grid_mech_spectral_polarisation_init use math, only: & math_invSym3333 - implicit none real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P real(pReal), dimension(3,3) :: & temp33_Real = 0.0_pReal @@ -238,7 +237,6 @@ function grid_mech_spectral_polarisation_solution(incInfoIn,timeinc,timeinc_old, restartWrite, & terminallyIll - implicit none !-------------------------------------------------------------------------------------------------- ! input data for solution character(len=*), intent(in) :: & @@ -445,7 +443,6 @@ subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dumm use FEsolving, only: & terminallyIll - implicit none SNES :: snes_local PetscInt, intent(in) :: PETScIter PetscReal, intent(in) :: & @@ -529,7 +526,6 @@ subroutine formResidual(in, FandF_tau, & use FEsolving, only: & terminallyIll - implicit none DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: in !< DMDA info (needs to be named "in" for macros like XRANGE to work) PetscScalar, dimension(3,3,2,XG_RANGE,YG_RANGE,ZG_RANGE), & target, intent(in) :: FandF_tau diff --git a/src/grid_thermal_spectral.f90 b/src/grid_thermal_spectral.f90 index 31740feb9..e899fd89a 100644 --- a/src/grid_thermal_spectral.f90 +++ b/src/grid_thermal_spectral.f90 @@ -69,7 +69,6 @@ subroutine grid_thermal_spectral_init worldsize, & petsc_options - implicit none PetscInt, dimension(worldsize) :: localK integer :: i, j, k, cell DM :: thermal_grid @@ -167,7 +166,6 @@ function grid_thermal_spectral_solution(timeinc,timeinc_old,loadCaseTime) result use thermal_conduction, only: & thermal_conduction_putTemperatureAndItsRate - implicit none real(pReal), intent(in) :: & timeinc, & !< increment in time for current solution timeinc_old, & !< increment in time of last increment @@ -242,7 +240,6 @@ subroutine grid_thermal_spectral_forward thermal_conduction_getMassDensity, & thermal_conduction_getSpecificHeat - implicit none integer :: i, j, k, cell DM :: dm_local PetscScalar, dimension(:,:,:), pointer :: x_scal @@ -311,7 +308,6 @@ subroutine formResidual(in,x_scal,f_scal,dummy,ierr) thermal_conduction_getMassDensity, & thermal_conduction_getSpecificHeat - implicit none DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & in PetscScalar, dimension( & From ed8270d432ab971b09d8f4838fcf700470492718 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 16 Apr 2019 14:53:36 +0200 Subject: [PATCH 59/97] need to read reference stiffness --- src/grid_mech_spectral_basic.f90 | 3 +++ src/grid_mech_spectral_polarisation.f90 | 3 +++ 2 files changed, 6 insertions(+) diff --git a/src/grid_mech_spectral_basic.f90 b/src/grid_mech_spectral_basic.f90 index f698fdc6d..2daebefbd 100644 --- a/src/grid_mech_spectral_basic.f90 +++ b/src/grid_mech_spectral_basic.f90 @@ -116,6 +116,7 @@ subroutine grid_mech_spectral_basic_init F ! pointer to solution data PetscInt, dimension(worldsize) :: localK integer(HID_T) :: fileHandle + integer :: fileUnit character(len=1024) :: rankStr write(6,'(/,a)') ' <<<+- grid_mech_spectral_basic init -+>>>' @@ -201,6 +202,8 @@ subroutine grid_mech_spectral_basic_init call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') call HDF5_closeFile(fileHandle) + fileUnit = IO_open_jobFile_binary('C_ref') + read(fileUnit) C_minMaxAvg; close(fileUnit) endif restartRead call utilities_updateGamma(C_minMaxAvg,.true.) diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid_mech_spectral_polarisation.f90 index 55df4455f..3bd30a360 100644 --- a/src/grid_mech_spectral_polarisation.f90 +++ b/src/grid_mech_spectral_polarisation.f90 @@ -124,6 +124,7 @@ subroutine grid_mech_spectral_polarisation_init F_tau ! specific (sub)pointer PetscInt, dimension(worldsize) :: localK integer(HID_T) :: fileHandle + integer :: fileUnit character(len=1024) :: rankStr write(6,'(/,a)') ' <<<+- grid_mech_spectral_polarisation init -+>>>' @@ -214,6 +215,8 @@ subroutine grid_mech_spectral_polarisation_init call HDF5_read(fileHandle,C_volAvgLastInc,'C_volAvgLastInc') call HDF5_closeFile(fileHandle) + fileUnit = IO_open_jobFile_binary('C_ref') + read(fileUnit) C_minMaxAvg; close(fileUnit) endif restartRead call utilities_updateGamma(C_minMaxAvg,.true.) From 7177813710995ae5cb886dc03f01accbd429f6c0 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 17 Apr 2019 19:57:16 +0200 Subject: [PATCH 60/97] adding data to geometry --- processing/post/DADF5_vtk_cells.py | 10 ++++-- python/damask/dadf5.py | 49 +++++++++++++++++++++++++++--- 2 files changed, 52 insertions(+), 7 deletions(-) diff --git a/processing/post/DADF5_vtk_cells.py b/processing/post/DADF5_vtk_cells.py index 008ac5f66..85b999a19 100755 --- a/processing/post/DADF5_vtk_cells.py +++ b/processing/post/DADF5_vtk_cells.py @@ -5,6 +5,7 @@ import os,vtk import numpy as np import argparse import damask +from vtk.util import numpy_support scriptName = os.path.splitext(os.path.basename(__file__))[0] scriptID = ' '.join([scriptName,damask.version]) @@ -36,7 +37,7 @@ for filename in options.filenames: vtk.vtkDoubleArray(), ] - rGrid.SetDimensions(*data.grid) + rGrid.SetDimensions(*(data.grid+1)) for dim in [0,1,2]: for c in np.linspace(0,data.size[dim],1+data.grid[dim]): coordArray[dim].InsertNextValue(c) @@ -47,8 +48,11 @@ for filename in options.filenames: for i,inc in enumerate(data.increments): - if not inc['active']: pass - + data.active['increments'] = [inc] + x = data.get_dataset_location('xi_sl')[0] + VTKarray = numpy_support.numpy_to_vtk(num_array=data.read_dataset(x,0),deep=True,array_type= vtk.VTK_DOUBLE) + VTKarray.SetName('xi_sl') + rGrid.GetCellData().AddArray(VTKarray) if data.structured: writer = vtk.vtkXMLRectilinearGridWriter() diff --git a/python/damask/dadf5.py b/python/damask/dadf5.py index 6342b18e7..043997547 100644 --- a/python/damask/dadf5.py +++ b/python/damask/dadf5.py @@ -1,6 +1,8 @@ # -*- coding: UTF-8 no BOM -*- import h5py import re +import numpy as np +import os # ------------------------------------------------------------------ class DADF5(): @@ -20,7 +22,7 @@ class DADF5(): with h5py.File(filename,'r') as f: if f.attrs['DADF5-major'] != 0 or f.attrs['DADF5-minor'] != 1: - print('Unsupported DADF5 version {} '.format(f.attrs['DADF5-version'])) + raise TypeError('Unsupported DADF5 version {} '.format(f.attrs['DADF5-version'])) self.structured = 'grid' in f['mapping'].attrs.keys() @@ -29,10 +31,49 @@ class DADF5(): self.size = f['mapping'].attrs['size'] r=re.compile('inc[0-9]+') - self.increments = [{'group': u, - 'time': f[u].attrs['time/s'], - 'active': True + self.increments = [{'inc': int(u[3:]), + 'time': round(f[u].attrs['time/s'],12), } for u in f.keys() if r.match(u)] + + self.constituents = np.unique(f['mapping/cellResults/constituent']['Name']).tolist() # ToDo: I am not to happy with the name + self.constituents = [c.decode() for c in self.constituents] + self.materialpoints = np.unique(f['mapping/cellResults/materialpoint']['Name']).tolist() # ToDo: I am not to happy with the name + self.materialpoints = [m.decode() for m in self.materialpoints] + self.Nconstitutents = np.shape(f['mapping/cellResults/constituent'])[1] + self.Nmaterialpoints= np.shape(f['mapping/cellResults/constituent'])[0] + + self.active= {'increments' :self.increments, + 'constituents' :self.constituents, + 'materialpoints':self.materialpoints} self.filename = filename self.mode = mode + + + def get_dataset_location(self,label): + path = [] + with h5py.File(self.filename,'r') as f: + for i in self.active['increments']: + group_inc = 'inc{:05}'.format(i['inc']) + for c in self.active['constituents']: + group_constituent = group_inc+'/constituent/'+c + for t in f[group_constituent].keys(): + try: + f[group_constituent+'/'+t+'/'+label] + path.append(group_constituent+'/'+t+'/'+label) + except: + pass + return path + + + def read_dataset(self,path,c): + with h5py.File(self.filename,'r') as f: + shape = (self.Nmaterialpoints,) + np.shape(f[path])[1:] + dataset = np.full(shape,np.nan) + label = path.split('/')[2] + p = np.where(f['mapping/cellResults/constituent'][:,c]['Name'] == str.encode(label)) + for s in p: dataset[s,:] = f[path][s,:] + + return dataset + + From 91c200ff8ca855b883fed988c27fb50f7aa6c6e1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 17 Apr 2019 20:57:41 +0200 Subject: [PATCH 61/97] correct labels for output (also for DADF5) --- examples/SpectralMethod/Polycrystal/material.config | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/examples/SpectralMethod/Polycrystal/material.config b/examples/SpectralMethod/Polycrystal/material.config index 39e7f1952..71d7e07d7 100644 --- a/examples/SpectralMethod/Polycrystal/material.config +++ b/examples/SpectralMethod/Polycrystal/material.config @@ -30,11 +30,20 @@ plasticity phenopowerlaw (output) resistance_slip (output) shearrate_slip (output) resolvedstress_slip -(output) totalshear +(output) accumulatedshear_slip (output) resistance_twin (output) shearrate_twin (output) resolvedstress_twin -(output) totalvolfrac +(output) accumulatedshear_twin + +# only for HDF5 out +(output) orientation # quaternion +(output) f # deformation gradient tensor; synonyms: "defgrad" +(output) fe # elastic deformation gradient tensor +(output) fp # plastic deformation gradient tensor +(output) p # first Piola-Kichhoff stress tensor; synonyms: "firstpiola", "1stpiola" +(output) lp # plastic velocity gradient tensor + lattice_structure fcc Nslip 12 # per family From 7c771647adfb8222503d099ed41020e497977721 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 18 Apr 2019 11:55:50 +0200 Subject: [PATCH 62/97] adjustments for easier access to output data --- src/constitutive.f90 | 2 +- src/crystallite.f90 | 4 +++- src/results.f90 | 4 ++-- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 5031616d8..6428e19d1 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -1112,7 +1112,7 @@ subroutine constitutive_results group = trim('current/constituent')//'/'//trim(config_name_phase(p)) call HDF5_closeGroup(results_addGroup(group)) - group = trim(group)//'/'//'plastic' + group = trim(group)//'/plastic' call HDF5_closeGroup(results_addGroup(group)) select case(material_phase_plasticity_type(p)) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index c330c8733..1ba1f7483 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -1098,7 +1098,9 @@ subroutine crystallite_results character(len=256) :: group,lattice_label do p=1,size(config_name_phase) - group = trim('current/constituent')//'/'//trim(config_name_phase(p)) + group = trim('current/constituent')//'/'//trim(config_name_phase(p))//'/generic' + + call HDF5_closeGroup(results_addGroup(group)) do o = 1, size(output_constituent(p)%label) select case (output_constituent(p)%label(o)) diff --git a/src/results.f90 b/src/results.f90 index a969816d5..516c64552 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -510,7 +510,7 @@ subroutine results_mapping_constituent(phaseAt,memberAt,label) !--------------------------------------------------------------------------------------------------- ! renumber member from my process to all processes do i = 1, size(label) - where(phaseAt_perIP == i) memberAt_total = memberAt + sum(memberOffset(i,0:worldrank-1)) + where(phaseAt_perIP == i) memberAt_total = memberAt + sum(memberOffset(i,0:worldrank-1)) -1 ! convert to 0-based enddo !-------------------------------------------------------------------------------------------------- @@ -648,7 +648,7 @@ subroutine results_mapping_materialpoint(homogenizationAt,memberAt,label) !--------------------------------------------------------------------------------------------------- ! renumber member from my process to all processes do i = 1, size(label) - where(homogenizationAt_perIP == i) memberAt_total = memberAt + sum(memberOffset(i,0:worldrank-1)) + where(homogenizationAt_perIP == i) memberAt_total = memberAt + sum(memberOffset(i,0:worldrank-1)) - 1 ! convert to 0-based enddo !-------------------------------------------------------------------------------------------------- From 6b7fd6b7ea7eb4c510be011a011025a76c4676d8 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 18 Apr 2019 11:58:17 +0200 Subject: [PATCH 63/97] visualizing data from DADF5: first prototype --- processing/post/DADF5_vtk_cells.py | 50 +++++++++++++++++------ python/damask/dadf5.py | 65 +++++++++++++++++++++++------- 2 files changed, 87 insertions(+), 28 deletions(-) diff --git a/processing/post/DADF5_vtk_cells.py b/processing/post/DADF5_vtk_cells.py index 85b999a19..3bbf9fd45 100755 --- a/processing/post/DADF5_vtk_cells.py +++ b/processing/post/DADF5_vtk_cells.py @@ -24,22 +24,23 @@ parser.add_argument('filenames', nargs='+', options = parser.parse_args() +options.labels = ['Fe','Fp','xi_sl'] # --- loop over input files ------------------------------------------------------------------------ for filename in options.filenames: - data = damask.DADF5(filename) + results = damask.DADF5(filename) - if data.structured: # for grid solvers use rectilinear grid + if results.structured: # for grid solvers use rectilinear grid rGrid = vtk.vtkRectilinearGrid() coordArray = [vtk.vtkDoubleArray(), vtk.vtkDoubleArray(), vtk.vtkDoubleArray(), ] - rGrid.SetDimensions(*(data.grid+1)) + rGrid.SetDimensions(*(results.grid+1)) for dim in [0,1,2]: - for c in np.linspace(0,data.size[dim],1+data.grid[dim]): + for c in np.linspace(0,results.size[dim],1+results.grid[dim]): coordArray[dim].InsertNextValue(c) rGrid.SetXCoordinates(coordArray[0]) @@ -47,22 +48,45 @@ for filename in options.filenames: rGrid.SetZCoordinates(coordArray[2]) - for i,inc in enumerate(data.increments): - data.active['increments'] = [inc] - x = data.get_dataset_location('xi_sl')[0] - VTKarray = numpy_support.numpy_to_vtk(num_array=data.read_dataset(x,0),deep=True,array_type= vtk.VTK_DOUBLE) - VTKarray.SetName('xi_sl') - rGrid.GetCellData().AddArray(VTKarray) - if data.structured: + for i,inc in enumerate(results.increments): + print('Output step {}/{}'.format(i+1,len(results.increments))) + vtk_data = [] + results.active['increments'] = [inc] + for label in options.labels: + for o in results.c_output_types: + results.active['c_output_types'] = [o] + if o != 'generic': + for c in results.constituents: + results.active['constituents'] = [c] + x = results.get_dataset_location(label) + if len(x) == 0: + continue + array = results.read_dataset(x,0) + shape = [array.shape[0],np.product(array.shape[1:])] + vtk_data.append(numpy_support.numpy_to_vtk(num_array=array.reshape(shape),deep=True,array_type= vtk.VTK_DOUBLE)) + vtk_data[-1].SetName('1_'+x[0].split('/',1)[1]) + rGrid.GetCellData().AddArray(vtk_data[-1]) + else: + results.active['constituents'] = results.constituents + x = results.get_dataset_location(label) + if len(x) == 0: + continue + array = results.read_dataset(x,0) + shape = [array.shape[0],np.product(array.shape[1:])] + vtk_data.append(numpy_support.numpy_to_vtk(num_array=array.reshape(shape),deep=True,array_type= vtk.VTK_DOUBLE)) + vtk_data[-1].SetName('1_'+x[0].split('/')[1]+'/generic/'+label) + rGrid.GetCellData().AddArray(vtk_data[-1]) + + if results.structured: writer = vtk.vtkXMLRectilinearGridWriter() writer.SetCompressorTypeToZLib() writer.SetDataModeToBinary() writer.SetFileName(os.path.join(os.path.split(filename)[0], os.path.splitext(os.path.split(filename)[1])[0] + - '_inc{:04d}'.format(i) + # ToDo: adjust to lenght of increments + '_inc{:04d}'.format(i) + # ToDo: adjust to length of increments '.' + writer.GetDefaultFileExtension())) - if data.structured: + if results.structured: writer.SetInputData(rGrid) writer.Write() diff --git a/python/damask/dadf5.py b/python/damask/dadf5.py index 043997547..887c32338 100644 --- a/python/damask/dadf5.py +++ b/python/damask/dadf5.py @@ -35,29 +35,56 @@ class DADF5(): 'time': round(f[u].attrs['time/s'],12), } for u in f.keys() if r.match(u)] - self.constituents = np.unique(f['mapping/cellResults/constituent']['Name']).tolist() # ToDo: I am not to happy with the name - self.constituents = [c.decode() for c in self.constituents] - self.materialpoints = np.unique(f['mapping/cellResults/materialpoint']['Name']).tolist() # ToDo: I am not to happy with the name - self.materialpoints = [m.decode() for m in self.materialpoints] - self.Nconstitutents = np.shape(f['mapping/cellResults/constituent'])[1] - self.Nmaterialpoints= np.shape(f['mapping/cellResults/constituent'])[0] + self.constituents = np.unique(f['mapping/cellResults/constituent']['Name']).tolist() # ToDo: I am not to happy with the name + self.constituents = [c.decode() for c in self.constituents] - self.active= {'increments' :self.increments, - 'constituents' :self.constituents, - 'materialpoints':self.materialpoints} + self.materialpoints = np.unique(f['mapping/cellResults/materialpoint']['Name']).tolist() # ToDo: I am not to happy with the name + self.materialpoints = [m.decode() for m in self.materialpoints] + + self.Nconstituents = [i for i in range(np.shape(f['mapping/cellResults/constituent'])[1])] + self.Nmaterialpoints = np.shape(f['mapping/cellResults/constituent'])[0] + + self.c_output_types = [] + for c in self.constituents: + for o in f['inc{:05}/constituent/{}'.format(self.increments[0]['inc'],c)].keys(): + self.c_output_types.append(o) + self.c_output_types = list(set(self.c_output_types)) # make unique + + self.active= {'increments': self.increments, + 'constituents': self.constituents, + 'materialpoints': self.materialpoints, + 'constituent': self.Nconstituents, + 'c_output_types': self.c_output_types} self.filename = filename self.mode = mode - + + def list_data(self): + """Shows information on all datasets in the file""" + with h5py.File(self.filename,'r') as f: + group_inc = 'inc{:05}'.format(self.active['increments'][0]['inc']) + for c in self.active['constituents']: + print('\n'+c) + group_constituent = group_inc+'/constituent/'+c + for t in self.active['c_output_types']: + print(' {}'.format(t)) + group_output_types = group_constituent+'/'+t + try: + for x in f[group_output_types].keys(): + print(' {} ({})'.format(x,f[group_output_types+'/'+x].attrs['Description'].decode())) + except: + pass + def get_dataset_location(self,label): + """Returns the location of all active datasets with given label""" path = [] with h5py.File(self.filename,'r') as f: for i in self.active['increments']: group_inc = 'inc{:05}'.format(i['inc']) for c in self.active['constituents']: group_constituent = group_inc+'/constituent/'+c - for t in f[group_constituent].keys(): + for t in self.active['c_output_types']: try: f[group_constituent+'/'+t+'/'+label] path.append(group_constituent+'/'+t+'/'+label) @@ -67,12 +94,20 @@ class DADF5(): def read_dataset(self,path,c): + """ + Dataset for all points/cells + + + If more than one path is given, the dataset is composed of the individual contributions + """ with h5py.File(self.filename,'r') as f: - shape = (self.Nmaterialpoints,) + np.shape(f[path])[1:] + shape = (self.Nmaterialpoints,) + np.shape(f[path[0]])[1:] dataset = np.full(shape,np.nan) - label = path.split('/')[2] - p = np.where(f['mapping/cellResults/constituent'][:,c]['Name'] == str.encode(label)) - for s in p: dataset[s,:] = f[path][s,:] + for pa in path: + label = pa.split('/')[2] + p = np.where(f['mapping/cellResults/constituent'][:,c]['Name'] == str.encode(label))[0] + u = (f['mapping/cellResults/constituent'][p,c]['Position']) + dataset[p,:] = f[pa][u,:] return dataset From ccf13c2c500501e8395aacbde57855abaea7ea7b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 18 Apr 2019 11:59:27 +0200 Subject: [PATCH 64/97] autodoc does not work for argparse --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1e1b8fe49..0cd8759d9 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -505,7 +505,7 @@ Processing: - rm abq_addUserOutput.py marc_addUserOutput.py - $DAMASKROOT/PRIVATE/documenting/scriptHelpToWiki.py --debug *.py - cd $DAMASKROOT/processing/post - - rm marc_to_vtk.py vtk2ang.py + - rm marc_to_vtk.py vtk2ang.py DAD*.py - $DAMASKROOT/PRIVATE/documenting/scriptHelpToWiki.py --debug *.py except: - master From b746b841f77c4fdd929ee00846db4d5f95ac4a8d Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 18 Apr 2019 12:04:09 +0200 Subject: [PATCH 65/97] not needed --- python/damask/dadf5.py | 2 -- 1 file changed, 2 deletions(-) diff --git a/python/damask/dadf5.py b/python/damask/dadf5.py index 887c32338..4214f4922 100644 --- a/python/damask/dadf5.py +++ b/python/damask/dadf5.py @@ -2,7 +2,6 @@ import h5py import re import numpy as np -import os # ------------------------------------------------------------------ class DADF5(): @@ -97,7 +96,6 @@ class DADF5(): """ Dataset for all points/cells - If more than one path is given, the dataset is composed of the individual contributions """ with h5py.File(self.filename,'r') as f: From f89d318b0309e2536e17996bd400efb9b6f370dc Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 18 Apr 2019 18:28:22 +0200 Subject: [PATCH 66/97] [skip ci] old output not needed for testing HDF5 --- installation/patch/README.md | 5 +- installation/patch/disable_old_output | 178 ++++++++++++++++++++++++++ 2 files changed, 182 insertions(+), 1 deletion(-) create mode 100644 installation/patch/disable_old_output diff --git a/installation/patch/README.md b/installation/patch/README.md index dd8232758..0b8251510 100644 --- a/installation/patch/README.md +++ b/installation/patch/README.md @@ -12,7 +12,10 @@ patch -p1 < installation/patch/nameOfPatch ## Available patches * **disable_HDF5** disables all HDF5 output. - HDF5 output is an experimental feature. Also, some routines not present in HDF5 1.8.x are remove to allow compilation of DAMASK with HDF5 < 1.10.x + HDF5 output is an experimental feature. Also, some routines not present in HDF5 1.8.x are removed to allow compilation of DAMASK with HDF5 < 1.10.x + + * **disable_old_output** disables all non-HDF5 output. + Saves some memory when using only HDF5 output ## Create patch commit your changes diff --git a/installation/patch/disable_old_output b/installation/patch/disable_old_output new file mode 100644 index 000000000..732dfc83e --- /dev/null +++ b/installation/patch/disable_old_output @@ -0,0 +1,178 @@ +From 6dbd904a4cfc28add3c39bb2a4ec9e2dbb2442b6 Mon Sep 17 00:00:00 2001 +From: Martin Diehl +Date: Thu, 18 Apr 2019 18:25:32 +0200 +Subject: [PATCH] to create patch + +--- + src/DAMASK_grid.f90 | 81 +----------------------------------------- + src/homogenization.f90 | 2 ++ + 2 files changed, 3 insertions(+), 80 deletions(-) + +diff --git a/src/DAMASK_grid.f90 b/src/DAMASK_grid.f90 +index f2f52bb2..a7543f4d 100644 +--- a/src/DAMASK_grid.f90 ++++ b/src/DAMASK_grid.f90 +@@ -18,7 +18,6 @@ program DAMASK_spectral + use DAMASK_interface, only: & + DAMASK_interface_init, & + loadCaseFile, & +- geometryFile, & + getSolverJobName, & + interface_restartInc + use IO, only: & +@@ -49,14 +48,9 @@ program DAMASK_spectral + restartInc + use numerics, only: & + worldrank, & +- worldsize, & + stagItMax, & + maxCutBack, & + continueCalculation +- use homogenization, only: & +- materialpoint_sizeResults, & +- materialpoint_results, & +- materialpoint_postResults + use material, only: & + thermal_type, & + damage_type, & +@@ -131,12 +125,6 @@ program DAMASK_spectral + type(tLoadCase), allocatable, dimension(:) :: loadCases !< array of all load cases + type(tLoadCase) :: newLoadCase + type(tSolutionState), allocatable, dimension(:) :: solres +- integer(MPI_OFFSET_KIND) :: fileOffset +- integer(MPI_OFFSET_KIND), dimension(:), allocatable :: outputSize +- integer(pInt), parameter :: maxByteOut = 2147483647-4096 !< limit of one file output write https://trac.mpich.org/projects/mpich/ticket/1742 +- integer(pInt), parameter :: maxRealOut = maxByteOut/pReal +- integer(pLongInt), dimension(2) :: outputIndex +- PetscErrorCode :: ierr + procedure(grid_mech_spectral_basic_init), pointer :: & + mech_init + procedure(grid_mech_spectral_basic_forward), pointer :: & +@@ -384,22 +372,6 @@ program DAMASK_spectral + ! write header of output file + if (worldrank == 0) then + writeHeader: if (interface_restartInc < 1_pInt) then +- open(newunit=fileUnit,file=trim(getSolverJobName())//& +- '.spectralOut',form='UNFORMATTED',status='REPLACE') +- write(fileUnit) 'load:', trim(loadCaseFile) ! ... and write header +- write(fileUnit) 'workingdir:', 'n/a' +- write(fileUnit) 'geometry:', trim(geometryFile) +- write(fileUnit) 'grid:', grid +- write(fileUnit) 'size:', geomSize +- write(fileUnit) 'materialpoint_sizeResults:', materialpoint_sizeResults +- write(fileUnit) 'loadcases:', size(loadCases) +- write(fileUnit) 'frequencies:', loadCases%outputfrequency ! one entry per LoadCase +- write(fileUnit) 'times:', loadCases%time ! one entry per LoadCase +- write(fileUnit) 'logscales:', loadCases%logscale +- write(fileUnit) 'increments:', loadCases%incs ! one entry per LoadCase +- write(fileUnit) 'startingIncrement:', restartInc ! start with writing out the previous inc +- write(fileUnit) 'eoh' +- close(fileUnit) ! end of header + open(newunit=statUnit,file=trim(getSolverJobName())//& + '.sta',form='FORMATTED',status='REPLACE') + write(statUnit,'(a)') 'Increment Time CutbackLevel Converged IterationsNeeded' ! statistics file +@@ -412,39 +384,6 @@ program DAMASK_spectral + endif writeHeader + endif + +-!-------------------------------------------------------------------------------------------------- +-! prepare MPI parallel out (including opening of file) +- allocate(outputSize(worldsize), source = 0_MPI_OFFSET_KIND) +- outputSize(worldrank+1) = size(materialpoint_results,kind=MPI_OFFSET_KIND)*int(pReal,MPI_OFFSET_KIND) +- call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_LONG,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process +- if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_allreduce') +- call MPI_file_open(PETSC_COMM_WORLD, trim(getSolverJobName())//'.spectralOut', & +- MPI_MODE_WRONLY + MPI_MODE_APPEND, & +- MPI_INFO_NULL, & +- fileUnit, & +- ierr) +- if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_file_open') +- call MPI_file_get_position(fileUnit,fileOffset,ierr) ! get offset from header +- if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_file_get_position') +- fileOffset = fileOffset + sum(outputSize(1:worldrank)) ! offset of my process in file (header + processes before me) +- call MPI_file_seek (fileUnit,fileOffset,MPI_SEEK_SET,ierr) +- if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_file_seek') +- +- writeUndeformed: if (interface_restartInc < 1_pInt) then +- write(6,'(1/,a)') ' ... writing initial configuration to file ........................' +- call CPFEM_results(0_pInt,0.0_pReal) +- do i = 1, size(materialpoint_results,3)/(maxByteOut/(materialpoint_sizeResults*pReal))+1 ! slice the output of my process in chunks not exceeding the limit for one output +- outputIndex = int([(i-1_pInt)*((maxRealOut)/materialpoint_sizeResults)+1_pInt, & ! QUESTION: why not starting i at 0 instead of murky 1? +- min(i*((maxRealOut)/materialpoint_sizeResults),size(materialpoint_results,3))],pLongInt) +- call MPI_file_write(fileUnit,reshape(materialpoint_results(:,:,outputIndex(1):outputIndex(2)), & +- [(outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)]), & +- int((outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)), & +- MPI_DOUBLE, MPI_STATUS_IGNORE, ierr) +- if (ierr /= 0_pInt) call IO_error(error_ID=894_pInt, ext_msg='MPI_file_write') +- enddo +- fileOffset = fileOffset + sum(outputSize) ! forward to current file position +- endif writeUndeformed +- + + loadCaseLooping: do currentLoadCase = 1_pInt, size(loadCases) + time0 = time ! load case start time +@@ -574,7 +513,6 @@ program DAMASK_spectral + write(6,'(/,a)') ' cutting back ' + else ! no more options to continue + call IO_warning(850_pInt) +- call MPI_file_close(fileUnit,ierr) + close(statUnit) + call quit(-1_pInt*(lastRestartWritten+1_pInt)) ! quit and provide information about last restart inc written + endif +@@ -593,24 +531,8 @@ program DAMASK_spectral + ' increment ', totalIncsCounter, ' NOT converged' + endif; flush(6) + +- if (mod(inc,loadCases(currentLoadCase)%outputFrequency) == 0_pInt) then ! at output frequency +- write(6,'(1/,a)') ' ... writing results to file ......................................' +- flush(6) +- call materialpoint_postResults() +- call MPI_file_seek (fileUnit,fileOffset,MPI_SEEK_SET,ierr) +- if (ierr /= 0_pInt) call IO_error(894_pInt, ext_msg='MPI_file_seek') +- do i=1, size(materialpoint_results,3)/(maxByteOut/(materialpoint_sizeResults*pReal))+1 ! slice the output of my process in chunks not exceeding the limit for one output +- outputIndex=int([(i-1_pInt)*((maxRealOut)/materialpoint_sizeResults)+1_pInt, & +- min(i*((maxRealOut)/materialpoint_sizeResults),size(materialpoint_results,3))],pLongInt) +- call MPI_file_write(fileUnit,reshape(materialpoint_results(:,:,outputIndex(1):outputIndex(2)),& +- [(outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)]), & +- int((outputIndex(2)-outputIndex(1)+1)*int(materialpoint_sizeResults,pLongInt)),& +- MPI_DOUBLE, MPI_STATUS_IGNORE, ierr) +- if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='MPI_file_write') +- enddo +- fileOffset = fileOffset + sum(outputSize) ! forward to current file position ++ if (mod(inc,loadCases(currentLoadCase)%outputFrequency) == 0_pInt) & ! at output frequency + call CPFEM_results(totalIncsCounter,time) +- endif + if ( loadCases(currentLoadCase)%restartFrequency > 0_pInt & ! writing of restart info requested ... + .and. mod(inc,loadCases(currentLoadCase)%restartFrequency) == 0_pInt) then ! ... and at frequency of writing restart information + restartWrite = .true. ! set restart parameter for FEsolving +@@ -633,7 +555,6 @@ program DAMASK_spectral + real(convergedCounter, pReal)/& + real(notConvergedCounter + convergedCounter,pReal)*100.0_pReal, ' %) increments converged!' + flush(6) +- call MPI_file_close(fileUnit,ierr) + close(statUnit) + + if (notConvergedCounter > 0_pInt) call quit(2_pInt) ! error if some are not converged +diff --git a/src/homogenization.f90 b/src/homogenization.f90 +index 06da6ab2..0743d545 100644 +--- a/src/homogenization.f90 ++++ b/src/homogenization.f90 +@@ -269,6 +269,7 @@ subroutine homogenization_init + + homogenization_maxNgrains * (1 + crystallite_maxSizePostResults & ! crystallite size & crystallite results + + 1 + constitutive_plasticity_maxSizePostResults & ! constitutive size & constitutive results + + constitutive_source_maxSizePostResults) ++ materialpoint_sizeResults = 0 + allocate(materialpoint_results(materialpoint_sizeResults,theMesh%elem%nIPs,theMesh%nElems)) + + write(6,'(/,a)') ' <<<+- homogenization init -+>>>' +@@ -682,6 +683,7 @@ subroutine materialpoint_postResults + i, & !< integration point number + e !< element number + ++ return + !$OMP PARALLEL DO PRIVATE(myNgrains,myCrystallite,thePos,theSize) + elementLooping: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNgrains = homogenization_Ngrains(mesh_element(3,e)) +-- +2.21.0 + From 835831b6108b62267944dbbe0327f64104c14239 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 21 Apr 2019 09:53:51 +0200 Subject: [PATCH 67/97] to specific for MPIE --- python/damask/environment.py | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/python/damask/environment.py b/python/damask/environment.py index 17786ab28..0b77c94d2 100644 --- a/python/damask/environment.py +++ b/python/damask/environment.py @@ -26,24 +26,3 @@ class Environment(): if len(items) == 2: self.options[items[0].upper()] = \ re.sub('\$\{*DAMASK_ROOT\}*',self.rootDir(),os.path.expandvars(items[1])) # expand all shell variables and DAMASK_ROOT - - def isAvailable(self,software,Nneeded =-1): - licensesNeeded = {'abaqus' :5, - 'standard':5 - } - if Nneeded == -1: Nneeded = licensesNeeded[software] - try: - cmd = """ ssh mulicense2 "/lm-status | grep 'Users of %s: ' | cut -d' ' -f7,13" """%software - process = subprocess.Popen(shlex.split(cmd),stdout = subprocess.PIPE,stderr = subprocess.PIPE) - licenses = list(map(int, process.stdout.readline().split())) - try: - if licenses[0]-licenses[1] >= Nneeded: - return 0 - else: - print('%s missing licenses for %s'%(licenses[1] + Nneeded - licenses[0],software)) - return licenses[1] + Nneeded - licenses[0] - except IndexError: - print('Could not retrieve license information for %s'%software) - return 127 - except: - return 126 From 53f6a4e030aa4ea9ba880895708a1f59d3254e91 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 25 Apr 2019 06:00:56 +0200 Subject: [PATCH 68/97] too specific - only works at MPIE --- python/damask/environment.py | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/python/damask/environment.py b/python/damask/environment.py index 17786ab28..0b77c94d2 100644 --- a/python/damask/environment.py +++ b/python/damask/environment.py @@ -26,24 +26,3 @@ class Environment(): if len(items) == 2: self.options[items[0].upper()] = \ re.sub('\$\{*DAMASK_ROOT\}*',self.rootDir(),os.path.expandvars(items[1])) # expand all shell variables and DAMASK_ROOT - - def isAvailable(self,software,Nneeded =-1): - licensesNeeded = {'abaqus' :5, - 'standard':5 - } - if Nneeded == -1: Nneeded = licensesNeeded[software] - try: - cmd = """ ssh mulicense2 "/lm-status | grep 'Users of %s: ' | cut -d' ' -f7,13" """%software - process = subprocess.Popen(shlex.split(cmd),stdout = subprocess.PIPE,stderr = subprocess.PIPE) - licenses = list(map(int, process.stdout.readline().split())) - try: - if licenses[0]-licenses[1] >= Nneeded: - return 0 - else: - print('%s missing licenses for %s'%(licenses[1] + Nneeded - licenses[0],software)) - return licenses[1] + Nneeded - licenses[0] - except IndexError: - print('Could not retrieve license information for %s'%software) - return 127 - except: - return 126 From 7104bc9934730d8eac42bafedc1fc5f1ca519d4a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 25 Apr 2019 07:08:32 +0200 Subject: [PATCH 69/97] allow standard CMAKE way of setting install directory - DAMASK_BIN in config has no effect anymore --- CMakeLists.txt | 24 ++++-------------------- Makefile | 5 +++-- PRIVATE | 2 +- src/CMakeLists.txt | 4 ++-- 4 files changed, 10 insertions(+), 25 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 0cfe47248..a76b7ae3d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -106,11 +106,11 @@ set (CMAKE_C_COMPILER "${PETSC_MPICC}") # DAMASK solver defines project to build if (DAMASK_SOLVER STREQUAL "GRID") - project (DAMASK_grid Fortran C) + project (damask-grid Fortran C) add_definitions (-DGrid) message ("Building Grid Solver\n") elseif (DAMASK_SOLVER STREQUAL "FEM") - project (DAMASK_FEM Fortran C) + project (damask-mesh Fortran C) add_definitions (-DFEM) message ("Building FEM Solver\n") else () @@ -156,22 +156,6 @@ if (CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") set (BUILDCMD_POST "${BUILDCMD_POST} -fsyntax-only") endif () -# Parse DAMASK_BIN from CONFIG file -file (READ "CONFIG" CONFIGFILE) -string (REGEX REPLACE ";" "\\\\;" CONFIGFILE "${CONFIGFILE}") -string (REGEX REPLACE "\n" ";" CONFIGFILE "${CONFIGFILE}") -foreach (item ${CONFIGFILE}) - string (REGEX MATCH ".+DAMASK_BIN.+" item ${item}) - if (item) - string (REGEX REPLACE "set" "" item "${item}") - string (REGEX REPLACE "=" " " item "${item}") - string (REGEX REPLACE "\\\${DAMASK_ROOT}" "${PROJECT_SOURCE_DIR}" item "${item}") - string (REPLACE "DAMASK_BIN" ";" STRING_LIST ${item}) - list (GET STRING_LIST 1 item) - string (STRIP "${item}" CMAKE_INSTALL_PREFIX) - endif () -endforeach(item ${CONFIGFILE}) - # Parse DAMASK version from VERSION file find_program (CAT_EXECUTABLE NAMES cat) execute_process (COMMAND ${CAT_EXECUTABLE} ${PROJECT_SOURCE_DIR}/VERSION @@ -490,10 +474,10 @@ if (CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") exec_program (mktemp ARGS -d OUTPUT_VARIABLE black_hole) install (PROGRAMS ${nothing} DESTINATION ${black_hole}) else () - if (PROJECT_NAME STREQUAL "DAMASK_grid") + if (PROJECT_NAME STREQUAL "damask-grid") install (PROGRAMS ${PROJECT_BINARY_DIR}/src/DAMASK_spectral DESTINATION ${CMAKE_INSTALL_PREFIX}) - elseif (PROJECT_NAME STREQUAL "DAMASK_FEM") + elseif (PROJECT_NAME STREQUAL "damask-mesh") install (PROGRAMS ${PROJECT_BINARY_DIR}/src/DAMASK_FEM DESTINATION ${CMAKE_INSTALL_PREFIX}) endif () diff --git a/Makefile b/Makefile index 53ae30c1c..31553d88f 100644 --- a/Makefile +++ b/Makefile @@ -2,6 +2,7 @@ SHELL = /bin/sh ######################################################################################## # Makefile for the installation of DAMASK ######################################################################################## +DAMASK_ROOT = $(shell python -c "import os,sys; print(os.path.normpath(os.path.realpath(os.path.expanduser('$(pwd)'))))") .PHONY: all all: grid FEM processing @@ -20,12 +21,12 @@ FEM: build/FEM .PHONY: build/grid build/grid: @mkdir -p build/grid - @(cd build/grid; cmake -Wno-dev -DDAMASK_SOLVER=GRID -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) + @(cd build/grid; cmake -Wno-dev -DDAMASK_SOLVER=GRID -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT}/bin -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) .PHONY: build/FEM build/FEM: @mkdir -p build/FEM - @(cd build/FEM; cmake -Wno-dev -DDAMASK_SOLVER=FEM -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) + @(cd build/FEM; cmake -Wno-dev -DDAMASK_SOLVER=FEM -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT}/bin -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) .PHONY: clean clean: diff --git a/PRIVATE b/PRIVATE index f342bc7da..f6171a748 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit f342bc7dabddf5a9c7786d14115145ef4b0f330b +Subproject commit f6171a748e51b994db27c2cc74cc0168b7aea93f diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 274069226..8cdb51551 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -14,7 +14,7 @@ list(FILTER sources EXCLUDE REGEX ".*mesh_abaqus.*\\.f90") list(FILTER sources EXCLUDE REGEX ".*commercialFEM_fileList.*\\.f90") -if (PROJECT_NAME STREQUAL "DAMASK_grid") +if (PROJECT_NAME STREQUAL "damask-grid") # probably we should have subfolders for FEM and spectral list(FILTER sources EXCLUDE REGEX ".*DAMASK_FEM.*\\.f90") @@ -29,7 +29,7 @@ if (PROJECT_NAME STREQUAL "DAMASK_grid") add_library(DAMASK_spectral OBJECT ${sources}) endif() -elseif (PROJECT_NAME STREQUAL "DAMASK_FEM") +elseif (PROJECT_NAME STREQUAL "damask-mesh") # probably we should have subfolders for FEM and spectral list(FILTER sources EXCLUDE REGEX ".*DAMASK_grid.*\\.f90") From 64c9a367c0304212a917a489793310b3ed01d62a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 25 Apr 2019 07:16:24 +0200 Subject: [PATCH 70/97] always install post processing scripts into {$DAMASK_ROOT}/bin custom installation directions will be made available by more standard approaches --- CONFIG | 2 -- installation/symlink_Processing.py | 2 +- python/damask/environment.py | 2 +- 3 files changed, 2 insertions(+), 4 deletions(-) diff --git a/CONFIG b/CONFIG index 31a9c34c8..6d5226c89 100644 --- a/CONFIG +++ b/CONFIG @@ -1,8 +1,6 @@ # "set"-syntax needed only for tcsh (but works with bash and zsh) # DAMASK_ROOT will be expanded -set DAMASK_BIN = ${DAMASK_ROOT}/bin - set DAMASK_NUM_THREADS = 4 set MSC_ROOT = /opt/msc diff --git a/installation/symlink_Processing.py b/installation/symlink_Processing.py index 60f8d3639..90497c0eb 100755 --- a/installation/symlink_Processing.py +++ b/installation/symlink_Processing.py @@ -7,7 +7,7 @@ import damask damaskEnv = damask.Environment() baseDir = damaskEnv.relPath('processing/') -binDir = damaskEnv.options['DAMASK_BIN'] +binDir = damaskEnv.relPath('bin/') if not os.path.isdir(binDir): os.mkdir(binDir) diff --git a/python/damask/environment.py b/python/damask/environment.py index 0b77c94d2..21eb24694 100644 --- a/python/damask/environment.py +++ b/python/damask/environment.py @@ -1,6 +1,6 @@ # -*- coding: UTF-8 no BOM -*- -import os,subprocess,shlex,re +import os,re class Environment(): __slots__ = [ \ From eab2ce376186d2f846b33b275e4e0f12624012b8 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 25 Apr 2019 08:00:09 +0200 Subject: [PATCH 71/97] point always to $DAMASK_ROOT/bin --- env/DAMASK.csh | 4 +--- env/DAMASK.sh | 3 +-- env/DAMASK.zsh | 2 +- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/env/DAMASK.csh b/env/DAMASK.csh index 1819dd305..d223d885a 100644 --- a/env/DAMASK.csh +++ b/env/DAMASK.csh @@ -13,9 +13,7 @@ set BRANCH = `git branch 2>/dev/null| grep -E '^\* ')` cd - >/dev/null # if DAMASK_BIN is present -if ( $?DAMASK_BIN) then - set path = ($DAMASK_BIN $path) -endif +set path = ($DAMASK_ROOT/bin $path) set SOLVER=`which DAMASK_spectral` set PROCESSING=`which postResults` diff --git a/env/DAMASK.sh b/env/DAMASK.sh index fa2c8db25..1b4bea86a 100644 --- a/env/DAMASK.sh +++ b/env/DAMASK.sh @@ -33,8 +33,7 @@ unset -f set # add BRANCH if DAMASK_ROOT is a git repository cd $DAMASK_ROOT >/dev/null; BRANCH=$(git branch 2>/dev/null| grep -E '^\* '); cd - >/dev/null -# add DAMASK_BIN if present -[ "x$DAMASK_BIN" != "x" ] && PATH=$DAMASK_BIN:$PATH +PATH=${DAMASK_ROOT}/bin:$PATH SOLVER=$(type -p DAMASK_spectral || true 2>/dev/null) [ "x$SOLVER" == "x" ] && SOLVER=$(blink 'Not found!') diff --git a/env/DAMASK.zsh b/env/DAMASK.zsh index 61b9c89f9..5449007f9 100644 --- a/env/DAMASK.zsh +++ b/env/DAMASK.zsh @@ -25,7 +25,7 @@ unset -f set cd $DAMASK_ROOT >/dev/null; BRANCH=$(git branch 2>/dev/null| grep -E '^\* '); cd - >/dev/null # add DAMASK_BIN if present -[[ "x$DAMASK_BIN" != "x" ]] && PATH=$DAMASK_BIN:$PATH +PATH=${DAMASK_ROOT}/bin:$PATH SOLVER=$(which DAMASK_spectral || true 2>/dev/null) [[ "x$SOLVER" == "x" ]] && SOLVER=$(blink 'Not found!') From 009a47ad7255f54dd8d7fd0bf719b83930ad53d2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 25 Apr 2019 20:02:48 +0200 Subject: [PATCH 72/97] make python package independent from rest of DAMASK https://packaging.python.org/guides/single-sourcing-package-version/ --- python/damask/VERSION | 1 + python/damask/__init__.py | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) create mode 120000 python/damask/VERSION diff --git a/python/damask/VERSION b/python/damask/VERSION new file mode 120000 index 000000000..558194c5a --- /dev/null +++ b/python/damask/VERSION @@ -0,0 +1 @@ +../../VERSION \ No newline at end of file diff --git a/python/damask/__init__.py b/python/damask/__init__.py index d7ed4a9f9..a57d450d8 100644 --- a/python/damask/__init__.py +++ b/python/damask/__init__.py @@ -3,8 +3,8 @@ """Main aggregator""" import os -with open(os.path.join(os.path.dirname(__file__),'../../VERSION')) as f: - version = f.readline()[:-1] +with open(os.path.join(os.path.dirname(__file__),'VERSION')) as f: + version = f.readline()[1:-1] name = 'damask' From 5020d8204e3c503435d58b4eee9068586bc4b87a Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 26 Apr 2019 10:00:29 +0200 Subject: [PATCH 73/97] prefix is without bin --- CMakeLists.txt | 4 ++-- Makefile | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index a76b7ae3d..9f808b167 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -476,9 +476,9 @@ if (CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") else () if (PROJECT_NAME STREQUAL "damask-grid") install (PROGRAMS ${PROJECT_BINARY_DIR}/src/DAMASK_spectral - DESTINATION ${CMAKE_INSTALL_PREFIX}) + DESTINATION ${CMAKE_INSTALL_PREFIX}/bin) elseif (PROJECT_NAME STREQUAL "damask-mesh") install (PROGRAMS ${PROJECT_BINARY_DIR}/src/DAMASK_FEM - DESTINATION ${CMAKE_INSTALL_PREFIX}) + DESTINATION ${CMAKE_INSTALL_PREFIX}/bin) endif () endif () diff --git a/Makefile b/Makefile index 31553d88f..161d4c3ce 100644 --- a/Makefile +++ b/Makefile @@ -21,12 +21,12 @@ FEM: build/FEM .PHONY: build/grid build/grid: @mkdir -p build/grid - @(cd build/grid; cmake -Wno-dev -DDAMASK_SOLVER=GRID -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT}/bin -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) + @(cd build/grid; cmake -Wno-dev -DDAMASK_SOLVER=GRID -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT} -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) .PHONY: build/FEM build/FEM: @mkdir -p build/FEM - @(cd build/FEM; cmake -Wno-dev -DDAMASK_SOLVER=FEM -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT}/bin -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) + @(cd build/FEM; cmake -Wno-dev -DDAMASK_SOLVER=FEM -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT} -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) .PHONY: clean clean: From ed2d64d87624a9ec85e1411cb9772cdcaffc2279 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 26 Apr 2019 16:36:36 +0200 Subject: [PATCH 74/97] more standard way of installing executable --- CMakeLists.txt | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 9f808b167..4601d0dfd 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -474,11 +474,10 @@ if (CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") exec_program (mktemp ARGS -d OUTPUT_VARIABLE black_hole) install (PROGRAMS ${nothing} DESTINATION ${black_hole}) else () + set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) if (PROJECT_NAME STREQUAL "damask-grid") - install (PROGRAMS ${PROJECT_BINARY_DIR}/src/DAMASK_spectral - DESTINATION ${CMAKE_INSTALL_PREFIX}/bin) + install (TARGETS DAMASK_spectral RUNTIME) elseif (PROJECT_NAME STREQUAL "damask-mesh") - install (PROGRAMS ${PROJECT_BINARY_DIR}/src/DAMASK_FEM - DESTINATION ${CMAKE_INSTALL_PREFIX}/bin) + install (TARGETS DAMASK_FEM RUNTIME) endif () endif () From b63a6c703436a3fa810bf90dc96e69f52cc7b2a9 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 26 Apr 2019 17:39:21 +0200 Subject: [PATCH 75/97] cleaner code that also works with older cmake --- CMakeLists.txt | 15 +-------------- src/CMakeLists.txt | 5 +++++ 2 files changed, 6 insertions(+), 14 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 4601d0dfd..a9c5fa83e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -467,17 +467,4 @@ message ("Fortran Linker Command:\n${CMAKE_Fortran_LINK_EXECUTABLE}\n") # location of code add_subdirectory (src) - -# INSTALL BUILT BINARIES -if (CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") - exec_program (mktemp OUTPUT_VARIABLE nothing) - exec_program (mktemp ARGS -d OUTPUT_VARIABLE black_hole) - install (PROGRAMS ${nothing} DESTINATION ${black_hole}) -else () - set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) - if (PROJECT_NAME STREQUAL "damask-grid") - install (TARGETS DAMASK_spectral RUNTIME) - elseif (PROJECT_NAME STREQUAL "damask-mesh") - install (TARGETS DAMASK_FEM RUNTIME) - endif () -endif () +set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 8cdb51551..6ff120873 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -25,8 +25,12 @@ if (PROJECT_NAME STREQUAL "damask-grid") if(NOT CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") add_executable(DAMASK_spectral ${sources}) + install (TARGETS DAMASK_spectral RUNTIME) else() add_library(DAMASK_spectral OBJECT ${sources}) + exec_program (mktemp OUTPUT_VARIABLE nothing) + exec_program (mktemp ARGS -d OUTPUT_VARIABLE black_hole) + install (PROGRAMS ${nothing} DESTINATION ${black_hole}) endif() elseif (PROJECT_NAME STREQUAL "damask-mesh") @@ -42,5 +46,6 @@ elseif (PROJECT_NAME STREQUAL "damask-mesh") list(FILTER sources EXCLUDE REGEX ".*mesh_grid.*\\.f90") add_executable(DAMASK_FEM ${sources}) + install (TARGETS DAMASK_FEM RUNTIME) endif() From b4a21e8d40651e7186e117066e697f5dc66c2861 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 26 Apr 2019 18:07:43 +0200 Subject: [PATCH 76/97] fix for older cmake looks ok --- CMakeLists.txt | 1 - src/CMakeLists.txt | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index a9c5fa83e..78d63117e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -467,4 +467,3 @@ message ("Fortran Linker Command:\n${CMAKE_Fortran_LINK_EXECUTABLE}\n") # location of code add_subdirectory (src) -set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 6ff120873..736db112a 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -25,7 +25,7 @@ if (PROJECT_NAME STREQUAL "damask-grid") if(NOT CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") add_executable(DAMASK_spectral ${sources}) - install (TARGETS DAMASK_spectral RUNTIME) + install (TARGETS DAMASK_spectral RUNTIME DESTINATION bin) else() add_library(DAMASK_spectral OBJECT ${sources}) exec_program (mktemp OUTPUT_VARIABLE nothing) @@ -46,6 +46,6 @@ elseif (PROJECT_NAME STREQUAL "damask-mesh") list(FILTER sources EXCLUDE REGEX ".*mesh_grid.*\\.f90") add_executable(DAMASK_FEM ${sources}) - install (TARGETS DAMASK_FEM RUNTIME) + install (TARGETS DAMASK_FEM RUNTIME DESTINATION bin) endif() From 1b9355327a49186103d92114bd202a6944ddf73b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 26 Apr 2019 19:08:10 +0200 Subject: [PATCH 77/97] WIP: preparing for PIP package --- python/damask/LICENSE | 1 + python/damask/setup.py | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+) create mode 120000 python/damask/LICENSE create mode 100644 python/damask/setup.py diff --git a/python/damask/LICENSE b/python/damask/LICENSE new file mode 120000 index 000000000..30cff7403 --- /dev/null +++ b/python/damask/LICENSE @@ -0,0 +1 @@ +../../LICENSE \ No newline at end of file diff --git a/python/damask/setup.py b/python/damask/setup.py new file mode 100644 index 000000000..f44738d38 --- /dev/null +++ b/python/damask/setup.py @@ -0,0 +1,18 @@ +import setuptools + +setuptools.setup( + name="xxx", + version="0.0.1", + author="The DAMASK team", + author_email="damask@mpie.de", + description="A small example package", + long_description='test', + long_description_content_type="text/markdown", + url="https://github.com/pypa/sampleproject", + packages=setuptools.find_packages(), + classifiers=[ + "Programming Language :: Python :: 3", + "License :: OSI Approved :: GLPv3", + "Operating System :: OS Independent", + ], +) From 1ccc9675448f5097a8ea5a5fa9291d22c6d8886c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 26 Apr 2019 19:24:22 +0200 Subject: [PATCH 78/97] enables auto include --- python/.gitignore | 1 + python/{damask => }/setup.py | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) create mode 100644 python/.gitignore rename python/{damask => }/setup.py (87%) diff --git a/python/.gitignore b/python/.gitignore new file mode 100644 index 000000000..1521c8b76 --- /dev/null +++ b/python/.gitignore @@ -0,0 +1 @@ +dist diff --git a/python/damask/setup.py b/python/setup.py similarity index 87% rename from python/damask/setup.py rename to python/setup.py index f44738d38..823365d34 100644 --- a/python/damask/setup.py +++ b/python/setup.py @@ -1,11 +1,11 @@ import setuptools setuptools.setup( - name="xxx", + name="damask", version="0.0.1", author="The DAMASK team", author_email="damask@mpie.de", - description="A small example package", + description="Python library for DAMASK", long_description='test', long_description_content_type="text/markdown", url="https://github.com/pypa/sampleproject", From a5c620379b7e5c271ffa0158e5285f59bb5be708 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Fri, 26 Apr 2019 20:54:58 +0200 Subject: [PATCH 79/97] tools to build a python wheel distribution --- python/MANIFEST.in | 1 + python/damask/README | 1 + python/setup.py | 11 ++++++++--- 3 files changed, 10 insertions(+), 3 deletions(-) create mode 100644 python/MANIFEST.in create mode 120000 python/damask/README diff --git a/python/MANIFEST.in b/python/MANIFEST.in new file mode 100644 index 000000000..bb6d21f36 --- /dev/null +++ b/python/MANIFEST.in @@ -0,0 +1 @@ +include damask/VERSION diff --git a/python/damask/README b/python/damask/README new file mode 120000 index 000000000..3830a4118 --- /dev/null +++ b/python/damask/README @@ -0,0 +1 @@ +../../README \ No newline at end of file diff --git a/python/setup.py b/python/setup.py index 823365d34..e49872354 100644 --- a/python/setup.py +++ b/python/setup.py @@ -1,15 +1,20 @@ import setuptools +import os + +with open(os.path.join(os.path.dirname(__file__),'damask/VERSION')) as f: + version = f.readline()[1:-1] setuptools.setup( name="damask", - version="0.0.1", + version=version, author="The DAMASK team", author_email="damask@mpie.de", description="Python library for DAMASK", long_description='test', - long_description_content_type="text/markdown", - url="https://github.com/pypa/sampleproject", + #long_description_content_type="text/markdown", + url="https://damask.mpie.de", packages=setuptools.find_packages(), + include_package_data=True, classifiers=[ "Programming Language :: Python :: 3", "License :: OSI Approved :: GLPv3", From a2887e39183baa3f73bab824f231fc7206a82165 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 27 Apr 2019 07:56:52 +0200 Subject: [PATCH 80/97] small portions are better readable --- CMakeLists.txt | 277 +------------------------------------ cmake/Compiler-GNU.cmake | 130 +++++++++++++++++ cmake/Compiler-Intel.cmake | 114 +++++++++++++++ cmake/Compiler-PGI.cmake | 25 ++++ 4 files changed, 273 insertions(+), 273 deletions(-) create mode 100644 cmake/Compiler-GNU.cmake create mode 100644 cmake/Compiler-Intel.cmake create mode 100644 cmake/Compiler-PGI.cmake diff --git a/CMakeLists.txt b/CMakeLists.txt index 78d63117e..34eefc3f8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -168,283 +168,14 @@ add_definitions (-DDAMASKVERSION="${DAMASK_V}") add_definitions (-DPETSc) set (DAMASK_INCLUDE_FLAGS "${DAMASK_INCLUDE_FLAGS} ${PETSC_INCLUDES}") +list(APPEND CMAKE_MODULE_PATH ${PROJECT_SOURCE_DIR}/cmake) -################################################################################################### -# Intel Compiler -################################################################################################### if (CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") - - if (OPENMP) - set (OPENMP_FLAGS "-qopenmp -parallel") - endif () - - if (OPTIMIZATION STREQUAL "OFF") - set (OPTIMIZATION_FLAGS "-O0 -no-ip") - elseif (OPTIMIZATION STREQUAL "DEFENSIVE") - set (OPTIMIZATION_FLAGS "-O2") - elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") - set (OPTIMIZATION_FLAGS "-ipo -O3 -no-prec-div -fp-model fast=2 -xHost") - # -fast = -ipo, -O3, -no-prec-div, -static, -fp-model fast=2, and -xHost" - endif () - - # -assume std_mod_proc_name (included in -standard-semantics) causes problems if other modules - # (PETSc, HDF5) are not compiled with this option (https://software.intel.com/en-us/forums/intel-fortran-compiler-for-linux-and-mac-os-x/topic/62172) - set (STANDARD_CHECK "-stand f15 -standard-semantics -assume nostd_mod_proc_name") - set (LINKER_FLAGS "${LINKER_FLAGS} -shared-intel") - # Link against shared Intel libraries instead of static ones - -#------------------------------------------------------------------------------------------------ -# Fine tuning compilation options - set (COMPILE_FLAGS "${COMPILE_FLAGS} -fpp") - # preprocessor - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -ftz") - # flush underflow to zero, automatically set if -O[1,2,3] - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -diag-disable") - # disables warnings ... - set (COMPILE_FLAGS "${COMPILE_FLAGS} 5268") - # ... the text exceeds right hand column allowed on the line (we have only comments there) - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -warn") - # enables warnings ... - set (COMPILE_FLAGS "${COMPILE_FLAGS} declarations") - # ... any undeclared names (alternative name: -implicitnone) - set (COMPILE_FLAGS "${COMPILE_FLAGS},general") - # ... warning messages and informational messages are issued by the compiler - set (COMPILE_FLAGS "${COMPILE_FLAGS},usage") - # ... questionable programming practices - set (COMPILE_FLAGS "${COMPILE_FLAGS},interfaces") - # ... checks the interfaces of all SUBROUTINEs called and FUNCTIONs invoked in your compilation against an external set of interface blocks - set (COMPILE_FLAGS "${COMPILE_FLAGS},ignore_loc") - # ... %LOC is stripped from an actual argument - set (COMPILE_FLAGS "${COMPILE_FLAGS},alignments") - # ... data that is not naturally aligned - set (COMPILE_FLAGS "${COMPILE_FLAGS},unused") - # ... declared variables that are never used - - # Additional options - # -warn: enables warnings, where - # truncated_source: Determines whether warnings occur when source exceeds the maximum column width in fixed-format files. - # (too many warnings because we have comments beyond character 132) - # uncalled: Determines whether warnings occur when a statement function is never called - # all: - # -name as_is: case sensitive Fortran! - -#------------------------------------------------------------------------------------------------ -# Runtime debugging - set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") - # Generate symbolic debugging information in the object file - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -traceback") - # Generate extra information in the object file to provide source file traceback information when a severe error occurs at run time - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -gen-interfaces") - # Generate an interface block for each routine. http://software.intel.com/en-us/blogs/2012/01/05/doctor-fortran-gets-explicit-again/ - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fp-stack-check") - # Generate extra code after every function call to ensure that the floating-point (FP) stack is in the expected state - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fp-model strict") - # Trap uninitalized variables - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -check" ) - # Checks at runtime ... - set (DEBUG_FLAGS "${DEBUG_FLAGS} bounds") - # ... if an array index is too small (<1) or too large! - set (DEBUG_FLAGS "${DEBUG_FLAGS},format") - # ... for the data type of an item being formatted for output. - set (DEBUG_FLAGS "${DEBUG_FLAGS},output_conversion") - # ... for the fit of data items within a designated format descriptor field. - set (DEBUG_FLAGS "${DEBUG_FLAGS},pointers") - # ... for certain disassociated or uninitialized pointers or unallocated allocatable objects. - set (DEBUG_FLAGS "${DEBUG_FLAGS},uninit") - # ... for uninitialized variables. - set (DEBUG_FLAGS "${DEBUG_FLAGS} -ftrapuv") - # ... initializes stack local variables to an unusual value to aid error detection - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fpe-all=0") - # ... capture all floating-point exceptions, sets -ftz automatically - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -warn") - # enables warnings ... - set (DEBUG_FLAGS "${DEBUG_FLAGS} errors") - # ... warnings are changed to errors - set (DEBUG_FLAGS "${DEBUG_FLAGS},stderrors") - # ... warnings about Fortran standard violations are changed to errors - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -debug-parameters all") - # generate debug information for parameters - - # Additional options - # -heap-arrays: Should not be done for OpenMP, but set "ulimit -s unlimited" on shell. Probably it helps also to unlimit other limits - # -check: Checks at runtime, where - # arg_temp_created: will cause a lot of warnings because we create a bunch of temporary arrays (performance?) - # stack: - -#------------------------------------------------------------------------------------------------ -# precision settings - set (PRECISION_FLAGS "${PRECISION_FLAGS} -real-size 64") - # set precision for standard real to 32 | 64 | 128 (= 4 | 8 | 16 bytes, type pReal is always 8 bytes) - - -################################################################################################### -# GNU Compiler -################################################################################################### + include(Compiler-Intel.cmake) elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") - - if (OPENMP) - set (OPENMP_FLAGS "-fopenmp") - endif () - - if (OPTIMIZATION STREQUAL "OFF") - set (OPTIMIZATION_FLAGS "-O0" ) - elseif (OPTIMIZATION STREQUAL "DEFENSIVE") - set (OPTIMIZATION_FLAGS "-O2") - elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") - set (OPTIMIZATION_FLAGS "-O3 -ffast-math -funroll-loops -ftree-vectorize") - endif () - - set (STANDARD_CHECK "-std=f2008ts -pedantic-errors" ) - set (LINKER_FLAGS "${LINKER_FLAGS} -Wl") - # options parsed directly to the linker - set (LINKER_FLAGS "${LINKER_FLAGS},-undefined,dynamic_lookup" ) - # ensure to link against dynamic libraries - -#------------------------------------------------------------------------------------------------ -# Fine tuning compilation options - set (COMPILE_FLAGS "${COMPILE_FLAGS} -xf95-cpp-input") - # preprocessor - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -ffree-line-length-132") - # restrict line length to the standard 132 characters (lattice.f90 require more characters) - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -fimplicit-none") - # assume "implicit none" even if not present in source - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wall") - # sets the following Fortran options: - # -Waliasing: warn about possible aliasing of dummy arguments. Specifically, it warns if the same actual argument is associated with a dummy argument with "INTENT(IN)" and a dummy argument with "INTENT(OUT)" in a call with an explicit interface. - # -Wampersand: checks if a character expression is continued proberly by an ampersand at the end of the line and at the beginning of the new line - # -Warray-bounds: checks if array reference is out of bounds at compile time. use -fcheck-bounds to also check during runtime - # -Wconversion: warn about implicit conversions between different type - # -Wsurprising: warn when "suspicious" code constructs are encountered. While technically legal these usually indicate that an error has been made. - # -Wc-binding-type: - # -Wintrinsics-std: only standard intrisics are available, e.g. "call flush(6)" will cause an error - # -Wno-tabs: do not allow tabs in source - # -Wintrinsic-shadow: warn if a user-defined procedure or module procedure has the same name as an intrinsic - # -Wline-truncation: - # -Wtarget-lifetime: - # -Wreal-q-constant: warn about real-literal-constants with 'q' exponent-letter - # -Wunused: a number of unused-xxx warnings - # and sets the general (non-Fortran options) options: - # -Waddress - # -Warray-bounds (only with -O2) - # -Wc++11-compat - # -Wchar-subscripts - # -Wcomment - # -Wformat - # -Wmaybe-uninitialized - # -Wnonnull - # -Wparentheses - # -Wpointer-sign - # -Wreorder - # -Wreturn-type - # -Wsequence-point - # -Wstrict-aliasing - # -Wstrict-overflow=1 - # -Wswitch - # -Wtrigraphs - # -Wuninitialized - # -Wunknown-pragmas - # -Wunused-function - # -Wunused-label - # -Wunused-value - # -Wunused-variable - # -Wvolatile-register-var - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wextra") - # sets the following Fortran options: - # -Wunuses-parameter: - # -Wcompare-reals: - # and sets the general (non-Fortran options) options: - # -Wclobbered - # -Wempty-body - # -Wignored-qualifiers - # -Wmissing-field-initializers - # -Woverride-init - # -Wsign-compare - # -Wtype-limits - # -Wuninitialized - # -Wunused-but-set-parameter (only with -Wunused or -Wall) - # -Wno-globals - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wcharacter-truncation") - # warn if character expressions (strings) are truncated - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wunderflow") - # produce a warning when numerical constant expressions are encountered, which yield an UNDERFLOW during compilation - - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wsuggest-attribute=pure") - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wsuggest-attribute=noreturn") - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wconversion-extra") - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wimplicit-procedure") - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wno-unused-parameter") - set (COMPILE_FLAGS "${COMPILE_FLAGS} -ffpe-summary=all") - # print summary of floating point exeptions (invalid,zero,overflow,underflow,inexact,denormal) - - # Additional options - # -Warray-temporarieswarnings: because we have many temporary arrays (performance issue?): - # -Wimplicit-interface: no interfaces for lapack/MPI routines - # -Wunsafe-loop-optimizations: warn if the loop cannot be optimized due to nontrivial assumptions. - -#------------------------------------------------------------------------------------------------ -# Runtime debugging - set (DEBUG_FLAGS "${DEBUG_FLAGS} -ffpe-trap=invalid,zero,overflow") - # stop execution if floating point exception is detected (NaN is silent) - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") - # Generate symbolic debugging information in the object file - - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fbacktrace") - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fdump-core") - set (DEBUG_FLAGS "${DEBUG_FLAGS} -fcheck=all") - # checks for (array-temps,bounds,do,mem,pointer,recursion) - - # Additional options - # -ffpe-trap=precision,denormal,underflow -#------------------------------------------------------------------------------------------------ -# precision settings - set (PRECISION_FLAGS "${PRECISION_FLAGS} -fdefault-real-8") - # set precision to 8 bytes for standard real (=8 for pReal). Will set size of double to 16 bytes as long as -fdefault-double-8 is not set - set (PRECISION_FLAGS "${PRECISION_FLAGS} -fdefault-double-8") - # set precision to 8 bytes for double real, would be 16 bytes if -fdefault-real-8 is used - - -################################################################################################### -# PGI Compiler -################################################################################################### + include(Compiler-GNU) elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "PGI") - - if (OPTIMIZATION STREQUAL "OFF") - set (OPTIMIZATION_FLAGS "-O0" ) - elseif (OPTIMIZATION STREQUAL "DEFENSIVE") - set (OPTIMIZATION_FLAGS "-O2") - elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") - set (OPTIMIZATION_FLAGS "-O3") - endif () - - -#------------------------------------------------------------------------------------------------ -# Fine tuning compilation options - set (COMPILE_FLAGS "${COMPILE_FLAGS} -Mpreprocess") - # preprocessor - - set (STANDARD_CHECK "-Mallocatable=03") - -#------------------------------------------------------------------------------------------------ -# Runtime debugging - set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") - # Includes debugging information in the object module; sets the optimization level to zero unless a -⁠O option is present on the command line + include(Compiler-PGI) else () message (FATAL_ERROR "Compiler type (CMAKE_Fortran_COMPILER_ID) not recognized") endif () diff --git a/cmake/Compiler-GNU.cmake b/cmake/Compiler-GNU.cmake new file mode 100644 index 000000000..008c0c90e --- /dev/null +++ b/cmake/Compiler-GNU.cmake @@ -0,0 +1,130 @@ +################################################################################################### +# GNU Compiler +################################################################################################### + + if (OPENMP) + set (OPENMP_FLAGS "-fopenmp") + endif () + + if (OPTIMIZATION STREQUAL "OFF") + set (OPTIMIZATION_FLAGS "-O0" ) + elseif (OPTIMIZATION STREQUAL "DEFENSIVE") + set (OPTIMIZATION_FLAGS "-O2") + elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") + set (OPTIMIZATION_FLAGS "-O3 -ffast-math -funroll-loops -ftree-vectorize") + endif () + + set (STANDARD_CHECK "-std=f2008ts -pedantic-errors" ) + set (LINKER_FLAGS "${LINKER_FLAGS} -Wl") + # options parsed directly to the linker + set (LINKER_FLAGS "${LINKER_FLAGS},-undefined,dynamic_lookup" ) + # ensure to link against dynamic libraries + +#------------------------------------------------------------------------------------------------ +# Fine tuning compilation options + set (COMPILE_FLAGS "${COMPILE_FLAGS} -xf95-cpp-input") + # preprocessor + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -ffree-line-length-132") + # restrict line length to the standard 132 characters (lattice.f90 require more characters) + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -fimplicit-none") + # assume "implicit none" even if not present in source + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wall") + # sets the following Fortran options: + # -Waliasing: warn about possible aliasing of dummy arguments. Specifically, it warns if the same actual argument is associated with a dummy argument with "INTENT(IN)" and a dummy argument with "INTENT(OUT)" in a call with an explicit interface. + # -Wampersand: checks if a character expression is continued proberly by an ampersand at the end of the line and at the beginning of the new line + # -Warray-bounds: checks if array reference is out of bounds at compile time. use -fcheck-bounds to also check during runtime + # -Wconversion: warn about implicit conversions between different type + # -Wsurprising: warn when "suspicious" code constructs are encountered. While technically legal these usually indicate that an error has been made. + # -Wc-binding-type: + # -Wintrinsics-std: only standard intrisics are available, e.g. "call flush(6)" will cause an error + # -Wno-tabs: do not allow tabs in source + # -Wintrinsic-shadow: warn if a user-defined procedure or module procedure has the same name as an intrinsic + # -Wline-truncation: + # -Wtarget-lifetime: + # -Wreal-q-constant: warn about real-literal-constants with 'q' exponent-letter + # -Wunused: a number of unused-xxx warnings + # and sets the general (non-Fortran options) options: + # -Waddress + # -Warray-bounds (only with -O2) + # -Wc++11-compat + # -Wchar-subscripts + # -Wcomment + # -Wformat + # -Wmaybe-uninitialized + # -Wnonnull + # -Wparentheses + # -Wpointer-sign + # -Wreorder + # -Wreturn-type + # -Wsequence-point + # -Wstrict-aliasing + # -Wstrict-overflow=1 + # -Wswitch + # -Wtrigraphs + # -Wuninitialized + # -Wunknown-pragmas + # -Wunused-function + # -Wunused-label + # -Wunused-value + # -Wunused-variable + # -Wvolatile-register-var + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wextra") + # sets the following Fortran options: + # -Wunuses-parameter: + # -Wcompare-reals: + # and sets the general (non-Fortran options) options: + # -Wclobbered + # -Wempty-body + # -Wignored-qualifiers + # -Wmissing-field-initializers + # -Woverride-init + # -Wsign-compare + # -Wtype-limits + # -Wuninitialized + # -Wunused-but-set-parameter (only with -Wunused or -Wall) + # -Wno-globals + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wcharacter-truncation") + # warn if character expressions (strings) are truncated + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wunderflow") + # produce a warning when numerical constant expressions are encountered, which yield an UNDERFLOW during compilation + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wsuggest-attribute=pure") + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wsuggest-attribute=noreturn") + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wconversion-extra") + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wimplicit-procedure") + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Wno-unused-parameter") + set (COMPILE_FLAGS "${COMPILE_FLAGS} -ffpe-summary=all") + # print summary of floating point exeptions (invalid,zero,overflow,underflow,inexact,denormal) + + # Additional options + # -Warray-temporarieswarnings: because we have many temporary arrays (performance issue?): + # -Wimplicit-interface: no interfaces for lapack/MPI routines + # -Wunsafe-loop-optimizations: warn if the loop cannot be optimized due to nontrivial assumptions. + +#------------------------------------------------------------------------------------------------ +# Runtime debugging + set (DEBUG_FLAGS "${DEBUG_FLAGS} -ffpe-trap=invalid,zero,overflow") + # stop execution if floating point exception is detected (NaN is silent) + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") + # Generate symbolic debugging information in the object file + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fbacktrace") + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fdump-core") + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fcheck=all") + # checks for (array-temps,bounds,do,mem,pointer,recursion) + + # Additional options + # -ffpe-trap=precision,denormal,underflow +#------------------------------------------------------------------------------------------------ +# precision settings + set (PRECISION_FLAGS "${PRECISION_FLAGS} -fdefault-real-8") + # set precision to 8 bytes for standard real (=8 for pReal). Will set size of double to 16 bytes as long as -fdefault-double-8 is not set + set (PRECISION_FLAGS "${PRECISION_FLAGS} -fdefault-double-8") + # set precision to 8 bytes for double real, would be 16 bytes if -fdefault-real-8 is used diff --git a/cmake/Compiler-Intel.cmake b/cmake/Compiler-Intel.cmake new file mode 100644 index 000000000..998f60326 --- /dev/null +++ b/cmake/Compiler-Intel.cmake @@ -0,0 +1,114 @@ +################################################################################################### +# Intel Compiler +################################################################################################### + if (OPENMP) + set (OPENMP_FLAGS "-qopenmp -parallel") + endif () + + if (OPTIMIZATION STREQUAL "OFF") + set (OPTIMIZATION_FLAGS "-O0 -no-ip") + elseif (OPTIMIZATION STREQUAL "DEFENSIVE") + set (OPTIMIZATION_FLAGS "-O2") + elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") + set (OPTIMIZATION_FLAGS "-ipo -O3 -no-prec-div -fp-model fast=2 -xHost") + # -fast = -ipo, -O3, -no-prec-div, -static, -fp-model fast=2, and -xHost" + endif () + + # -assume std_mod_proc_name (included in -standard-semantics) causes problems if other modules + # (PETSc, HDF5) are not compiled with this option (https://software.intel.com/en-us/forums/intel-fortran-compiler-for-linux-and-mac-os-x/topic/62172) + set (STANDARD_CHECK "-stand f15 -standard-semantics -assume nostd_mod_proc_name") + set (LINKER_FLAGS "${LINKER_FLAGS} -shared-intel") + # Link against shared Intel libraries instead of static ones + +#------------------------------------------------------------------------------------------------ +# Fine tuning compilation options + set (COMPILE_FLAGS "${COMPILE_FLAGS} -fpp") + # preprocessor + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -ftz") + # flush underflow to zero, automatically set if -O[1,2,3] + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -diag-disable") + # disables warnings ... + set (COMPILE_FLAGS "${COMPILE_FLAGS} 5268") + # ... the text exceeds right hand column allowed on the line (we have only comments there) + + set (COMPILE_FLAGS "${COMPILE_FLAGS} -warn") + # enables warnings ... + set (COMPILE_FLAGS "${COMPILE_FLAGS} declarations") + # ... any undeclared names (alternative name: -implicitnone) + set (COMPILE_FLAGS "${COMPILE_FLAGS},general") + # ... warning messages and informational messages are issued by the compiler + set (COMPILE_FLAGS "${COMPILE_FLAGS},usage") + # ... questionable programming practices + set (COMPILE_FLAGS "${COMPILE_FLAGS},interfaces") + # ... checks the interfaces of all SUBROUTINEs called and FUNCTIONs invoked in your compilation against an external set of interface blocks + set (COMPILE_FLAGS "${COMPILE_FLAGS},ignore_loc") + # ... %LOC is stripped from an actual argument + set (COMPILE_FLAGS "${COMPILE_FLAGS},alignments") + # ... data that is not naturally aligned + set (COMPILE_FLAGS "${COMPILE_FLAGS},unused") + # ... declared variables that are never used + + # Additional options + # -warn: enables warnings, where + # truncated_source: Determines whether warnings occur when source exceeds the maximum column width in fixed-format files. + # (too many warnings because we have comments beyond character 132) + # uncalled: Determines whether warnings occur when a statement function is never called + # all: + # -name as_is: case sensitive Fortran! + +#------------------------------------------------------------------------------------------------ +# Runtime debugging + set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") + # Generate symbolic debugging information in the object file + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -traceback") + # Generate extra information in the object file to provide source file traceback information when a severe error occurs at run time + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -gen-interfaces") + # Generate an interface block for each routine. http://software.intel.com/en-us/blogs/2012/01/05/doctor-fortran-gets-explicit-again/ + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fp-stack-check") + # Generate extra code after every function call to ensure that the floating-point (FP) stack is in the expected state + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fp-model strict") + # Trap uninitalized variables + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -check" ) + # Checks at runtime ... + set (DEBUG_FLAGS "${DEBUG_FLAGS} bounds") + # ... if an array index is too small (<1) or too large! + set (DEBUG_FLAGS "${DEBUG_FLAGS},format") + # ... for the data type of an item being formatted for output. + set (DEBUG_FLAGS "${DEBUG_FLAGS},output_conversion") + # ... for the fit of data items within a designated format descriptor field. + set (DEBUG_FLAGS "${DEBUG_FLAGS},pointers") + # ... for certain disassociated or uninitialized pointers or unallocated allocatable objects. + set (DEBUG_FLAGS "${DEBUG_FLAGS},uninit") + # ... for uninitialized variables. + set (DEBUG_FLAGS "${DEBUG_FLAGS} -ftrapuv") + # ... initializes stack local variables to an unusual value to aid error detection + set (DEBUG_FLAGS "${DEBUG_FLAGS} -fpe-all=0") + # ... capture all floating-point exceptions, sets -ftz automatically + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -warn") + # enables warnings ... + set (DEBUG_FLAGS "${DEBUG_FLAGS} errors") + # ... warnings are changed to errors + set (DEBUG_FLAGS "${DEBUG_FLAGS},stderrors") + # ... warnings about Fortran standard violations are changed to errors + + set (DEBUG_FLAGS "${DEBUG_FLAGS} -debug-parameters all") + # generate debug information for parameters + + # Additional options + # -heap-arrays: Should not be done for OpenMP, but set "ulimit -s unlimited" on shell. Probably it helps also to unlimit other limits + # -check: Checks at runtime, where + # arg_temp_created: will cause a lot of warnings because we create a bunch of temporary arrays (performance?) + # stack: + +#------------------------------------------------------------------------------------------------ +# precision settings + set (PRECISION_FLAGS "${PRECISION_FLAGS} -real-size 64") + # set precision for standard real to 32 | 64 | 128 (= 4 | 8 | 16 bytes, type pReal is always 8 bytes) diff --git a/cmake/Compiler-PGI.cmake b/cmake/Compiler-PGI.cmake new file mode 100644 index 000000000..bca76f648 --- /dev/null +++ b/cmake/Compiler-PGI.cmake @@ -0,0 +1,25 @@ +################################################################################################### +# PGI Compiler +################################################################################################### +elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "PGI") + + if (OPTIMIZATION STREQUAL "OFF") + set (OPTIMIZATION_FLAGS "-O0" ) + elseif (OPTIMIZATION STREQUAL "DEFENSIVE") + set (OPTIMIZATION_FLAGS "-O2") + elseif (OPTIMIZATION STREQUAL "AGGRESSIVE") + set (OPTIMIZATION_FLAGS "-O3") + endif () + + +#------------------------------------------------------------------------------------------------ +# Fine tuning compilation options + set (COMPILE_FLAGS "${COMPILE_FLAGS} -Mpreprocess") + # preprocessor + + set (STANDARD_CHECK "-Mallocatable=03") + +#------------------------------------------------------------------------------------------------ +# Runtime debugging + set (DEBUG_FLAGS "${DEBUG_FLAGS} -g") + # Includes debugging information in the object module; sets the optimization level to zero unless a -⁠O option is present on the command line From 7041c1508a7dce6aa984debb4d2825f9b23110a1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 27 Apr 2019 10:19:11 +0200 Subject: [PATCH 81/97] giving extension does not work --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 34eefc3f8..b4d2613c6 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -171,7 +171,7 @@ set (DAMASK_INCLUDE_FLAGS "${DAMASK_INCLUDE_FLAGS} ${PETSC_INCLUDES}") list(APPEND CMAKE_MODULE_PATH ${PROJECT_SOURCE_DIR}/cmake) if (CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") - include(Compiler-Intel.cmake) + include(Compiler-Intel) elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") include(Compiler-GNU) elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "PGI") From 7b04b76112076612208f2976580ec67ca30aae21 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sat, 27 Apr 2019 17:55:06 +0200 Subject: [PATCH 82/97] check for undefined variables defined but empty variables are different --- CMakeLists.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 0cfe47248..e0ec3d136 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -138,14 +138,14 @@ elseif (CMAKE_BUILD_TYPE STREQUAL "PERFORMANCE") endif () # $OPTIMIZATION takes precedence over $BUILD_TYPE defaults -if (OPTIMIZATION STREQUAL "") +if (OPTIMIZATION STREQUAL "" OR NOT DEFINED OPTIMIZATION) set (OPTIMIZATION "${OPTI}") else () set (OPTIMIZATION "${OPTIMIZATION}") endif () # $OPENMP takes precedence over $BUILD_TYPE defaults -if (OPENMP STREQUAL "") +if (OPENMP STREQUAL "" OR NOT DEFINED OPENMP) set (OPENMP "${PARALLEL}") else () set(OPENMP "${OPENMP}") From 55d0c0dad1f80e6ba8c46e65beaf615e9fb5b4fe Mon Sep 17 00:00:00 2001 From: Test User Date: Sat, 27 Apr 2019 20:09:03 +0200 Subject: [PATCH 83/97] [skip ci] updated version information after successful test of v2.0.3-138-g7b04b761 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index a55a6e6d5..4d6205d89 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.3-130-gda034f97 +v2.0.3-138-g7b04b761 From 948680df74dd3cebc19e20bda0bcece2539c1e72 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 28 Apr 2019 07:00:15 +0200 Subject: [PATCH 84/97] not needed anymore --- .gitignore | 3 --- 1 file changed, 3 deletions(-) diff --git a/.gitignore b/.gitignore index 2a118ef29..c34f2f0b7 100644 --- a/.gitignore +++ b/.gitignore @@ -1,8 +1,5 @@ *.pyc -*.mod -*.o *.hdf5 -*.exe *.bak *~ bin From c72518e52b91057f86265d9f162ed457a04dbaa2 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 28 Apr 2019 07:22:12 +0200 Subject: [PATCH 85/97] reflects current temp files --- python/.gitignore | 1 + python/damask/.gitignore | 3 --- 2 files changed, 1 insertion(+), 3 deletions(-) delete mode 100644 python/damask/.gitignore diff --git a/python/.gitignore b/python/.gitignore index 1521c8b76..bd729dc2c 100644 --- a/python/.gitignore +++ b/python/.gitignore @@ -1 +1,2 @@ dist +damask.egg-info diff --git a/python/damask/.gitignore b/python/damask/.gitignore deleted file mode 100644 index 1b8936623..000000000 --- a/python/damask/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -core.so -corientation.so -*.pyx From 327a8ab757cf4c3489046c3b49aa2ab152f54137 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 28 Apr 2019 12:04:11 +0200 Subject: [PATCH 86/97] more details --- python/setup.py | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/python/setup.py b/python/setup.py index e49872354..515401c59 100644 --- a/python/setup.py +++ b/python/setup.py @@ -9,15 +9,20 @@ setuptools.setup( version=version, author="The DAMASK team", author_email="damask@mpie.de", - description="Python library for DAMASK", - long_description='test', - #long_description_content_type="text/markdown", + description="DAMASK library", + long_description="Python library for pre and post processing of DAMASK simulations", url="https://damask.mpie.de", packages=setuptools.find_packages(), include_package_data=True, - classifiers=[ + install_requires = [ + "scipy", + "h5py", + "vtk" + ], + license = 'GPL3', + classifiers = [ "Programming Language :: Python :: 3", - "License :: OSI Approved :: GLPv3", + "License :: OSI Approved :: GPL3", "Operating System :: OS Independent", ], ) From d6c59c5d733e200b5e53abfb43742772b9271c6e Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 28 Apr 2019 12:07:15 +0200 Subject: [PATCH 87/97] mesh is a better suited name for FEM because we have an FEM solver for grid --- Makefile | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/Makefile b/Makefile index 161d4c3ce..1e2f9db9f 100644 --- a/Makefile +++ b/Makefile @@ -4,29 +4,29 @@ SHELL = /bin/sh ######################################################################################## DAMASK_ROOT = $(shell python -c "import os,sys; print(os.path.normpath(os.path.realpath(os.path.expanduser('$(pwd)'))))") .PHONY: all -all: grid FEM processing +all: grid mesh processing .PHONY: grid grid: build/grid @(cd build/grid;make -j4 --no-print-directory -ws all install;) - .PHONY: spectral -spectral: build/grid - @(cd build/grid;make -j4 --no-print-directory -ws all install;) +spectral: grid +.PHONY: mesh +mesh: build/mesh + @(cd build/mesh; make -j4 --no-print-directory -ws all install;) .PHONY: FEM -FEM: build/FEM - @(cd build/FEM; make -j4 --no-print-directory -ws all install;) +FEM: mesh .PHONY: build/grid build/grid: @mkdir -p build/grid @(cd build/grid; cmake -Wno-dev -DDAMASK_SOLVER=GRID -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT} -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) -.PHONY: build/FEM -build/FEM: - @mkdir -p build/FEM - @(cd build/FEM; cmake -Wno-dev -DDAMASK_SOLVER=FEM -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT} -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) +.PHONY: build/mesh +build/mesh: + @mkdir -p build/mesh + @(cd build/mesh; cmake -Wno-dev -DDAMASK_SOLVER=FEM -DCMAKE_INSTALL_PREFIX=${DAMASK_ROOT} -DCMAKE_BUILD_TYPE=${BUILD_TYPE} -DBUILDCMD_POST=${BUILDCMD_POST} -DBUILDCMD_PRE=${BUILDCMD_PRE} -DOPTIMIZATION=${OPTIMIZATION} -DOPENMP=${OPENMP} ../../;) .PHONY: clean clean: From 2ea07950ff4c0d195b7b3bad4f3b2ee1a7e68ada Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Sun, 28 Apr 2019 12:54:59 +0200 Subject: [PATCH 88/97] case insensitive comparison for project name accept also mesh for FEM --- CMakeLists.txt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index a80f19757..6c9bbea04 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -105,11 +105,12 @@ set (CMAKE_C_COMPILER "${PETSC_MPICC}") # Now start to care about DAMASK # DAMASK solver defines project to build -if (DAMASK_SOLVER STREQUAL "GRID") +string(TOLOWER ${DAMASK_SOLVER} DAMASK_SOLVER) +if (DAMASK_SOLVER STREQUAL "grid") project (damask-grid Fortran C) add_definitions (-DGrid) message ("Building Grid Solver\n") -elseif (DAMASK_SOLVER STREQUAL "FEM") +elseif (DAMASK_SOLVER STREQUAL "fem" OR DAMASK_SOLVER STREQUAL "mesh") project (damask-mesh Fortran C) add_definitions (-DFEM) message ("Building FEM Solver\n") From cc7e6d237e0be31d6d77e1c0eadee3281a731127 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 29 Apr 2019 10:18:39 +0200 Subject: [PATCH 89/97] options not needed --- Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 1e2f9db9f..b24e3d36b 100644 --- a/Makefile +++ b/Makefile @@ -8,13 +8,13 @@ all: grid mesh processing .PHONY: grid grid: build/grid - @(cd build/grid;make -j4 --no-print-directory -ws all install;) + @(cd build/grid;make -j4 all install;) .PHONY: spectral spectral: grid .PHONY: mesh mesh: build/mesh - @(cd build/mesh; make -j4 --no-print-directory -ws all install;) + @(cd build/mesh; make -j4 all install;) .PHONY: FEM FEM: mesh From 477478f66c98b2e2c396945b2a6a05b5797ff50c Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 29 Apr 2019 10:43:49 +0200 Subject: [PATCH 90/97] source code structure reflects build targets --- src/{ => grid}/DAMASK_grid.f90 | 0 src/{ => grid}/grid_damage_spectral.f90 | 0 src/{ => grid}/grid_mech_FEM.f90 | 0 src/{ => grid}/grid_mech_spectral_basic.f90 | 0 src/{ => grid}/grid_mech_spectral_polarisation.f90 | 0 src/{ => grid}/grid_thermal_spectral.f90 | 0 src/{ => grid}/spectral_utilities.f90 | 0 src/{ => mesh}/DAMASK_FEM.f90 | 0 src/{ => mesh}/FEM_mech.f90 | 0 src/{ => mesh}/FEM_utilities.f90 | 0 src/{ => mesh}/FEM_zoo.f90 | 0 src/{ => mesh}/mesh_FEM.f90 | 0 12 files changed, 0 insertions(+), 0 deletions(-) rename src/{ => grid}/DAMASK_grid.f90 (100%) rename src/{ => grid}/grid_damage_spectral.f90 (100%) rename src/{ => grid}/grid_mech_FEM.f90 (100%) rename src/{ => grid}/grid_mech_spectral_basic.f90 (100%) rename src/{ => grid}/grid_mech_spectral_polarisation.f90 (100%) rename src/{ => grid}/grid_thermal_spectral.f90 (100%) rename src/{ => grid}/spectral_utilities.f90 (100%) rename src/{ => mesh}/DAMASK_FEM.f90 (100%) rename src/{ => mesh}/FEM_mech.f90 (100%) rename src/{ => mesh}/FEM_utilities.f90 (100%) rename src/{ => mesh}/FEM_zoo.f90 (100%) rename src/{ => mesh}/mesh_FEM.f90 (100%) diff --git a/src/DAMASK_grid.f90 b/src/grid/DAMASK_grid.f90 similarity index 100% rename from src/DAMASK_grid.f90 rename to src/grid/DAMASK_grid.f90 diff --git a/src/grid_damage_spectral.f90 b/src/grid/grid_damage_spectral.f90 similarity index 100% rename from src/grid_damage_spectral.f90 rename to src/grid/grid_damage_spectral.f90 diff --git a/src/grid_mech_FEM.f90 b/src/grid/grid_mech_FEM.f90 similarity index 100% rename from src/grid_mech_FEM.f90 rename to src/grid/grid_mech_FEM.f90 diff --git a/src/grid_mech_spectral_basic.f90 b/src/grid/grid_mech_spectral_basic.f90 similarity index 100% rename from src/grid_mech_spectral_basic.f90 rename to src/grid/grid_mech_spectral_basic.f90 diff --git a/src/grid_mech_spectral_polarisation.f90 b/src/grid/grid_mech_spectral_polarisation.f90 similarity index 100% rename from src/grid_mech_spectral_polarisation.f90 rename to src/grid/grid_mech_spectral_polarisation.f90 diff --git a/src/grid_thermal_spectral.f90 b/src/grid/grid_thermal_spectral.f90 similarity index 100% rename from src/grid_thermal_spectral.f90 rename to src/grid/grid_thermal_spectral.f90 diff --git a/src/spectral_utilities.f90 b/src/grid/spectral_utilities.f90 similarity index 100% rename from src/spectral_utilities.f90 rename to src/grid/spectral_utilities.f90 diff --git a/src/DAMASK_FEM.f90 b/src/mesh/DAMASK_FEM.f90 similarity index 100% rename from src/DAMASK_FEM.f90 rename to src/mesh/DAMASK_FEM.f90 diff --git a/src/FEM_mech.f90 b/src/mesh/FEM_mech.f90 similarity index 100% rename from src/FEM_mech.f90 rename to src/mesh/FEM_mech.f90 diff --git a/src/FEM_utilities.f90 b/src/mesh/FEM_utilities.f90 similarity index 100% rename from src/FEM_utilities.f90 rename to src/mesh/FEM_utilities.f90 diff --git a/src/FEM_zoo.f90 b/src/mesh/FEM_zoo.f90 similarity index 100% rename from src/FEM_zoo.f90 rename to src/mesh/FEM_zoo.f90 diff --git a/src/mesh_FEM.f90 b/src/mesh/mesh_FEM.f90 similarity index 100% rename from src/mesh_FEM.f90 rename to src/mesh/mesh_FEM.f90 From 39e6cedfb489563a4115a61d91e61e33ab4dbaae Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 29 Apr 2019 11:15:23 +0200 Subject: [PATCH 91/97] more direct and readable --- src/CMakeLists.txt | 37 +++++++++++++------------------------ 1 file changed, 13 insertions(+), 24 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 736db112a..b2eee5561 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -4,30 +4,26 @@ if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") SET_SOURCE_FILES_PROPERTIES("lattice.f90" PROPERTIES COMPILE_FLAGS "-ffree-line-length-240") endif() -file(GLOB_RECURSE sources *.f90 *.c) +file(GLOB damask-sources *.f90 *.c) # probably we should have subfolders for abaqus and MSC.Marc -list(FILTER sources EXCLUDE REGEX ".*CPFEM\\.f90") -list(FILTER sources EXCLUDE REGEX ".*DAMASK_marc.*\\.f90") -list(FILTER sources EXCLUDE REGEX ".*mesh_marc.*\\.f90") -list(FILTER sources EXCLUDE REGEX ".*mesh_abaqus.*\\.f90") -list(FILTER sources EXCLUDE REGEX ".*commercialFEM_fileList.*\\.f90") +list(FILTER damask-sources EXCLUDE REGEX ".*CPFEM.f90") +list(FILTER damask-sources EXCLUDE REGEX ".*DAMASK_marc.*.f90") +list(FILTER damask-sources EXCLUDE REGEX ".*mesh_marc.*.f90") +list(FILTER damask-sources EXCLUDE REGEX ".*mesh_abaqus.*.f90") +list(FILTER damask-sources EXCLUDE REGEX ".*commercialFEM_fileList.*.f90") if (PROJECT_NAME STREQUAL "damask-grid") - # probably we should have subfolders for FEM and spectral - list(FILTER sources EXCLUDE REGEX ".*DAMASK_FEM.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*FEM_utilities.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*FEM_zoo.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*mesh_FEM.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*FEM_mech.*\\.f90") + list(FILTER damask-sources EXCLUDE REGEX ".*mesh_FEM.*.f90") + file(GLOB grid-sources grid/*.f90) if(NOT CMAKE_BUILD_TYPE STREQUAL "SYNTAXONLY") - add_executable(DAMASK_spectral ${sources}) + add_executable(DAMASK_spectral ${damask-sources} ${grid-sources}) install (TARGETS DAMASK_spectral RUNTIME DESTINATION bin) else() - add_library(DAMASK_spectral OBJECT ${sources}) + add_library(DAMASK_spectral OBJECT ${damask-sources} ${grid-sources}) exec_program (mktemp OUTPUT_VARIABLE nothing) exec_program (mktemp ARGS -d OUTPUT_VARIABLE black_hole) install (PROGRAMS ${nothing} DESTINATION ${black_hole}) @@ -35,17 +31,10 @@ if (PROJECT_NAME STREQUAL "damask-grid") elseif (PROJECT_NAME STREQUAL "damask-mesh") - # probably we should have subfolders for FEM and spectral - list(FILTER sources EXCLUDE REGEX ".*DAMASK_grid.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*grid_mech_FEM.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*grid_mech_spectral_basic.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*grid_mech_spectral_polarisation.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*grid_damage_spectral.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*grid_thermal_spectral.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*spectral_utilities.*\\.f90") - list(FILTER sources EXCLUDE REGEX ".*mesh_grid.*\\.f90") + list(FILTER damask-sources EXCLUDE REGEX ".*mesh_grid.*.f90") + file(GLOB mesh-sources mesh/*.f90) - add_executable(DAMASK_FEM ${sources}) + add_executable(DAMASK_FEM ${damask-sources} ${mesh-sources}) install (TARGETS DAMASK_FEM RUNTIME DESTINATION bin) endif() From f628c80542e84fb51ea2de7398ac8935a742e1b0 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Mon, 29 Apr 2019 12:17:33 +0200 Subject: [PATCH 92/97] not supported anymore --- src/MarcInclude/concom2016 | 417 ------------------------------------ src/MarcInclude/concom2017 | 424 ------------------------------------- src/MarcInclude/creeps2016 | 66 ------ src/MarcInclude/creeps2017 | 66 ------ 4 files changed, 973 deletions(-) delete mode 100644 src/MarcInclude/concom2016 delete mode 100644 src/MarcInclude/concom2017 delete mode 100644 src/MarcInclude/creeps2016 delete mode 100644 src/MarcInclude/creeps2017 diff --git a/src/MarcInclude/concom2016 b/src/MarcInclude/concom2016 deleted file mode 100644 index e26774bfc..000000000 --- a/src/MarcInclude/concom2016 +++ /dev/null @@ -1,417 +0,0 @@ -! common block definition file taken from respective MSC.Marc release and reformated to free format -!*********************************************************************** -! -! File: concom.cmn -! -! MSC.Marc include file -! -integer(pInt) & - 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 -dimension :: ideva(60) -integer(pInt) num_concom -parameter(num_concom=245) -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 -! -! 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 -! 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 -! -! 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. -! 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 -! 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 -! 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 software (ADAMS-MARC) -! 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 -! -!*********************************************************************** -!$omp threadprivate(/marc_concom/) -!! diff --git a/src/MarcInclude/concom2017 b/src/MarcInclude/concom2017 deleted file mode 100644 index 08cc3b59b..000000000 --- a/src/MarcInclude/concom2017 +++ /dev/null @@ -1,424 +0,0 @@ -! common block definition file taken from respective MSC.Marc release and reformated to free format -!*********************************************************************** -! -! File: concom.cmn -! -! MSC.Marc include file -! -integer(pInt) & - 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 -dimension :: ideva(60) -integer(pInt) num_concom -parameter(num_concom=249) -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 -! -! 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 -! 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 -! -! 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. -! 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 -! 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 -! 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 software (ADAMS-MARC) -! 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) -! -!*********************************************************************** -!$omp threadprivate(/marc_concom/) -!! diff --git a/src/MarcInclude/creeps2016 b/src/MarcInclude/creeps2016 deleted file mode 100644 index 85c67492d..000000000 --- a/src/MarcInclude/creeps2016 +++ /dev/null @@ -1,66 +0,0 @@ -! 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(pInt) 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(pInt) num_creepsr,num_creepsi,num_creeps2r -parameter(num_creepsr=7) -parameter(num_creepsi=17) -parameter(num_creeps2r=6) -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 Pointer to constant 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 Pointer to storage of material id cross reference numbers. -! iicpmt -! iicpa Pointer to constant in creep strain rate expression -! -! time_beg_lcase time at the beginning of the current load case -! time_beg_inc time at the beginning of the current increment -! fractol fraction of loadcase or increment time when we -! consider it to be finished -! time_beg_pst time corresponding to first increment to be -! read in from thermal post file for auto step -! -! timinc_old Time step of the previous increment -! -!*********************************************************************** -!!$omp threadprivate(/marc_creeps/) -!!$omp threadprivate(/marc_creeps2/) -!! diff --git a/src/MarcInclude/creeps2017 b/src/MarcInclude/creeps2017 deleted file mode 100644 index 85c67492d..000000000 --- a/src/MarcInclude/creeps2017 +++ /dev/null @@ -1,66 +0,0 @@ -! 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(pInt) 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(pInt) num_creepsr,num_creepsi,num_creeps2r -parameter(num_creepsr=7) -parameter(num_creepsi=17) -parameter(num_creeps2r=6) -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 Pointer to constant 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 Pointer to storage of material id cross reference numbers. -! iicpmt -! iicpa Pointer to constant 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/) -!! From 7072a8beac829f5d67bb76521a4e7bf52dcf1947 Mon Sep 17 00:00:00 2001 From: Test User Date: Tue, 30 Apr 2019 01:39:52 +0200 Subject: [PATCH 93/97] [skip ci] updated version information after successful test of v2.0.3-152-gd74599d3 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 4d6205d89..00ca40975 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.3-138-g7b04b761 +v2.0.3-152-gd74599d3 From 9703d04a7df1043cf5e5b972e98ef504d14162ea Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 30 Apr 2019 06:31:03 +0200 Subject: [PATCH 94/97] grid/mesh for mesh needs rename keep the old naming/location for the moment consistently for all solvers --- src/{mesh => }/mesh_FEM.f90 | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/{mesh => }/mesh_FEM.f90 (100%) diff --git a/src/mesh/mesh_FEM.f90 b/src/mesh_FEM.f90 similarity index 100% rename from src/mesh/mesh_FEM.f90 rename to src/mesh_FEM.f90 From 9fe786d38b79d3ddc6bb02a46d7b3a3295307f0b Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Tue, 30 Apr 2019 06:37:10 +0200 Subject: [PATCH 95/97] including changes for deploying (some parts missing) - debian/ubuntu - arch linux - conda --- PRIVATE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/PRIVATE b/PRIVATE index f6171a748..212ac3b32 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit f6171a748e51b994db27c2cc74cc0168b7aea93f +Subproject commit 212ac3b326f3a15926d71109fec0173d95931b6b From c3a7b7b068184d1938e11a39954ceb61a0617aae Mon Sep 17 00:00:00 2001 From: Test User Date: Tue, 30 Apr 2019 16:10:23 +0200 Subject: [PATCH 96/97] [skip ci] updated version information after successful test of v2.0.3-183-gb72b6b66 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 00ca40975..40b83075b 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.3-152-gd74599d3 +v2.0.3-183-gb72b6b66 From ced3a13b1cd004cc51e34e18816ee53d3272a015 Mon Sep 17 00:00:00 2001 From: Test User Date: Wed, 1 May 2019 01:58:40 +0200 Subject: [PATCH 97/97] [skip ci] updated version information after successful test of v2.0.3-198-g1c762860 --- VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VERSION b/VERSION index 40b83075b..9096149dc 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -v2.0.3-183-gb72b6b66 +v2.0.3-198-g1c762860